1 #include "rlang.h"
2
3 sexp* rlang_ns_get(const char* name);
4
5
r_on_exit(sexp * expr,sexp * frame)6 void r_on_exit(sexp* expr, sexp* frame) {
7 static sexp* on_exit_prim = NULL;
8 if (!on_exit_prim) {
9 on_exit_prim = r_base_ns_get("on.exit");
10 }
11
12 sexp* args = r_pairlist2(expr, r_lgl(1));
13 sexp* lang = KEEP(r_new_call(on_exit_prim, args));
14
15 r_eval(lang, frame);
16 FREE(1);
17 }
18
19
20 static sexp* current_frame_call = NULL;
21
r_current_frame()22 sexp* r_current_frame() {
23 return r_eval(current_frame_call, r_empty_env);
24 }
25
26
27 static sexp* sys_frame_call = NULL;
28 static sexp* sys_call_call = NULL;
29
30 static int* sys_frame_n_addr = NULL;
31 static int* sys_call_n_addr = NULL;
32
r_sys_frame(int n,sexp * frame)33 sexp* r_sys_frame(int n, sexp* frame) {
34 int n_protect = 0;
35 if (!frame) {
36 frame = r_current_frame();
37 KEEP_N(frame, n_protect);
38 }
39
40 *sys_frame_n_addr = n;
41 SEXP value = r_eval(sys_frame_call, frame);
42
43 FREE(n_protect);
44 return value;
45 }
r_sys_call(int n,sexp * frame)46 sexp* r_sys_call(int n, sexp* frame) {
47 int n_protect = 0;
48 if (!frame) {
49 frame = r_current_frame();
50 KEEP_N(frame, n_protect);
51 }
52
53 *sys_call_n_addr = n;
54 SEXP value = r_eval(sys_call_call, frame);
55
56 FREE(n_protect);
57 return value;
58 }
59
60
generate_sys_call(const char * name,int ** n_addr)61 static sexp* generate_sys_call(const char* name, int** n_addr) {
62 sexp* sys_n = KEEP(r_int(0));
63 *n_addr = r_int_deref(sys_n);
64
65 sexp* sys_args = KEEP(r_new_node(sys_n, r_null));
66 sexp* sys_call = KEEP(r_new_call(r_base_ns_get(name), sys_args));
67 r_mark_precious(sys_call);
68
69 FREE(3);
70 return sys_call;
71 }
72
r_init_library_stack()73 void r_init_library_stack() {
74 sexp* current_frame_body = KEEP(r_parse_eval("as.call(list(sys.frame, -1))", r_base_env));
75 sexp* current_frame_fn = KEEP(r_new_function(r_null, current_frame_body, r_empty_env));
76 current_frame_call = r_new_call(current_frame_fn, r_null);
77 r_mark_precious(current_frame_call);
78 FREE(2);
79
80 sys_frame_call = generate_sys_call("sys.frame", &sys_frame_n_addr);
81 sys_call_call = generate_sys_call("sys.call", &sys_call_n_addr);
82 }
83