1
#include <stdbool.h>
2
#define R_NO_REMAP
3
#include <Rinternals.h>
4
#include <R_ext/Rdynload.h>
5
#include <R_ext/Visibility.h>
6
#include "utils.h"
7

8
#define export attribute_visible extern
9

10

11
enum pipe_kind {
12
  PIPE_KIND_none = 0,
13
  PIPE_KIND_magrittr,
14
  PIPE_KIND_compound,
15
  PIPE_KIND_tee,
16
  PIPE_KIND_dollar
17
};
18

19
// Helper structures for unwind-protection of `.` restoration
20
struct pipe_info {
21
  SEXP exprs;
22
  SEXP env;
23
};
24
struct cleanup_info {
25
  SEXP old;
26
  SEXP env;
27
};
28

29
// Initialised at load time
30
static SEXP magrittr_ns_env = NULL;
31
static SEXP syms_lhs = NULL;
32
static SEXP syms_rhs = NULL;
33
static SEXP syms_kind = NULL;
34
static SEXP syms_env = NULL;
35
static SEXP syms_lazy = NULL;
36

37
static SEXP syms_assign = NULL;
38
static SEXP syms_bang = NULL;
39
static SEXP syms_curly = NULL;
40
static SEXP syms_dot = NULL;
41
static SEXP syms_nested = NULL;
42
static SEXP syms_new_lambda = NULL;
43
static SEXP syms_paren = NULL;
44
static SEXP syms_pipe = NULL;
45
static SEXP syms_pipe_compound = NULL;
46
static SEXP syms_pipe_dollar = NULL;
47
static SEXP syms_pipe_tee = NULL;
48
static SEXP syms_return = NULL;
49
static SEXP syms_sym = NULL;
50

51
static SEXP calls_base_with = NULL;
52
static SEXP chrs_dot = NULL;
53

54
static void clean_pipe(void* data);
55
static SEXP eval_pipe(void* data);
56
static SEXP eval_pipe_lazy(SEXP exprs, SEXP env);
57
static SEXP pipe_unroll(SEXP lhs, SEXP rhs, SEXP env, enum pipe_kind kind,
58
                        SEXP pipe_sym, SEXP* p_assign);
59
static SEXP pipe_nest(SEXP exprs);
60
static SEXP as_pipe_call(SEXP x);
61
static SEXP add_dot(SEXP x);
62
static inline SEXP as_pipe_tee_call(SEXP x);
63
static inline SEXP as_pipe_dollar_call(SEXP x);
64
static SEXP new_lambda(SEXP exprs, SEXP env);
65
static inline bool is_return(SEXP x);
66

67
// [[ register() ]]
68 1
SEXP magrittr_pipe(SEXP call, SEXP op, SEXP args, SEXP rho) {
69 1
  args = CDR(args);
70

71 1
  SEXP lhs = PROTECT(Rf_eval(syms_lhs, rho));
72 1
  SEXP rhs = PROTECT(Rf_eval(syms_rhs, rho));
73 1
  SEXP kind = PROTECT(Rf_eval(syms_kind, rho));
74 1
  SEXP env = PROTECT(Rf_eval(syms_env, rho));
75

76 1
  SEXP pipe_sym = r_env_get(rho, syms_sym);
77 1
  if (pipe_sym == R_UnboundValue) {
78 1
    pipe_sym = syms_pipe;
79
  }
80 1
  PROTECT(pipe_sym);
81

82 1
  enum pipe_kind c_kind = INTEGER(kind)[0];
83 1
  SEXP assign = R_NilValue;
84 1
  SEXP exprs = PROTECT(pipe_unroll(lhs, rhs, env, c_kind, pipe_sym, &assign));
85

86
  // Create a magrittr lambda when first expression is a `.`
87 1
  if (CAR(exprs) == syms_dot) {
88 1
    SEXP lambda = new_lambda(CDR(exprs), env);
89 1
    UNPROTECT(6);
90 1
    return lambda;
91
  }
92

93 1
  bool use_nested = Rf_findVar(syms_nested, rho) != R_UnboundValue;
94 1
  if (use_nested) {
95 1
    SEXP call = PROTECT(pipe_nest(exprs));
96 1
    SEXP out = Rf_eval(call, env);
97 1
    UNPROTECT(7);
98 1
    return out;
99
  }
100

101 1
  bool use_lazy = Rf_findVar(syms_lazy, rho) != R_UnboundValue;
102 1
  SEXP out = R_NilValue;
103

104 1
  if (use_lazy) {
105 1
    out = eval_pipe_lazy(exprs, env);
106
  } else {
107 1
    SEXP old = PROTECT(Rf_findVar(syms_dot, env));
108

109 1
    struct pipe_info pipe_info = {
110 1
      .exprs = exprs,
111 1
      .env = env
112
    };
113 1
    struct cleanup_info cleanup_info = {
114 1
      .old = old,
115 1
      .env = env
116
    };
117

118 1
    out =  R_ExecWithCleanup(eval_pipe, &pipe_info, &clean_pipe, &cleanup_info);
119 1
    UNPROTECT(1);
120
  }
121

122 1
  if (assign != R_NilValue) {
123 1
    PROTECT(out);
124 1
    SEXP call = PROTECT(Rf_lang3(syms_assign, assign, out));
125 1
    Rf_eval(call, env);
126 1
    UNPROTECT(2);
127
  }
128

129 1
  UNPROTECT(6);
130 1
  return out;
131
}
132

