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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
#include <stdio.h>
#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_defun(pit_runtime *rt, pit_value args) {
pit_value nm = pit_car(rt, args);
pit_value as = pit_car(rt, pit_cdr(rt, args));
pit_value body = pit_cdr(rt, pit_cdr(rt, args));
return pit_list(rt, 3,
pit_intern_cstr(rt, "fset"),
pit_list(rt, 2, pit_intern_cstr(rt, "quote"), nm),
pit_cons(rt, pit_intern_cstr(rt, "lambda"), pit_cons(rt, as, body))
);
}
static pit_value impl_m_defmacro(pit_runtime *rt, pit_value args) {
pit_value nm = pit_car(rt, args);
return pit_list(rt, 3,
pit_intern_cstr(rt, "progn"),
pit_cons(rt, pit_intern_cstr(rt, "defun"), args),
pit_list(rt, 2, pit_intern_cstr(rt, "set-symbol-macro"), nm)
);
}
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_symbol_is_macro(pit_runtime *rt, pit_value args) {
pit_value sym = pit_car(rt, args);
pit_symbol_is_macro(rt, sym);
return PIT_NIL;
}
static pit_value impl_eval(pit_runtime *rt, pit_value args) {
pit_value x = pit_car(rt, args);
return pit_eval(rt, x);
}
static pit_value impl_print(pit_runtime *rt, pit_value args) {
pit_value x = pit_car(rt, args);
char buf[1024] = {0};
pit_dump(rt, buf, sizeof(buf), x);
buf[1023] = 0;
puts(buf);
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, "defun"), pit_nativefunc_new(rt, impl_m_defun));
pit_mset(rt, pit_intern_cstr(rt, "defmacro"), pit_nativefunc_new(rt, impl_m_defmacro));
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, "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, "symbol-is-macro"), pit_nativefunc_new(rt, impl_symbol_is_macro));
pit_fset(rt, pit_intern_cstr(rt, "eval"), pit_nativefunc_new(rt, impl_eval));
pit_fset(rt, pit_intern_cstr(rt, "print"), pit_nativefunc_new(rt, impl_print));
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));
}
|
