1 #include <R.h>
2 #include <Rdefines.h>
3
promise_as_lazy(SEXP promise,SEXP env,int follow_symbols)4 SEXP promise_as_lazy(SEXP promise, SEXP env, int follow_symbols) {
5 // recurse until we find the real promise, not a promise of a promise
6 // never go past the global environment
7 while(TYPEOF(promise) == PROMSXP && env != R_GlobalEnv) {
8
9 env = PRENV(promise);
10 promise = PREXPR(promise);
11
12 // If the promise is threaded through multiple functions, we'll
13 // get some symbols along the way. If the symbol is bound to a promise
14 // keep going on up
15 if (follow_symbols && TYPEOF(promise) == SYMSXP) {
16 SEXP obj = findVar(promise, env);
17 if (TYPEOF(obj) == PROMSXP) {
18 promise = obj;
19 }
20 }
21 }
22
23 // Make named list for output
24 SEXP lazy = PROTECT(allocVector(VECSXP, 2));
25 SET_VECTOR_ELT(lazy, 0, promise);
26 SET_VECTOR_ELT(lazy, 1, env);
27
28 SEXP names = PROTECT(allocVector(STRSXP, 2));
29 SET_STRING_ELT(names, 0, mkChar("expr"));
30 SET_STRING_ELT(names, 1, mkChar("env"));
31
32 setAttrib(lazy, install("names"), names);
33 setAttrib(lazy, install("class"), PROTECT(mkString("lazy")));
34
35 UNPROTECT(3);
36
37 return lazy;
38 }
39
make_lazy(SEXP name,SEXP env,SEXP follow_symbols_)40 SEXP make_lazy(SEXP name, SEXP env, SEXP follow_symbols_) {
41 SEXP promise = PROTECT(findVar(name, env));
42 int follow_symbols = asLogical(follow_symbols_);
43 SEXP ret = promise_as_lazy(promise, env, follow_symbols);
44 UNPROTECT(1);
45 return ret;
46 }
47
make_lazy_dots(SEXP env,SEXP follow_symbols_)48 SEXP make_lazy_dots(SEXP env, SEXP follow_symbols_) {
49 SEXP dots = PROTECT(findVar(install("..."), env));
50 int follow_symbols = asLogical(follow_symbols_);
51
52 // Figure out how many elements in dots
53 int n = 0;
54 for(SEXP nxt = dots; nxt != R_NilValue; nxt = CDR(nxt)) {
55 n++;
56 }
57
58 // Allocate list to store results
59 SEXP lazy_dots = PROTECT(allocVector(VECSXP, n));
60 SEXP names = PROTECT(allocVector(STRSXP, n));
61
62 // Iterate through all elements of dots, converting promises into lazy exprs
63 int i = 0;
64 SEXP nxt = dots;
65 while(nxt != R_NilValue) {
66 SEXP promise = CAR(nxt);
67
68 SEXP lazy = promise_as_lazy(promise, env, follow_symbols);
69 SET_VECTOR_ELT(lazy_dots, i, lazy);
70 if (TAG(nxt) != R_NilValue)
71 SET_STRING_ELT(names, i, PRINTNAME(TAG(nxt)));
72
73 nxt = CDR(nxt);
74 i++;
75 }
76 setAttrib(lazy_dots, install("names"), names);
77 setAttrib(lazy_dots, install("class"), PROTECT(mkString("lazy_dots")));
78
79 UNPROTECT(4);
80
81 return lazy_dots;
82 }
83 #include <R.h>
84 #include <Rdefines.h>
85
86 /* For now, replace with pure R alternative ------------------------------------
87
88 // This is a bit naughty, but there's no other way to create a promise
89 SEXP Rf_mkPROMISE(SEXP, SEXP);
90 SEXP Rf_installTrChar(SEXP);
91
92 SEXP lazy_to_promise(SEXP x) {
93 // arg is a list of length 2 - LANGSXP/SYMSXP, followed by ENVSXP
94 return Rf_mkPROMISE(VECTOR_ELT(x, 0), VECTOR_ELT(x, 1));
95 }
96
97 SEXP eval_call_(SEXP fun, SEXP dots, SEXP env) {
98 if (TYPEOF(fun) != SYMSXP && TYPEOF(fun) != LANGSXP) {
99 error("fun must be a call or a symbol");
100 }
101 if (TYPEOF(dots) != VECSXP) {
102 error("dots must be a list");
103 }
104 if (!inherits(dots, "lazy_dots")) {
105 error("dots must be of class lazy_dots");
106 }
107 if (TYPEOF(env) != ENVSXP) {
108 error("env must be an environment");
109 }
110
111 int n = length(dots);
112 if (n == 0) {
113 return LCONS(fun, R_NilValue);
114 }
115
116 SEXP names = GET_NAMES(dots);
117
118 SEXP args = R_NilValue;
119 for (int i = n - 1; i >= 0; --i) {
120 SEXP dot = VECTOR_ELT(dots, i);
121 SEXP prom = lazy_to_promise(dot);
122 args = PROTECT(CONS(prom, args));
123 if (names != R_NilValue) {
124 SEXP name = STRING_ELT(names, i);
125 if (strlen(CHAR(name)) > 0)
126 SET_TAG(args, Rf_installTrChar(name));
127 }
128 }
129 UNPROTECT(n);
130
131 SEXP call = LCONS(fun, args);
132
133 return eval(call, env);
134 }
135
136 */
137 #include <R.h>
138 #include <Rdefines.h>
139
140 /* Fails on Linux --------------------------------------------------------------
141
142 SEXP Rf_mkPROMISE(SEXP, SEXP);
143
144 SEXP promise_(SEXP expr, SEXP env) {
145 if (TYPEOF(expr) != SYMSXP && TYPEOF(expr) != LANGSXP) {
146 error("expr must be a call or a symbol");
147 }
148 if (TYPEOF(env) != ENVSXP) {
149 error("env must be an environment");
150 }
151
152 return Rf_mkPROMISE(expr, env);
153 }
154
155 */
156
promise_expr_(SEXP prom)157 SEXP promise_expr_(SEXP prom) {
158 if (TYPEOF(prom) != PROMSXP) {
159 error("prom must be a promise");
160 }
161
162 return PREXPR(prom);
163 }
164
promise_env_(SEXP prom)165 SEXP promise_env_(SEXP prom) {
166 if (TYPEOF(prom) != PROMSXP) {
167 error("prom must be a promise");
168 }
169
170 return PRENV(prom);
171 }
172
173