133
static
134 1
SEXP eval_pipe(void* data) {
135 1
  struct pipe_info* info = (struct pipe_info*) data;
136

137 1
  SEXP exprs = info->exprs;
138 1
  SEXP env = info->env;
139

140 1
  SEXP out = R_NilValue;
141 1
  while (exprs != R_NilValue) {
142 1
    out = PROTECT(Rf_eval(CAR(exprs), env));
143

144 1
    Rf_defineVar(syms_dot, out, env);
145 1
    UNPROTECT(1);
146

147 1
    exprs = CDR(exprs);
148
  }
149

150 1
  return out;
151
}
152

153
static
154 1
SEXP eval_pipe_lazy(SEXP exprs, SEXP env) {
155 1
  SEXP prev_mask = env;
156

157
  PROTECT_INDEX mask_pi;
158 1
  PROTECT_WITH_INDEX(R_NilValue, &mask_pi);
159

160 1
  SEXP rest = exprs;
161 1
  while ((rest = CDR(exprs)) != R_NilValue) {
162 1
    SEXP mask = r_new_environment(env);
163 1
    REPROTECT(mask, mask_pi);
164

165
    // Lazily bind current pipe expression to `.` in the new
166
    // mask. Evaluation occurs in the previous mask environment.
167
    // The promise is protected by `mask` and protects `prev_mask`.
168 1
    r_env_bind_lazy(mask, syms_dot, CAR(exprs), prev_mask);
169

170 1
    exprs = rest;
171 1
    prev_mask = mask;
172
  }
173

174
  // For compatibility, allow last expression to be `return()`.
175
  // Substitute it with `.` to avoid an error.
176 1
  SEXP last = CAR(exprs);
177 1
  if (is_return(last)) {
178 1
    last = syms_dot;
179
  }
180

181
  // Evaluate last expression in the very last mask. This triggers a
182
  // recursive evaluation of `.` bindings in the different masks.
183 1
  SEXP out = Rf_eval(last, prev_mask);
184

185 1
  UNPROTECT(1);
186 1
  return out;
187
}
188

189
static inline
190 1
bool is_return(SEXP x) {
191 1
  return TYPEOF(x) == LANGSXP && CAR(x) == syms_return;
192
}
193

194
static
195 1
void clean_pipe(void* data) {
196 1
  struct cleanup_info* info = (struct cleanup_info*) data;
197

198 1
  if (info->old == R_UnboundValue) {
199 1
    r_env_unbind(info->env, syms_dot);
200
  } else {
201 0
    Rf_defineVar(syms_dot, info->old, info->env);
202
  }
203
}
204

205

206
static enum pipe_kind parse_pipe_call(SEXP x, SEXP pipe_sym);
207

