1 #define R_NO_REMAP
2 #include <R.h>
3 #include <Rinternals.h>
4 #include "utils.h"
5
6 // Returns a CHARSXP
as_name(SEXP x)7 SEXP as_name(SEXP x) {
8 switch(TYPEOF(x)) {
9 case STRSXP:
10 if (Rf_length(x) != 1)
11 Rf_errorcall(R_NilValue, "LHS must evaluate to a single string");
12 return STRING_ELT(x, 0);
13 case SYMSXP:
14 return PRINTNAME(x);
15 case LANGSXP:
16 if (!is_formula(x) || Rf_length(x) != 2)
17 Rf_errorcall(R_NilValue, "RHS of LHS must be a single-sided formula");
18
19 return as_name(rhs(x));
20 default:
21 Rf_errorcall(R_NilValue, "LHS must evaluate to a string or name");
22 }
23 }
24
lhs_name(SEXP x)25 SEXP lhs_name(SEXP x) {
26 if (TYPEOF(x) != VECSXP)
27 Rf_errorcall(R_NilValue, "`x` must be a list (not a %s)", Rf_type2char(TYPEOF(x)));
28
29 int n = Rf_length(x);
30 SEXP x2 = PROTECT(Rf_shallow_duplicate(x));
31
32 SEXP names = Rf_getAttrib(x2, R_NamesSymbol);
33
34 // Hush rchk false positives
35 PROTECT(names);
36
37 if (names == R_NilValue) {
38 names = Rf_allocVector(STRSXP, n);
39 Rf_setAttrib(x2, R_NamesSymbol, names);
40 }
41
42 for (int i = 0; i < n; ++i) {
43 SEXP xi = VECTOR_ELT(x2, i);
44 if (!is_formula(xi) || Rf_length(xi) != 3)
45 continue;
46
47 // Hush rchk false positives
48 SEXP p_lhs = PROTECT(lhs(xi));
49 SEXP p_env = PROTECT(env(xi));
50
51 // set name
52 SEXP name = PROTECT(Rf_eval(p_lhs, p_env));
53 if (TYPEOF(name) != NILSXP)
54 SET_STRING_ELT(names, i, as_name(name));
55
56 // replace with RHS of formula
57 SET_VECTOR_ELT(x2, i, make_formula1(CADDR(xi), env(xi)));
58 UNPROTECT(3);
59 }
60
61 UNPROTECT(2);
62 return x2;
63 }
64