1 #include "rlang.h"
2
3 extern sexp* rlang_attrib(sexp* x);
4 extern sexp* r_poke_attrib(sexp* x, sexp* attrs);
5
r_attrib_push(sexp * x,sexp * tag,sexp * value)6 sexp* r_attrib_push(sexp* x, sexp* tag, sexp* value) {
7 sexp* attrs = r_new_node(value, r_attrib(x));
8 r_node_poke_tag(attrs, tag);
9 r_poke_attrib(x, attrs);
10 return attrs;
11 }
12
13
r_attrs_set_at(sexp * attrs,sexp * node,sexp * value)14 sexp* r_attrs_set_at(sexp* attrs, sexp* node, sexp* value) {
15 sexp* sentinel = r_node_cdr(node);
16 sexp* new_node = r_null;
17
18 attrs = KEEP(r_pairlist_clone_until(attrs, sentinel, &new_node));
19 r_node_poke_car(new_node, value);
20
21 FREE(1);
22 return attrs;
23 }
r_attrs_zap_at(sexp * attrs,sexp * node,sexp * value)24 sexp* r_attrs_zap_at(sexp* attrs, sexp* node, sexp* value) {
25 sexp* sentinel = node;
26 sexp* new_node = r_null;
27
28 attrs = KEEP(r_pairlist_clone_until(attrs, sentinel, &new_node));
29
30 if (new_node == r_null) {
31 // `node` is the first node of `attrs`
32 attrs = r_node_cdr(attrs);
33 } else {
34 r_node_poke_cdr(new_node, r_node_cdr(node));
35 }
36
37 FREE(1);
38 return attrs;
39 }
r_clone2(sexp * x)40 sexp* r_clone2(sexp* x) {
41 sexp* attrs = r_attrib(x);
42
43 // Prevent attributes from being cloned
44 r_poke_attrib(x, r_null);
45 sexp* out = r_clone(x);
46 r_poke_attrib(x, attrs);
47 r_poke_attrib(out, attrs);
48
49 return out;
50 }
51
r_attrib_set(sexp * x,sexp * tag,sexp * value)52 sexp* r_attrib_set(sexp* x, sexp* tag, sexp* value) {
53 sexp* attrs = r_attrib(x);
54 sexp* out = KEEP(r_clone2(x));
55
56 sexp* node = attrs;
57 while (node != r_null) {
58 if (r_node_tag(node) == tag) {
59 if (value == r_null) {
60 attrs = r_attrs_zap_at(attrs, node, value);
61 } else {
62 attrs = r_attrs_set_at(attrs, node, value);
63 }
64 r_poke_attrib(out, attrs);
65
66 FREE(1);
67 return out;
68 }
69
70 node = r_node_cdr(node);
71 }
72
73 if (value != r_null) {
74 // Just add to the front if attribute does not exist yet
75 attrs = KEEP(r_new_node(out, attrs));
76 r_node_poke_tag(attrs, tag);
77 r_node_poke_car(attrs, value);
78 r_poke_attrib(out, attrs);
79 FREE(1);
80 }
81
82 FREE(1);
83 return out;
84 }
85
86
87 /**
88 * With push_ prefix, assumes there is no `class` attribute in the
89 * node list merge. This is for low-level construction of objects.
90 */
91
92 // Caller must poke the object bit
r_node_push_classes(sexp * node,const char ** tags)93 sexp* r_node_push_classes(sexp* node, const char** tags) {
94 sexp* tags_chr = KEEP(r_new_character(tags));
95 sexp* attrs = r_new_node(tags_chr, node);
96 r_node_poke_tag(attrs, r_syms_class);
97
98 FREE(1);
99 return attrs;
100 }
r_node_push_class(sexp * x,const char * tag)101 sexp* r_node_push_class(sexp* x, const char* tag) {
102 static const char* tags[2] = { "", NULL };
103 tags[0] = tag;
104 return r_node_push_classes(x, tags);
105 }
106
r_push_classes(sexp * x,const char ** tags)107 void r_push_classes(sexp* x, const char** tags) {
108 sexp* attrs = r_attrib(x);
109 attrs = r_node_push_classes(attrs, tags);
110 SET_ATTRIB(x, attrs);
111 SET_OBJECT(x, 1);
112 }
r_push_class(sexp * x,const char * tag)113 void r_push_class(sexp* x, const char* tag) {
114 static const char* tags[2] = { "", NULL };
115 tags[0] = tag;
116 r_push_classes(x, tags);
117 }
118