1 #ifndef VCTRS_UTILS_RLANG_H
2 #define VCTRS_UTILS_RLANG_H
3
4 typedef struct SEXPREC sexp;
5 #define r_null R_NilValue
6
7 #define r_syms_names R_NamesSymbol
8 #define r_syms_class R_ClassSymbol
9
10 #define KEEP PROTECT
11 #define FREE UNPROTECT
12
13
14 // node.h ------------------------------------------------------------
15
r_node_car(sexp * x)16 static inline sexp* r_node_car(sexp* x) { return CAR(x); }
r_node_cdr(sexp * x)17 static inline sexp* r_node_cdr(sexp* x) { return CDR(x); }
r_node_tag(sexp * x)18 static inline sexp* r_node_tag(sexp* x) { return TAG(x); }
r_node_caar(sexp * x)19 static inline sexp* r_node_caar(sexp* x) { return CAAR(x); }
r_node_cadr(sexp * x)20 static inline sexp* r_node_cadr(sexp* x) { return CADR(x); }
r_node_cdar(sexp * x)21 static inline sexp* r_node_cdar(sexp* x) { return CDAR(x); }
r_node_cddr(sexp * x)22 static inline sexp* r_node_cddr(sexp* x) { return CDDR(x); }
23
24
25 static inline
r_node_poke_car(sexp * x,sexp * newcar)26 sexp* r_node_poke_car(sexp* x, sexp* newcar) {
27 SETCAR(x, newcar);
28 return x;
29 }
30 static inline
r_node_poke_cdr(sexp * x,sexp * newcdr)31 sexp* r_node_poke_cdr(sexp* x, sexp* newcdr) {
32 SETCDR(x, newcdr);
33 return x;
34 }
35 static inline
r_node_poke_tag(sexp * x,sexp * tag)36 sexp* r_node_poke_tag(sexp* x, sexp* tag) {
37 SET_TAG(x, tag);
38 return x;
39 }
40 static inline
r_node_poke_caar(sexp * x,sexp * newcaar)41 sexp* r_node_poke_caar(sexp* x, sexp* newcaar) {
42 SETCAR(CAR(x), newcaar);
43 return x;
44 }
45 static inline
r_node_poke_cadr(sexp * x,sexp * newcar)46 sexp* r_node_poke_cadr(sexp* x, sexp* newcar) {
47 SETCADR(x, newcar);
48 return x;
49 }
50 static inline
r_node_poke_cdar(sexp * x,sexp * newcdar)51 sexp* r_node_poke_cdar(sexp* x, sexp* newcdar) {
52 SETCDR(CAR(x), newcdar);
53 return x;
54 }
55 static inline
r_node_poke_cddr(sexp * x,sexp * newcdr)56 sexp* r_node_poke_cddr(sexp* x, sexp* newcdr) {
57 SETCDR(CDR(x), newcdr);
58 return x;
59 }
60
61 static inline
r_new_node(sexp * car,sexp * cdr)62 sexp* r_new_node(sexp* car, sexp* cdr) {
63 return Rf_cons(car, cdr);
64 }
65 static inline
r_new_node3(sexp * car,sexp * cdr,sexp * tag)66 sexp* r_new_node3(sexp* car, sexp* cdr, sexp* tag) {
67 sexp* out = Rf_cons(car, cdr);
68 SET_TAG(out, tag);
69 return out;
70 }
71
72 sexp* r_pairlist_find(sexp* node, sexp* tag);
73 sexp* r_pairlist_rev(sexp* node);
74
75 static inline
r_pairlist_get(sexp * node,sexp * tag)76 sexp* r_pairlist_get(sexp* node, sexp* tag) {
77 return r_node_car(r_pairlist_find(node, tag));
78 }
79
80 static inline
r_pairlist_poke(sexp * node,sexp * tag,sexp * value)81 sexp* r_pairlist_poke(sexp* node, sexp* tag, sexp* value) {
82 sexp* x = r_pairlist_find(node, tag);
83
84 if (x == R_NilValue) {
85 node = r_new_node(value, node);
86 r_node_poke_tag(node, tag);
87 return node;
88 } else {
89 r_node_poke_car(x, value);
90 return node;
91 }
92 }
93
94 static inline
r_pairlist_find_last(sexp * x)95 sexp* r_pairlist_find_last(sexp* x) {
96 while (CDR(x) != R_NilValue)
97 x = CDR(x);
98 return x;
99 }
100
101
102 // attrs.h -----------------------------------------------------------
103
104 static inline
r_attrib(sexp * x)105 sexp* r_attrib(sexp* x) {
106 return ATTRIB(x);
107 }
108 static inline
r_poke_attrib(sexp * x,sexp * attrs)109 sexp* r_poke_attrib(sexp* x, sexp* attrs) {
110 SET_ATTRIB(x, attrs);
111 return x;
112 }
113
114 // Unlike Rf_getAttrib(), this never allocates. This also doesn't bump
115 // refcounts or namedness.
116 static inline
r_attrib_get(sexp * x,sexp * tag)117 sexp* r_attrib_get(sexp* x, sexp* tag) {
118 return r_pairlist_get(r_attrib(x), tag);
119 }
120
121 SEXP r_clone_shared(SEXP x);
122
123 static inline
r_attrib_poke(sexp * x,sexp * tag,sexp * value)124 void r_attrib_poke(sexp* x, sexp* tag, sexp* value) {
125 sexp* attrib = KEEP(r_clone_shared(r_attrib(x)));
126 r_poke_attrib(x, r_pairlist_poke(attrib, tag, value));
127 FREE(1);
128 return;
129 }
130
131 static inline
r_names(sexp * x)132 sexp* r_names(sexp* x) {
133 return r_attrib_get(x, r_syms_names);
134 }
135 static inline
r_class(sexp * x)136 sexp* r_class(sexp* x) {
137 return r_attrib_get(x, r_syms_class);
138 }
139
140
141 #endif
142