pipe.c at 0221e18 ⋅ tidyverse/magrittr

#include <stdbool.h>
#define R_NO_REMAP
#include <Rinternals.h>
#include <R_ext/Rdynload.h>
#include <R_ext/Visibility.h>
#include "utils.h"

#define export attribute_visible extern


enum pipe_kind {
  PIPE_KIND_none = 0,
  PIPE_KIND_magrittr,
  PIPE_KIND_compound,
  PIPE_KIND_tee,
  PIPE_KIND_dollar
};

// Helper structures for unwind-protection of `.` restoration
struct pipe_info {
  SEXP exprs;
  SEXP env;
};
struct cleanup_info {
  SEXP old;
  SEXP env;
};

// Initialised at load time
static SEXP magrittr_ns_env = NULL;
static SEXP syms_lhs = NULL;
static SEXP syms_rhs = NULL;
static SEXP syms_kind = NULL;
static SEXP syms_env = NULL;
static SEXP syms_lazy = NULL;

static SEXP syms_assign = NULL;
static SEXP syms_bang = NULL;
static SEXP syms_curly = NULL;
static SEXP syms_dot = NULL;
static SEXP syms_nested = NULL;
static SEXP syms_new_lambda = NULL;
static SEXP syms_paren = NULL;
static SEXP syms_pipe = NULL;
static SEXP syms_pipe_compound = NULL;
static SEXP syms_pipe_dollar = NULL;
static SEXP syms_pipe_tee = NULL;
static SEXP syms_return = NULL;
static SEXP syms_sym = NULL;

static SEXP calls_base_with = NULL;
static SEXP chrs_dot = NULL;

static void clean_pipe(void* data);
static SEXP eval_pipe(void* data);
static SEXP eval_pipe_lazy(SEXP exprs, SEXP env);
static SEXP pipe_unroll(SEXP lhs, SEXP rhs, SEXP env, enum pipe_kind kind,
                        SEXP pipe_sym, SEXP* p_assign);
static SEXP pipe_nest(SEXP exprs);
static SEXP as_pipe_call(SEXP x);
static SEXP add_dot(SEXP x);
static inline SEXP as_pipe_tee_call(SEXP x);
static inline SEXP as_pipe_dollar_call(SEXP x);
static SEXP new_lambda(SEXP exprs, SEXP env);
static inline bool is_return(SEXP x);

// [[ register() ]]
SEXP magrittr_pipe(SEXP call, SEXP op, SEXP args, SEXP rho) {
  args = CDR(args);

  SEXP lhs = PROTECT(Rf_eval(syms_lhs, rho));
  SEXP rhs = PROTECT(Rf_eval(syms_rhs, rho));
  SEXP kind = PROTECT(Rf_eval(syms_kind, rho));
  SEXP env = PROTECT(Rf_eval(syms_env, rho));

  SEXP pipe_sym = r_env_get(rho, syms_sym);
  if (pipe_sym == R_UnboundValue) {
    pipe_sym = syms_pipe;
  }
  PROTECT(pipe_sym);

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

  // Create a magrittr lambda when first expression is a `.`
  if (CAR(exprs) == syms_dot) {
    SEXP lambda = new_lambda(CDR(exprs), env);
    UNPROTECT(6);
    return lambda;
  }

  bool use_nested = Rf_findVar(syms_nested, rho) != R_UnboundValue;
  if (use_nested) {
    SEXP call = PROTECT(pipe_nest(exprs));
    SEXP out = Rf_eval(call, env);
    UNPROTECT(7);
    return out;
  }

  bool use_lazy = Rf_findVar(syms_lazy, rho) != R_UnboundValue;
  SEXP out = R_NilValue;

  if (use_lazy) {
    out = eval_pipe_lazy(exprs, env);
  } else {
    SEXP old = PROTECT(Rf_findVar(syms_dot, env));

    struct pipe_info pipe_info = {
      .exprs = exprs,
      .env = env
    };
    struct cleanup_info cleanup_info = {
      .old = old,
      .env = env
    };

    out =  R_ExecWithCleanup(eval_pipe, &pipe_info, &clean_pipe, &cleanup_info);
    UNPROTECT(1);
  }

  if (assign != R_NilValue) {
    PROTECT(out);
    SEXP call = PROTECT(Rf_lang3(syms_assign, assign, out));
    Rf_eval(call, env);
    UNPROTECT(2);
  }

  UNPROTECT(6);
  return out;
}

static
SEXP eval_pipe(void* data) {
  struct pipe_info* info = (struct pipe_info*) data;

  SEXP exprs = info->exprs;
  SEXP env = info->env;

  SEXP out = R_NilValue;
  while (exprs != R_NilValue) {
    out = PROTECT(Rf_eval(CAR(exprs), env));

    Rf_defineVar(syms_dot, out, env);
    UNPROTECT(1);

    exprs = CDR(exprs);
  }

  return out;
}

