1 #define R_NO_REMAP
2 #include <R.h>
3 #include <Rinternals.h>
4 #include <stdio.h>
5 #include <stdbool.h>
6
find_dots(SEXP env)7 static SEXP find_dots(SEXP env) {
8 if (TYPEOF(env) != ENVSXP) {
9 Rf_errorcall(R_NilValue, "`env` is a not an environment");
10 }
11
12 SEXP dots = PROTECT(Rf_findVarInFrame3(env, R_DotsSymbol, TRUE));
13 if (dots == R_UnboundValue) {
14 Rf_errorcall(R_NilValue, "No ... found");
15 }
16
17 UNPROTECT(1);
18 return dots;
19 }
20
ellipsis_dots(SEXP env,SEXP auto_name_)21 SEXP ellipsis_dots(SEXP env, SEXP auto_name_) {
22 int auto_name = Rf_asLogical(auto_name_);
23
24 SEXP dots = PROTECT(find_dots(env));
25
26 // Empty dots
27 if (dots == R_MissingArg) {
28 UNPROTECT(1);
29 return Rf_allocVector(VECSXP, 0);
30 }
31
32 R_len_t n = Rf_length(dots);
33
34 SEXP out = PROTECT(Rf_allocVector(VECSXP, n));
35 SEXP names = PROTECT(Rf_allocVector(STRSXP, n));
36 Rf_setAttrib(out, R_NamesSymbol, names);
37
38 for (R_len_t i = 0; i < n; ++i) {
39 SET_VECTOR_ELT(out, i, CAR(dots));
40
41 SEXP name = TAG(dots);
42 if (TYPEOF(name) == SYMSXP) {
43 SET_STRING_ELT(names, i, PRINTNAME(name));
44 } else {
45 if (auto_name) {
46 char buffer[20];
47 snprintf(buffer, 20, "..%i", i + 1);
48 SET_STRING_ELT(names, i, Rf_mkChar(buffer));
49 } else {
50 SET_STRING_ELT(names, i, NA_STRING);
51 }
52 }
53
54 dots = CDR(dots);
55 }
56
57 UNPROTECT(3);
58 return out;
59 }
60
promise_forced(SEXP x)61 static bool promise_forced(SEXP x) {
62 if (TYPEOF(x) != PROMSXP) {
63 return true;
64 } else {
65 return PRVALUE(x) != R_UnboundValue;
66 }
67 }
ellipsis_promise_forced(SEXP x)68 SEXP ellipsis_promise_forced(SEXP x) {
69 return Rf_ScalarLogical(promise_forced(x));
70 }
71
ellipsis_dots_used(SEXP env)72 SEXP ellipsis_dots_used(SEXP env) {
73 SEXP dots = PROTECT(find_dots(env));
74
75 if (dots == R_MissingArg) {
76 UNPROTECT(1);
77 return Rf_ScalarLogical(true);
78 }
79
80 while (dots != R_NilValue) {
81 SEXP elt = CAR(dots);
82
83 if (!promise_forced(elt)) {
84 UNPROTECT(1);
85 return Rf_ScalarLogical(false);
86 }
87
88 dots = CDR(dots);
89 }
90
91 UNPROTECT(1);
92 return Rf_ScalarLogical(true);
93 }
94
ellipsis_eval_bare(SEXP expr,SEXP env)95 SEXP ellipsis_eval_bare(SEXP expr, SEXP env) {
96 return Rf_eval(expr, env);
97 }
98