1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
#include "runtime.h"
static pit_value impl_sf_quote(pit_runtime *rt, pit_value args) {
pit_runtime_eval_program_push(rt, rt->program, (pit_runtime_eval_program_entry) {
.sort = EVAL_PROGRAM_ENTRY_LITERAL,
.literal = pit_car(rt, args)
});
return PIT_NIL;
}
static pit_value impl_sf_if(pit_runtime *rt, pit_value args) {
pit_value c = pit_car(rt, args);
if (pit_eval(rt, c) != PIT_NIL) {
pit_values_push(rt, rt->expr_stack, pit_car(rt, pit_cdr(rt, args)));
} else {
pit_values_push(rt, rt->expr_stack, pit_car(rt, pit_cdr(rt, pit_cdr(rt, args))));
}
return PIT_NIL;
}
static pit_value impl_sf_progn(pit_runtime *rt, pit_value args) {
pit_value bodyforms = args;
pit_value final = PIT_NIL;
while (bodyforms != PIT_NIL) {
final = pit_eval(rt, pit_car(rt, bodyforms));
bodyforms = pit_cdr(rt, bodyforms);
}
pit_runtime_eval_program_push(rt, rt->program, (pit_runtime_eval_program_entry) {
.sort = EVAL_PROGRAM_ENTRY_LITERAL,
.literal = final,
});
return PIT_NIL;
}
static pit_value impl_sf_lambda(pit_runtime *rt, pit_value args) {
pit_value as = pit_car(rt, args);
pit_value body = pit_cdr(rt, args);
pit_runtime_eval_program_push(rt, rt->program, (pit_runtime_eval_program_entry) {
.sort = EVAL_PROGRAM_ENTRY_LITERAL,
.literal = pit_lambda(rt, as, body),
});
return PIT_NIL;
}
static pit_value impl_m_let(pit_runtime *rt, pit_value args) {
pit_value lparams = PIT_NIL;
pit_value largs = PIT_NIL;
pit_value binds = pit_car(rt, args);
pit_value bodyforms = pit_cdr(rt, args);
while (binds != PIT_NIL) {
pit_value bind = pit_car(rt, binds);
pit_value sym = pit_car(rt, bind);
pit_value expr = pit_car(rt, pit_cdr(rt, bind));
lparams = pit_cons(rt, sym, lparams);
largs = pit_cons(rt, expr, largs);
binds = pit_cdr(rt, binds);
}
pit_value lambda = pit_cons(rt, pit_intern_cstr(rt, "lambda"), pit_cons(rt, lparams, bodyforms));
pit_value application = pit_cons(rt, lambda, largs);
return application;
}
static pit_value impl_m_and(pit_runtime *rt, pit_value args) {
args = pit_reverse(rt, args);
pit_value ret = PIT_NIL;
if (args != PIT_NIL) {
ret = pit_car(rt, args);
args = pit_cdr(rt, args);
}
while (args != PIT_NIL) {
ret = pit_list(rt, 3, pit_intern_cstr(rt, "if"), pit_car(rt, args), ret, PIT_NIL);
args = pit_cdr(rt, args);
}
return ret;
}
static pit_value impl_set(pit_runtime *rt, pit_value args) {
pit_value sym = pit_car(rt, args);
pit_value v = pit_car(rt, pit_cdr(rt, args));
pit_set(rt, sym, v);
return v;
}
static pit_value impl_fset(pit_runtime *rt, pit_value args) {
pit_value sym = pit_car(rt, args);
pit_value v = pit_car(rt, pit_cdr(rt, args));
pit_fset(rt, sym, v);
return v;
}
static pit_value impl_print(pit_runtime *rt, pit_value args) {
pit_value x = pit_car(rt, args);
pit_trace(rt, x);
return x;
}
static pit_value impl_add(pit_runtime *rt, pit_value args) {
i64 x = pit_as_integer(rt, pit_car(rt, args));
i64 y = pit_as_integer(rt, pit_car(rt, pit_cdr(rt, args)));
return pit_integer_new(rt, x + y);
}
static pit_value impl_sub(pit_runtime *rt, pit_value args) {
i64 x = pit_as_integer(rt, pit_car(rt, args));
i64 y = pit_as_integer(rt, pit_car(rt, pit_cdr(rt, args)));
return pit_integer_new(rt, x - y);
}
void pit_install_library_essential(pit_runtime *rt) {
pit_sfset(rt, pit_intern_cstr(rt, "quote"), pit_nativefunc_new(rt, impl_sf_quote));
pit_sfset(rt, pit_intern_cstr(rt, "if"), pit_nativefunc_new(rt, impl_sf_if));
pit_sfset(rt, pit_intern_cstr(rt, "progn"), pit_nativefunc_new(rt, impl_sf_progn));
pit_sfset(rt, pit_intern_cstr(rt, "lambda"), pit_nativefunc_new(rt, impl_sf_lambda));
pit_mset(rt, pit_intern_cstr(rt, "let"), pit_nativefunc_new(rt, impl_m_let));
pit_mset(rt, pit_intern_cstr(rt, "and"), pit_nativefunc_new(rt, impl_m_and));
pit_fset(rt, pit_intern_cstr(rt, "print"), pit_nativefunc_new(rt, impl_print));
pit_fset(rt, pit_intern_cstr(rt, "set"), pit_nativefunc_new(rt, impl_set));
pit_fset(rt, pit_intern_cstr(rt, "fset"), pit_nativefunc_new(rt, impl_fset));
pit_fset(rt, pit_intern_cstr(rt, "+"), pit_nativefunc_new(rt, impl_add));
pit_fset(rt, pit_intern_cstr(rt, "-"), pit_nativefunc_new(rt, impl_sub));
}
|
