1 #include <R.h>
2 #include <Rdefines.h>
3 #include "utils.h"
4
promise_as_lazy(SEXP promise,SEXP env,int follow_symbols)5 SEXP promise_as_lazy(SEXP promise, SEXP env, int follow_symbols) {
6 // recurse until we find the real promise, not a promise of a promise
7 while(TYPEOF(promise) == PROMSXP) {
8 if (PRENV(promise) == R_NilValue) {
9 Rf_error("Promise has already been forced");
10 }
11
12 env = PRENV(promise);
13 promise = PREXPR(promise);
14
15 // If the promise is threaded through multiple functions, we'll
16 // get some symbols along the way. If the symbol is bound to a promise
17 // keep going on up
18 if (follow_symbols && TYPEOF(promise) == SYMSXP) {
19 SEXP obj = findVar(promise, env);
20
21 if (obj == R_MissingArg || obj == R_UnboundValue)
22 break;
23
24 if (TYPEOF(obj) == PROMSXP && is_lazy_load(obj))
25 break;
26
27 promise = obj;
28 }
29 }
30
31 // Make named list for output
32 SEXP lazy = PROTECT(allocVector(VECSXP, 2));
33 MARK_NOT_MUTABLE(promise);
34 SET_VECTOR_ELT(lazy, 0, promise);
35 SET_VECTOR_ELT(lazy, 1, env);
36
37 SEXP names = PROTECT(allocVector(STRSXP, 2));
38 SET_STRING_ELT(names, 0, mkChar("expr"));
39 SET_STRING_ELT(names, 1, mkChar("env"));
40
41 setAttrib(lazy, install("names"), names);
42 setAttrib(lazy, install("class"), PROTECT(mkString("lazy")));
43
44 UNPROTECT(3);
45
46 return lazy;
47 }
48
make_lazy(SEXP name,SEXP env,SEXP follow_symbols_)49 SEXP make_lazy(SEXP name, SEXP env, SEXP follow_symbols_) {
50 SEXP promise = PROTECT(findVar(name, env));
51 int follow_symbols = asLogical(follow_symbols_);
52
53 SEXP out = promise_as_lazy(promise, env, follow_symbols);
54
55 UNPROTECT(1);
56 return out;
57 }
58
is_missing(SEXP x)59 int is_missing(SEXP x) {
60 return TYPEOF(x) == SYMSXP && x == R_MissingArg;
61 }
62
make_lazy_dots(SEXP env,SEXP follow_symbols_,SEXP ignore_empty_)63 SEXP make_lazy_dots(SEXP env, SEXP follow_symbols_, SEXP ignore_empty_) {
64 SEXP dots = PROTECT(findVar(R_DotsSymbol, env));
65 int follow_symbols = asLogical(follow_symbols_);
66 int ignore_empty = asLogical(ignore_empty_);
67
68 if (dots == R_MissingArg) {
69 SEXP out = PROTECT(Rf_allocVector(VECSXP, 0));
70 setAttrib(out, install("class"), PROTECT(mkString("lazy_dots")));
71 UNPROTECT(3);
72 return out;
73 }
74
75 // Figure out how many elements in dots
76 int n = 0;
77 for(SEXP nxt = dots; nxt != R_NilValue; nxt = CDR(nxt)) {
78 if (ignore_empty && is_missing(CAR(nxt)))
79 continue;
80
81 n++;
82 }
83
84 // Allocate list to store results
85 SEXP lazy_dots = PROTECT(allocVector(VECSXP, n));
86 SEXP names = PROTECT(allocVector(STRSXP, n));
87
88 // Iterate through all elements of dots, converting promises into lazy exprs
89 int i = 0;
90 for(SEXP nxt = dots; nxt != R_NilValue; nxt = CDR(nxt)) {
91 SEXP promise = CAR(nxt);
92
93 if (ignore_empty && is_missing(promise))
94 continue;
95
96 SEXP lazy = promise_as_lazy(promise, env, follow_symbols);
97 SET_VECTOR_ELT(lazy_dots, i, lazy);
98 if (TAG(nxt) != R_NilValue)
99 SET_STRING_ELT(names, i, PRINTNAME(TAG(nxt)));
100
101 i++;
102 }
103 setAttrib(lazy_dots, install("names"), names);
104 setAttrib(lazy_dots, install("class"), PROTECT(mkString("lazy_dots")));
105
106 UNPROTECT(4);
107
108 return lazy_dots;
109 }
110