static
SEXP eval_pipe_lazy(SEXP exprs, SEXP env) {
  SEXP prev_mask = env;

  PROTECT_INDEX mask_pi;
  PROTECT_WITH_INDEX(R_NilValue, &mask_pi);

  SEXP rest = exprs;
  while ((rest = CDR(exprs)) != R_NilValue) {
    SEXP mask = r_new_environment(env);
    REPROTECT(mask, mask_pi);

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

    exprs = rest;
    prev_mask = mask;
  }

  // For compatibility, allow last expression to be `return()`.
  // Substitute it with `.` to avoid an error.
  SEXP last = CAR(exprs);
  if (is_return(last)) {
    last = syms_dot;
  }

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

  UNPROTECT(1);
  return out;
}

static inline
bool is_return(SEXP x) {
  return TYPEOF(x) == LANGSXP && CAR(x) == syms_return;
}

static
void clean_pipe(void* data) {
  struct cleanup_info* info = (struct cleanup_info*) data;

  if (info->old == R_UnboundValue) {
    r_env_unbind(info->env, syms_dot);
  } else {
    Rf_defineVar(syms_dot, info->old, info->env);
  }
}


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

static
SEXP pipe_unroll(SEXP lhs,
                 SEXP rhs,
                 SEXP env,
                 enum pipe_kind kind,
                 SEXP pipe_sym,
                 SEXP* p_assign) {
  PROTECT_INDEX out_pi;
  SEXP out = R_NilValue;
  PROTECT_WITH_INDEX(out, &out_pi);

  PROTECT_INDEX rhs_pi;
  PROTECT_WITH_INDEX(rhs, &rhs_pi);

  while (true) {
    if (kind != PIPE_KIND_dollar && TYPEOF(rhs) == LANGSXP && CAR(rhs) == syms_paren) {
      rhs = Rf_eval(rhs, env);
      REPROTECT(rhs, rhs_pi);
    }

    switch (kind) {
    case PIPE_KIND_compound: {
      // Technically we want to give `%<>%` the same precedence as `<-`.
      // In practice, since we only support one top-level `%<>%, we
      // can just interpret it as `%>%` and communicate the assignment
      // variable via `p_assign`.
      *p_assign = lhs;
      rhs = as_pipe_call(rhs);
      break;
    }
    case PIPE_KIND_magrittr: rhs = as_pipe_call(rhs); break;
    case PIPE_KIND_tee: rhs = as_pipe_tee_call(rhs); break;
    case PIPE_KIND_dollar: rhs = as_pipe_dollar_call(rhs); break;
    case PIPE_KIND_none: Rf_error("Internal error in `pipe_unroll()`: Unexpected state.");
    }

    out = Rf_cons(rhs, out);
    REPROTECT(out, out_pi);

    SEXP args = CDR(lhs);

    if ((kind = parse_pipe_call(lhs, pipe_sym))) {
      lhs = CAR(args);
      rhs = CADR(args);
      continue;
    }

    break;
  }

  out = Rf_cons(lhs, out);

  UNPROTECT(2);
  return out;
}

static
enum pipe_kind parse_pipe_call(SEXP x, SEXP pipe_sym) {
  if (TYPEOF(x) != LANGSXP) {
    return PIPE_KIND_none;
  }

  SEXP car = CAR(x);

  if (car == pipe_sym) {
    return PIPE_KIND_magrittr;
  }
  if (car == syms_pipe_compound) {
    return PIPE_KIND_compound;
  }
  if (car == syms_pipe_tee) {
    return PIPE_KIND_tee;
  }
  if (car == syms_pipe_dollar) {
    return PIPE_KIND_dollar;
  }

  return PIPE_KIND_none;
}

static
SEXP as_pipe_call(SEXP x) {
  // Transform `foo` into `foo()`
  if (TYPEOF(x) != LANGSXP) {
    x = Rf_lcons(x, R_NilValue);
  }
  PROTECT(x);

  // Transform `foo()` into `foo(.)`
  x = add_dot(x);

  UNPROTECT(1);
  return x;
}

static inline
SEXP as_pipe_dollar_call(SEXP x) {
  return Rf_lang3(calls_base_with, syms_dot, x);
}

static inline
SEXP as_pipe_tee_call(SEXP x) {
  x = PROTECT(as_pipe_call(x));
  SEXP out = Rf_lang3(syms_curly, x, syms_dot);

  UNPROTECT(1);
  return out;
}

static inline
bool is_bang(SEXP x) {
  return TYPEOF(x) == LANGSXP && CAR(x) == syms_bang;
}

