1 #include "dplyr.h"
2
as_utf8(SEXP s)3 SEXP as_utf8(SEXP s) {
4 if (!IS_UTF8(s) && !IS_ASCII(s)) {
5 s = Rf_mkCharCE(Rf_translateCharUTF8(s), CE_UTF8);
6 }
7 return s;
8 }
9
find_first(SEXP haystack,SEXP needle)10 R_xlen_t find_first(SEXP haystack, SEXP needle) {
11 SEXP needle_utf8 = PROTECT(as_utf8(needle));
12 R_xlen_t n = XLENGTH(haystack);
13 R_xlen_t i_name = 0;
14 for (; i_name < n; i_name++) {
15 if (needle_utf8 == as_utf8(STRING_ELT(haystack, i_name))) break;
16 }
17 UNPROTECT(1);
18 return i_name;
19 }
20
integers_append(SEXP ints,int x)21 SEXP integers_append(SEXP ints, int x) {
22 R_xlen_t n = XLENGTH(ints);
23 SEXP new_ints = PROTECT(Rf_allocVector(INTSXP, n + 1));
24 int* p_ints = INTEGER(ints);
25 int* p_new_ints = INTEGER(new_ints);
26 for (R_xlen_t i = 0; i < n; i++) {
27 p_new_ints[i] = p_ints[i];
28 }
29 p_new_ints[n] = x;
30 UNPROTECT(1);
31 return new_ints;
32 }
33
dplyr_mask_add(SEXP env_private,SEXP s_name,SEXP chunks)34 SEXP dplyr_mask_add(SEXP env_private, SEXP s_name, SEXP chunks) {
35 SEXP name = STRING_ELT(s_name, 0);
36
37 // we assume control over these
38 SEXP all_vars = PROTECT(Rf_findVarInFrame(env_private, dplyr::symbols::all_vars));
39
40 // search for position of name
41 R_xlen_t n = XLENGTH(all_vars);
42 R_xlen_t i_name = find_first(all_vars, name);
43
44 bool is_new_column = i_name == n;
45 if (is_new_column) {
46 SEXP new_all_vars = PROTECT(Rf_allocVector(STRSXP, n + 1));
47
48 for (R_xlen_t i = 0; i < n; i++) {
49 SET_STRING_ELT(new_all_vars, i, STRING_ELT(all_vars, i));
50 }
51 SET_STRING_ELT(new_all_vars, n, name);
52
53 Rf_defineVar(dplyr::symbols::all_vars, new_all_vars, env_private);
54
55 UNPROTECT(1);
56 }
57
58 SEXP sym_name = PROTECT(rlang::str_as_symbol(name));
59 SEXP chops = PROTECT(Rf_findVarInFrame(env_private, dplyr::symbols::chops));
60 Rf_defineVar(sym_name, chunks, chops);
61
62 SEXP mask = PROTECT(Rf_findVarInFrame(env_private, dplyr::symbols::mask));
63 add_mask_binding(sym_name, ENCLOS(mask), chops);
64
65 UNPROTECT(4);
66 return R_NilValue;
67 }
68
69 // no C-api for rm() so callback to R :shrug:
get_rm_call()70 SEXP get_rm_call() {
71 SEXP rm_call = PROTECT(Rf_lang3(dplyr::symbols::rm, R_NilValue, R_NilValue));
72 SET_TAG(CDDR(rm_call), dplyr::symbols::envir);
73 R_PreserveObject(rm_call);
74 UNPROTECT(1);
75 return rm_call;
76 }
77
rm(SEXP name,SEXP env)78 void rm(SEXP name, SEXP env) {
79 static SEXP rm_call = get_rm_call();
80 SETCADR(rm_call, name);
81 SETCADDR(rm_call, env);
82 Rf_eval(rm_call, R_BaseEnv);
83 }
84
dplyr_mask_remove(SEXP env_private,SEXP s_name)85 SEXP dplyr_mask_remove(SEXP env_private, SEXP s_name) {
86 SEXP name = STRING_ELT(s_name, 0);
87
88 SEXP all_vars = PROTECT(Rf_findVarInFrame(env_private, dplyr::symbols::all_vars));
89
90 // search for position of name
91 R_xlen_t n = XLENGTH(all_vars);
92 R_xlen_t i_name = find_first(all_vars, name);
93
94 if (i_name != n) {
95 // all_vars <- setdiff(all_vars, name)
96 SEXP new_all_vars = PROTECT(Rf_allocVector(STRSXP, n - 1));
97 for (R_xlen_t i = 0, j = 0; i < n; i++) {
98 if (i == i_name) continue;
99 SET_STRING_ELT(new_all_vars, j++, STRING_ELT(all_vars, i));
100 }
101 Rf_defineVar(dplyr::symbols::all_vars, new_all_vars, env_private);
102
103 SEXP chops = PROTECT(Rf_findVarInFrame(env_private, dplyr::symbols::chops));
104 SEXP sym_name = PROTECT(rlang::str_as_symbol(name));
105 rm(sym_name, chops);
106
107 SEXP mask = PROTECT(Rf_findVarInFrame(env_private, dplyr::symbols::mask));
108 rm(sym_name, ENCLOS(mask));
109
110 UNPROTECT(4);
111 }
112
113 UNPROTECT(1);
114 return R_NilValue;
115 }
116