1
#define R_NO_REMAP
2
#include <Rinternals.h>
3

4

5
SEXP syms_delayed_assign = NULL;
6

7 1
void r_env_bind_lazy(SEXP env,
8
                     SEXP sym,
9
                     SEXP expr,
10
                     SEXP eval_env) {
11 1
  SEXP prom = PROTECT(Rf_allocSExp(PROMSXP));
12 1
  SET_PRENV(prom, eval_env);
13 1
  SET_PRCODE(prom, expr);
14 1
  SET_PRVALUE(prom, R_UnboundValue);
15

16 1
  Rf_defineVar(sym, prom, env);
17

18 1
  UNPROTECT(1);
19 1
  return;
20

21
  SEXP call = PROTECT(Rf_lang5(syms_delayed_assign, sym, expr, eval_env, env));
22
  Rf_eval(call, R_BaseEnv);
23
  UNPROTECT(1);
24
}
25

26

27
// For `R_removeVarFromFrame()` compatibility
28
SEXP syms_envir = NULL;
29
SEXP syms_inherits = NULL;
30
SEXP syms_list = NULL;
31
SEXP syms_rm = NULL;
32

33
#include <Rversion.h>
34

35
#if (R_VERSION < R_Version(4, 0, 0))
36
void r__env_unbind(SEXP env, SEXP sym) {
37
  // Check if binding exists to avoid `rm()` warning
38
  if (Rf_findVar(sym, env) != R_UnboundValue) {
39
    SEXP nm = PROTECT(Rf_allocVector(STRSXP, 1));
40
    SET_STRING_ELT(nm, 0, PRINTNAME(sym));
41

42
    // remove(list = y, envir = x, inherits = z)
43
    SEXP args = Rf_cons(Rf_ScalarLogical(0), R_NilValue);
44
    SET_TAG(args, syms_inherits);
45

46
    args = Rf_cons(env, args);
47
    SET_TAG(args, syms_envir);
48

49
    args = Rf_cons(nm, args);
50
    SET_TAG(args, syms_list);
51

52
    SEXP call = Rf_lcons(syms_rm, args);
53
    PROTECT(call);
54

55
    Rf_eval(call, R_BaseEnv);
56
    UNPROTECT(2);
57
  }
58
}
59
#endif
60

61

62
#include <R_ext/Parse.h>
63

64 0
static void abort_parse(SEXP code, const char* why) {
65 0
  if (Rf_GetOption1(Rf_install("rlang__verbose_errors")) != R_NilValue) {
66 0
   Rf_PrintValue(code);
67
  }
68 0
  Rf_error("Internal error in `r_parse()`: %s", why);
69
}
70

71 1
SEXP r_parse(const char* str) {
72 1
  SEXP str_ = PROTECT(Rf_mkString(str));
73

74
  ParseStatus status;
75 1
  SEXP out = PROTECT(R_ParseVector(str_, -1, &status, R_NilValue));
76 1
  if (status != PARSE_OK) {
77 0
    abort_parse(str_, "Parsing failed.");
78
  }
79 1
  if (Rf_length(out) != 1) {
80 0
    abort_parse(str_, "Expected a single expression.");
81
  }
82

83 1
  out = VECTOR_ELT(out, 0);
84

85 1
  UNPROTECT(2);
86 1
  return out;
87
}
88 1
SEXP r_parse_eval(const char* str, SEXP env) {
89 1
  SEXP out = Rf_eval(PROTECT(r_parse(str)), env);
90 1
  UNPROTECT(1);
91 1
  return out;
92
}
93

94
static SEXP new_env_call = NULL;
95
static SEXP new_env__parent_node = NULL;
96
static SEXP new_env__size_node = NULL;
97

98
#if 0
99
SEXP r_new_environment(SEXP parent, R_len_t size) {
100
  parent = parent ? parent : R_EmptyEnv;
101
  SETCAR(new_env__parent_node, parent);
102

103
  size = size ? size : 29;
104
  SETCAR(new_env__size_node, Rf_ScalarInteger(size));
105

106
  SEXP env = Rf_eval(new_env_call, R_BaseEnv);
107

108
  // Free for gc
109
  SETCAR(new_env__parent_node, R_NilValue);
110

111
  return env;
112
}
113
#endif
114

115

116 1
void magrittr_init_utils(SEXP ns) {
117 1
  syms_delayed_assign = Rf_install("delayedAssign");
118 1
  syms_envir = Rf_install("envir");
119 1
  syms_inherits = Rf_install("inherits");
120 1
  syms_list = Rf_install("list");
121 1
  syms_rm = Rf_install("rm");
122

123 1
  new_env_call = r_parse_eval("as.call(list(new.env, TRUE, NULL, NULL))", R_BaseEnv);
124 1
  R_PreserveObject(new_env_call);
125 1
  new_env__parent_node = CDDR(new_env_call);
126 1
  new_env__size_node = CDR(new_env__parent_node);
127
}

Read our documentation on viewing source code .

Loading