static
bool is_spliced_dot(SEXP x) {
  if (!is_bang(x)) {
    return false;
  }

  x = CADR(x);
  if (!is_bang(x)) {
    return false;
  }

  x = CADR(x);
  if (!is_bang(x)) {
    return false;
  }

  return CADR(x) == syms_dot;
}

static
SEXP add_dot(SEXP x) {
  if (TYPEOF(x) != LANGSXP) {
    return x;
  }

  SEXP args = CDR(x);
  while (args != R_NilValue) {
    SEXP arg = CAR(args);
    if (arg == syms_dot || is_spliced_dot(arg)) {
      return x;
    }
    args = CDR(args);
  }

  return Rf_lcons(CAR(x), Rf_cons(syms_dot, CDR(x)));
}


static
SEXP pipe_nest(SEXP exprs) {
  SEXP expr = CAR(exprs);
  SEXP prev = expr;
  exprs = CDR(exprs);

  PROTECT_INDEX expr_pi;
  PROTECT_WITH_INDEX(expr, &expr_pi);

  while (exprs != R_NilValue) {
    expr = Rf_shallow_duplicate(CAR(exprs));
    REPROTECT(expr, expr_pi);

    bool found_placeholder = false;
    SEXP curr = CDR(expr);

    while (curr != R_NilValue) {
      if (CAR(curr) == syms_dot) {
        if (found_placeholder) {
          Rf_errorcall(R_NilValue, "Can't use multiple placeholders.");
        }

        found_placeholder = true;
        SETCAR(curr, prev);
        prev = expr;
      }
      curr = CDR(curr);
    }
    if (!found_placeholder) {
      Rf_error("Internal error in `pipe_nest()`: Can't find placeholder.");
    }

    exprs = CDR(exprs);
  }

  UNPROTECT(1);
  return expr;
}

static
SEXP new_lambda(SEXP exprs, SEXP env) {
  SEXP call = PROTECT(Rf_lang3(syms_new_lambda, exprs, env));
  SEXP out = Rf_eval(call, magrittr_ns_env);

  UNPROTECT(1);
  return out;
}


// Initialisation ----------------------------------------------------

void magrittr_init_utils(SEXP ns);

SEXP magrittr_init(SEXP ns) {
  magrittr_ns_env = ns;
  magrittr_init_utils(ns);

  syms_lhs = Rf_install("lhs");
  syms_rhs = Rf_install("rhs");
  syms_kind = Rf_install("kind");
  syms_env = Rf_install("env");
  syms_lazy = Rf_install("lazy");

  syms_assign = Rf_install("<-");
  syms_bang = Rf_install("!");
  syms_curly = Rf_install("{");
  syms_dot = Rf_install(".");
  syms_nested = Rf_install("nested");
  syms_new_lambda = Rf_install("new_lambda");
  syms_paren = Rf_install("(");
  syms_pipe = Rf_install("%>%");
  syms_pipe_compound = Rf_install("%<>%");
  syms_pipe_dollar = Rf_install("%$%");
  syms_pipe_tee = Rf_install("%T>%");
  syms_return = Rf_install("return");
  syms_sym = Rf_install("sym");

  chrs_dot = Rf_allocVector(STRSXP, 1);
  R_PreserveObject(chrs_dot);
  SET_STRING_ELT(chrs_dot, 0, Rf_mkChar("."));

  calls_base_with = Rf_lang3(Rf_install("::"),
                             Rf_install("base"),
                             Rf_install("with"));
  R_PreserveObject(calls_base_with);
  MARK_NOT_MUTABLE(calls_base_with);

  return R_NilValue;
}

static const R_CallMethodDef call_entries[] = {
  {"magrittr_init",              (DL_FUNC) magrittr_init, 1},
  {NULL, NULL, 0}
};

static const R_ExternalMethodDef ext_entries[] = {
  {"magrittr_pipe",              (DL_FUNC) magrittr_pipe, 0},
  {NULL, NULL, 0}
};

export void R_init_magrittr(DllInfo *dll) {
    R_registerRoutines(dll, NULL, call_entries, NULL, ext_entries);
    R_useDynamicSymbols(dll, FALSE);
}

Read our documentation on viewing source code .

Navigation	Overlay
`t` Navigate files	`h` Toggle hits
`y` Change url to tip of branch	`m` Toggle misses
`b / v` Jump to prev/next hit line	`p` Toggle partial
`z / x` Jump to prev/next missed or partial line	`1..9` Toggle flags
`shift + o` Open current page in GitHub	`a` Toggle all on
`/ or ?` Show keyboard shortcuts dialog	`c` Toggle context lines or commits

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		}