1 #include <rlang.h>
2
3 static const char* quo_tags[3] = { "quosure", "formula", NULL };
4
5 sexp* new_raw_formula(sexp* lhs, sexp* rhs, sexp* env);
6
rlang_new_quosure(sexp * expr,sexp * env)7 sexp* rlang_new_quosure(sexp* expr, sexp* env) {
8 if (r_typeof(env) != r_type_environment) {
9 r_abort("`env` must be an environment");
10 }
11 sexp* quo = KEEP(new_raw_formula(r_null, expr, env));
12 r_push_classes(quo, quo_tags);
13 FREE(1);
14 return quo;
15 }
rlang_is_quosure(sexp * x)16 bool rlang_is_quosure(sexp* x) {
17 return r_typeof(x) == r_type_call && Rf_inherits(x, "quosure");
18 }
19
check_quosure(sexp * quo)20 inline void check_quosure(sexp* quo) {
21 if (!rlang_is_quosure(quo)) {
22 r_abort("`quo` must be a quosure");
23 }
24 }
rlang_quo_get_expr(sexp * quo)25 sexp* rlang_quo_get_expr(sexp* quo) {
26 check_quosure(quo);
27 return r_node_cadr(quo);
28 }
rlang_quo_set_expr(sexp * quo,sexp * expr)29 sexp* rlang_quo_set_expr(sexp* quo, sexp* expr) {
30 check_quosure(quo);
31 quo = r_clone(quo);
32 return r_node_poke_cadr(quo, expr);
33 }
34
rlang_quo_get_env(sexp * quo)35 sexp* rlang_quo_get_env(sexp* quo) {
36 check_quosure(quo);
37 return r_attrib_get(quo, r_syms_dot_environment);
38 }
rlang_quo_set_env(sexp * quo,sexp * env)39 sexp* rlang_quo_set_env(sexp* quo, sexp* env) {
40 check_quosure(quo);
41 if (r_typeof(env) != r_type_environment) {
42 r_abort("`env` must be an environment");
43 }
44 return r_attrib_set(quo, r_syms_dot_environment, env);
45 }
46
rlang_get_expression(sexp * x,sexp * alternate)47 sexp* rlang_get_expression(sexp* x, sexp* alternate) {
48 switch (r_typeof(x)) {
49 case LANGSXP:
50 if (r_is_formulaish(x, -1, 0)) {
51 return r_f_rhs(x);
52 }
53 break;
54 // case CLOSXP:
55 // return r_fn_body(x);
56 case VECSXP:
57 if (r_inherits(x, "frame")) {
58 return r_list_get(x, 2);
59 }
60 break;
61 default:
62 break;
63 }
64
65 if (alternate) {
66 return alternate;
67 } else {
68 return x;
69 }
70 }
71
quo_is_missing(sexp * quo)72 bool quo_is_missing(sexp* quo) {
73 return r_node_cadr(quo) == R_MissingArg;
74 }
quo_is_symbol(sexp * quo)75 bool quo_is_symbol(sexp* quo) {
76 return r_typeof(r_node_cadr(quo)) == r_type_symbol;
77 }
quo_is_call(sexp * quo)78 bool quo_is_call(sexp* quo) {
79 return r_typeof(r_node_cadr(quo)) == r_type_call;
80 }
quo_is_symbolic(sexp * quo)81 bool quo_is_symbolic(sexp* quo) {
82 return r_is_symbolic(r_node_cadr(quo));
83 }
quo_is_null(sexp * quo)84 bool quo_is_null(sexp* quo) {
85 return r_node_cadr(quo) == r_null;
86 }
87