208
static
209 1
SEXP pipe_unroll(SEXP lhs,
210
                 SEXP rhs,
211
                 SEXP env,
212
                 enum pipe_kind kind,
213
                 SEXP pipe_sym,
214
                 SEXP* p_assign) {
215
  PROTECT_INDEX out_pi;
216 1
  SEXP out = R_NilValue;
217 1
  PROTECT_WITH_INDEX(out, &out_pi);
218

219
  PROTECT_INDEX rhs_pi;
220 1
  PROTECT_WITH_INDEX(rhs, &rhs_pi);
221

222 1
  while (true) {
223 1
    if (kind != PIPE_KIND_dollar && TYPEOF(rhs) == LANGSXP && CAR(rhs) == syms_paren) {
224 1
      rhs = Rf_eval(rhs, env);
225 1
      REPROTECT(rhs, rhs_pi);
226
    }
227

228 1
    switch (kind) {
229
    case PIPE_KIND_compound: {
230
      // Technically we want to give `%<>%` the same precedence as `<-`.
231
      // In practice, since we only support one top-level `%<>%, we
232
      // can just interpret it as `%>%` and communicate the assignment
233
      // variable via `p_assign`.
234 1
      *p_assign = lhs;
235 1
      rhs = as_pipe_call(rhs);
236 1
      break;
237
    }
238 1
    case PIPE_KIND_magrittr: rhs = as_pipe_call(rhs); break;
239 1
    case PIPE_KIND_tee: rhs = as_pipe_tee_call(rhs); break;
240 1
    case PIPE_KIND_dollar: rhs = as_pipe_dollar_call(rhs); break;
241 0
    case PIPE_KIND_none: Rf_error("Internal error in `pipe_unroll()`: Unexpected state.");
242
    }
243

244 1
    out = Rf_cons(rhs, out);
245 1
    REPROTECT(out, out_pi);
246

247 1
    SEXP args = CDR(lhs);
248

249 1
    if ((kind = parse_pipe_call(lhs, pipe_sym))) {
250 1
      lhs = CAR(args);
251 1
      rhs = CADR(args);
252 1
      continue;
253
    }
254

255 1
    break;
256
  }
257

258 1
  out = Rf_cons(lhs, out);
259

260 1
  UNPROTECT(2);
261 1
  return out;
262
}
263

264
static
265 1
enum pipe_kind parse_pipe_call(SEXP x, SEXP pipe_sym) {
266 1
  if (TYPEOF(x) != LANGSXP) {
267 1
    return PIPE_KIND_none;
268
  }
269

270 1
  SEXP car = CAR(x);
271

272 1
  if (car == pipe_sym) {
273 1
    return PIPE_KIND_magrittr;
274
  }
275 1
  if (car == syms_pipe_compound) {
276 1
    return PIPE_KIND_compound;
277
  }
278 1
  if (car == syms_pipe_tee) {
279 1
    return PIPE_KIND_tee;
280
  }
281 1
  if (car == syms_pipe_dollar) {
282 0
    return PIPE_KIND_dollar;
283
  }
284

285 1
  return PIPE_KIND_none;
286
}
287

288
static
289 1
SEXP as_pipe_call(SEXP x) {
290
  // Transform `foo` into `foo()`
291 1
  if (TYPEOF(x) != LANGSXP) {
292 1
    x = Rf_lcons(x, R_NilValue);
293
  }
294 1
  PROTECT(x);
295

296
  // Transform `foo()` into `foo(.)`
297 1
  x = add_dot(x);
298

299 1
  UNPROTECT(1);
300 1
  return x;
301
}
302

303
static inline
304 1
SEXP as_pipe_dollar_call(SEXP x) {
305 1
  return Rf_lang3(calls_base_with, syms_dot, x);
306
}
307

308
static inline
309 1
SEXP as_pipe_tee_call(SEXP x) {
310 1
  x = PROTECT(as_pipe_call(x));
311 1
  SEXP out = Rf_lang3(syms_curly, x, syms_dot);
312

313 1
  UNPROTECT(1);
314 1
  return out;
315
}
316

317
static inline
318 1
bool is_bang(SEXP x) {
319 1
  return TYPEOF(x) == LANGSXP && CAR(x) == syms_bang;
320
}
321

322
static
323 1
bool is_spliced_dot(SEXP x) {
324 1
  if (!is_bang(x)) {
325 1
    return false;
326
  }
327

328 1
  x = CADR(x);
329 1
  if (!is_bang(x)) {
330 0
    return false;
331
  }
332

333 1
  x = CADR(x);
334 1
  if (!is_bang(x)) {
335 0
    return false;
336
  }
337

338 1
  return CADR(x) == syms_dot;
339
}
340

341
static
342 1
SEXP add_dot(SEXP x) {
343 1
  if (TYPEOF(x) != LANGSXP) {
344 0
    return x;
345
  }
346

347 1
  SEXP args = CDR(x);
348 1
  while (args != R_NilValue) {
349 1
    SEXP arg = CAR(args);
350 1
    if (arg == syms_dot || is_spliced_dot(arg)) {
351 1
      return x;
352
    }
353 1
    args = CDR(args);
354
  }
355

356 1
  return Rf_lcons(CAR(x), Rf_cons(syms_dot, CDR(x)));
357
}
358

359

360
static
361 1
SEXP pipe_nest(SEXP exprs) {
362 1
  SEXP expr = CAR(exprs);
363 1
  SEXP prev = expr;
364 1
  exprs = CDR(exprs);
365

366
  PROTECT_INDEX expr_pi;
367 1
  PROTECT_WITH_INDEX(expr, &expr_pi);
368

369 1
  while (exprs != R_NilValue) {
370 1
    expr = Rf_shallow_duplicate(CAR(exprs));
371 1
    REPROTECT(expr, expr_pi);
372

373 1
    bool found_placeholder = false;
374 1
    SEXP curr = CDR(expr);
375

376 1
    while (curr != R_NilValue) {
377 1
      if (CAR(curr) == syms_dot) {
378 1
        if (found_placeholder) {
379 1
          Rf_errorcall(R_NilValue, "Can't use multiple placeholders.");
380
        }
381

382 1
        found_placeholder = true;
383 1
        SETCAR(curr, prev);
384 1
        prev = expr;
385
      }
386 1
      curr = CDR(curr);
387
    }
388 0
    if (!found_placeholder) {
389 0
      Rf_error("Internal error in `pipe_nest()`: Can't find placeholder.");
390
    }
391

392 0
    exprs = CDR(exprs);
393
  }
394

395 0
  UNPROTECT(1);
396 0
  return expr;
397
}
398

399
static
400 1
SEXP new_lambda(SEXP exprs, SEXP env) {
401 1
  SEXP call = PROTECT(Rf_lang3(syms_new_lambda, exprs, env));
402 1
  SEXP out = Rf_eval(call, magrittr_ns_env);
403

404 1
  UNPROTECT(1);
405 1
  return out;
406
}
407

408

409
// Initialisation ----------------------------------------------------
410

411
void magrittr_init_utils(SEXP ns);
412

413 1
SEXP magrittr_init(SEXP ns) {
414 1
  magrittr_ns_env = ns;
415 1
  magrittr_init_utils(ns);
416

417 1
  syms_lhs = Rf_install("lhs");
418 1
  syms_rhs = Rf_install("rhs");
419 1
  syms_kind = Rf_install("kind");
420 1
  syms_env = Rf_install("env");
421 1
  syms_lazy = Rf_install("lazy");
422

423 1
  syms_assign = Rf_install("<-");
424 1
  syms_bang = Rf_install("!");
425 1
  syms_curly = Rf_install("{");
426 1
  syms_dot = Rf_install(".");
427 1
  syms_nested = Rf_install("nested");
428 1
  syms_new_lambda = Rf_install("new_lambda");
429 1
  syms_paren = Rf_install("(");
430 1
  syms_pipe = Rf_install("%>%");
431 1
  syms_pipe_compound = Rf_install("%<>%");
432 1
  syms_pipe_dollar = Rf_install("%$%");
433 1
  syms_pipe_tee = Rf_install("%T>%");
434 1
  syms_return = Rf_install("return");
435 1
  syms_sym = Rf_install("sym");
436

437 1
  chrs_dot = Rf_allocVector(STRSXP, 1);
438 1
  R_PreserveObject(chrs_dot);
439 1
  SET_STRING_ELT(chrs_dot, 0, Rf_mkChar("."));
440

441 1
  calls_base_with = Rf_lang3(Rf_install("::"),
442 1
                             Rf_install("base"),
443 1
                             Rf_install("with"));
444 1
  R_PreserveObject(calls_base_with);
445 1
  MARK_NOT_MUTABLE(calls_base_with);
446

447 1
  return R_NilValue;
448
}
449

450
static const R_CallMethodDef call_entries[] = {
451
  {"magrittr_init",              (DL_FUNC) magrittr_init, 1},
452
  {NULL, NULL, 0}
453
};
454

455
static const R_ExternalMethodDef ext_entries[] = {
456
  {"magrittr_pipe",              (DL_FUNC) magrittr_pipe, 0},
457
  {NULL, NULL, 0}
458
};
459

460 1
export void R_init_magrittr(DllInfo *dll) {
461 1
    R_registerRoutines(dll, NULL, call_entries, NULL, ext_entries);
462 1
    R_useDynamicSymbols(dll, FALSE);
463
}

Read our documentation on viewing source code .

Loading