diff options
author | Bad Diode <bd@badd10de.dev> | 2021-10-13 16:44:17 +0200 |
---|---|---|
committer | Bad Diode <bd@badd10de.dev> | 2021-10-13 16:44:17 +0200 |
commit | ed1f406102738812fafa5e49ee131fe06c177687 (patch) | |
tree | 0bb648c18b6f96e0f020a9f8e664df330199b51b /src | |
parent | b8bad3bf5af3261f25780a8cd8b90a659fe29bab (diff) | |
download | bdl-ed1f406102738812fafa5e49ee131fe06c177687.tar.gz bdl-ed1f406102738812fafa5e49ee131fe06c177687.zip |
Add a lot of primitive types
Diffstat (limited to 'src')
-rw-r--r-- | src/bootstrap/errors.c | 2 | ||||
-rwxr-xr-x | src/bootstrap/main.c | 57 | ||||
-rw-r--r-- | src/bootstrap/objects.c | 103 | ||||
-rw-r--r-- | src/bootstrap/primitives.c | 900 |
4 files changed, 948 insertions, 114 deletions
diff --git a/src/bootstrap/errors.c b/src/bootstrap/errors.c index c9d9c97..13a2f3c 100644 --- a/src/bootstrap/errors.c +++ b/src/bootstrap/errors.c | |||
@@ -17,6 +17,7 @@ typedef enum ErrorValue { | |||
17 | ERR_OBJ_NOT_CALLABLE, | 17 | ERR_OBJ_NOT_CALLABLE, |
18 | ERR_NOT_ENOUGH_ARGS, | 18 | ERR_NOT_ENOUGH_ARGS, |
19 | ERR_WRONG_ARG_TYPE, | 19 | ERR_WRONG_ARG_TYPE, |
20 | ERR_DIVISION_BY_ZERO, | ||
20 | } ErrorValue; | 21 | } ErrorValue; |
21 | 22 | ||
22 | typedef struct Error { | 23 | typedef struct Error { |
@@ -39,6 +40,7 @@ static const char* error_msgs[] = { | |||
39 | [ERR_OBJ_NOT_CALLABLE] = "error: object is not callable", | 40 | [ERR_OBJ_NOT_CALLABLE] = "error: object is not callable", |
40 | [ERR_NOT_ENOUGH_ARGS] = "error: not enough arguments", | 41 | [ERR_NOT_ENOUGH_ARGS] = "error: not enough arguments", |
41 | [ERR_WRONG_ARG_TYPE] = "error: wrong argument type", | 42 | [ERR_WRONG_ARG_TYPE] = "error: wrong argument type", |
43 | [ERR_DIVISION_BY_ZERO] = "error: division by zero", | ||
42 | }; | 44 | }; |
43 | 45 | ||
44 | #define ERR_MAX_NUMBER 16 | 46 | #define ERR_MAX_NUMBER 16 |
diff --git a/src/bootstrap/main.c b/src/bootstrap/main.c index 2aa3038..8092bbd 100755 --- a/src/bootstrap/main.c +++ b/src/bootstrap/main.c | |||
@@ -11,8 +11,14 @@ | |||
11 | #include "lexer.c" | 11 | #include "lexer.c" |
12 | #include "objects.c" | 12 | #include "objects.c" |
13 | #include "parser.c" | 13 | #include "parser.c" |
14 | #include "environment.c" | ||
15 | #include "primitives.c" | ||
14 | 16 | ||
15 | #define MAKE_SYM(STR) make_symbol((StringView){(STR), sizeof(STR) - 1}) | 17 | #define MAKE_SYM(STR) make_symbol((StringView){(STR), sizeof(STR) - 1}) |
18 | #define MAKE_ENV_VAR(ENV,STR,VAR) \ | ||
19 | (env_add_symbol((ENV), MAKE_SYM(STR), (VAR))) | ||
20 | #define MAKE_ENV_PROC(ENV,STR,FUN) \ | ||
21 | (env_add_symbol((ENV), MAKE_SYM(STR), make_procedure(FUN))) | ||
16 | 22 | ||
17 | void | 23 | void |
18 | init(void) { | 24 | init(void) { |
@@ -24,8 +30,42 @@ init(void) { | |||
24 | 30 | ||
25 | // Global environment. | 31 | // Global environment. |
26 | global_env = env_create(NULL); | 32 | global_env = env_create(NULL); |
27 | env_add_symbol(global_env, MAKE_SYM("quote"), make_procedure(proc_quote)); | 33 | |
28 | env_add_symbol(global_env, MAKE_SYM("+"), make_procedure(proc_sum)); | 34 | // Primitive symbols. |
35 | MAKE_ENV_VAR(global_env, "else", obj_true); | ||
36 | MAKE_ENV_VAR(global_env, "nil", obj_nil); | ||
37 | |||
38 | // Primitive procedures. | ||
39 | MAKE_ENV_PROC(global_env, "quote", proc_quote); | ||
40 | MAKE_ENV_PROC(global_env, "car", proc_car); | ||
41 | MAKE_ENV_PROC(global_env, "cdr", proc_cdr); | ||
42 | MAKE_ENV_PROC(global_env, "cons", proc_cons); | ||
43 | MAKE_ENV_PROC(global_env, "list", proc_list); | ||
44 | MAKE_ENV_PROC(global_env, "+", proc_sum); | ||
45 | MAKE_ENV_PROC(global_env, "-", proc_sub); | ||
46 | MAKE_ENV_PROC(global_env, "*", proc_mul); | ||
47 | MAKE_ENV_PROC(global_env, "/", proc_div); | ||
48 | MAKE_ENV_PROC(global_env, "%", proc_mod); | ||
49 | MAKE_ENV_PROC(global_env, "print", proc_print); | ||
50 | MAKE_ENV_PROC(global_env, "display", proc_display); | ||
51 | MAKE_ENV_PROC(global_env, "newline", proc_newline); | ||
52 | MAKE_ENV_PROC(global_env, "boolean?", proc_is_boolean); | ||
53 | MAKE_ENV_PROC(global_env, "nil?", proc_is_nil); | ||
54 | MAKE_ENV_PROC(global_env, "symbol?", proc_is_symbol); | ||
55 | MAKE_ENV_PROC(global_env, "string?", proc_is_string); | ||
56 | MAKE_ENV_PROC(global_env, "fixnum?", proc_is_fixnum); | ||
57 | MAKE_ENV_PROC(global_env, "pair?", proc_is_pair); | ||
58 | MAKE_ENV_PROC(global_env, "procedure?", proc_is_procedure); | ||
59 | MAKE_ENV_PROC(global_env, "not", proc_not); | ||
60 | MAKE_ENV_PROC(global_env, "and", proc_and); | ||
61 | MAKE_ENV_PROC(global_env, "or", proc_or); | ||
62 | MAKE_ENV_PROC(global_env, "if", proc_if); | ||
63 | MAKE_ENV_PROC(global_env, "cond", proc_cond); | ||
64 | MAKE_ENV_PROC(global_env, "<", proc_num_less_than); | ||
65 | MAKE_ENV_PROC(global_env, "<=", proc_num_lesseq_than); | ||
66 | MAKE_ENV_PROC(global_env, ">", proc_num_greater_than); | ||
67 | MAKE_ENV_PROC(global_env, ">=", proc_num_greatereq_than); | ||
68 | MAKE_ENV_PROC(global_env, "=", proc_num_equal); | ||
29 | } | 69 | } |
30 | 70 | ||
31 | void | 71 | void |
@@ -51,12 +91,10 @@ process_source(const StringView *source) { | |||
51 | 91 | ||
52 | // FIXME: Not freeing result or intermediate objects, can leak memory. | 92 | // FIXME: Not freeing result or intermediate objects, can leak memory. |
53 | Object *result = eval(global_env, root); | 93 | Object *result = eval(global_env, root); |
54 | printf("AST: "); | 94 | if (result != obj_nil) { |
55 | display(root); | 95 | display(result); |
56 | printf("\n"); | 96 | printf("\n"); |
57 | printf("EVAL: "); | 97 | } |
58 | display(result); | ||
59 | printf("\n"); | ||
60 | free_objects(root); | 98 | free_objects(root); |
61 | } | 99 | } |
62 | 100 | ||
@@ -94,9 +132,6 @@ run_repl(void) { | |||
94 | errors_n = 0; | 132 | errors_n = 0; |
95 | continue; | 133 | continue; |
96 | } | 134 | } |
97 | if (sv.n != 0) { | ||
98 | printf("\n"); | ||
99 | } | ||
100 | } | 135 | } |
101 | } | 136 | } |
102 | 137 | ||
diff --git a/src/bootstrap/objects.c b/src/bootstrap/objects.c index 30827f1..0361ae8 100644 --- a/src/bootstrap/objects.c +++ b/src/bootstrap/objects.c | |||
@@ -197,106 +197,3 @@ display(Object *root) { | |||
197 | } | 197 | } |
198 | return; | 198 | return; |
199 | } | 199 | } |
200 | |||
201 | #include "environment.c" | ||
202 | |||
203 | Object * | ||
204 | eval(Environment* env, Object *root) { | ||
205 | switch (root->type) { | ||
206 | case OBJ_TYPE_FIXNUM: | ||
207 | case OBJ_TYPE_BOOL: | ||
208 | case OBJ_TYPE_NIL: | ||
209 | case OBJ_TYPE_STRING: { | ||
210 | return root; | ||
211 | } break; | ||
212 | case OBJ_TYPE_SYMBOL: { | ||
213 | Object *val = env_lookup(env, root); | ||
214 | if (val == obj_err) { | ||
215 | error_push((Error){ | ||
216 | .type = ERR_TYPE_RUNTIME, | ||
217 | .value = ERR_SYMBOL_NOT_FOUND, | ||
218 | }); | ||
219 | return obj_err; | ||
220 | } | ||
221 | return val; | ||
222 | } break; | ||
223 | case OBJ_TYPE_PAIR: { | ||
224 | if (root->car->type == OBJ_TYPE_SYMBOL) { | ||
225 | Object *val = env_lookup(env, root->car); | ||
226 | if (val == obj_err) { | ||
227 | error_push((Error){ | ||
228 | .type = ERR_TYPE_RUNTIME, | ||
229 | .value = ERR_SYMBOL_NOT_FOUND, | ||
230 | }); | ||
231 | return obj_err; | ||
232 | } | ||
233 | if (val->type == OBJ_TYPE_PROCEDURE) { | ||
234 | return val->proc(env, root->cdr); | ||
235 | } | ||
236 | error_push((Error){ | ||
237 | .type = ERR_TYPE_RUNTIME, | ||
238 | .value = ERR_OBJ_NOT_CALLABLE, | ||
239 | }); | ||
240 | return obj_err; | ||
241 | } | ||
242 | } break; | ||
243 | default: { | ||
244 | break; | ||
245 | } break; | ||
246 | } | ||
247 | |||
248 | error_push((Error){ | ||
249 | .type = ERR_TYPE_RUNTIME, | ||
250 | .value = ERR_UNKNOWN_OBJ_TYPE, | ||
251 | }); | ||
252 | return obj_err; | ||
253 | } | ||
254 | |||
255 | Object * | ||
256 | proc_quote(Environment *env, Object *obj) { | ||
257 | (void)env; | ||
258 | return obj->car; | ||
259 | } | ||
260 | |||
261 | Object * | ||
262 | proc_sum(Environment *env, Object *obj) { | ||
263 | // First argument. | ||
264 | if (obj == obj_nil) { | ||
265 | error_push((Error){ | ||
266 | .type = ERR_TYPE_RUNTIME, | ||
267 | .value = ERR_NOT_ENOUGH_ARGS, | ||
268 | }); | ||
269 | return obj_err; | ||
270 | } | ||
271 | Object *car = eval(env, obj->car); | ||
272 | if (car == obj_err) { | ||
273 | return obj_err; | ||
274 | } | ||
275 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
276 | error_push((Error){ | ||
277 | .type = ERR_TYPE_RUNTIME, | ||
278 | .value = ERR_WRONG_ARG_TYPE, | ||
279 | }); | ||
280 | return obj_err; | ||
281 | } | ||
282 | |||
283 | // Traverse the list. | ||
284 | obj = obj->cdr; | ||
285 | ssize_t tot = car->fixnum; | ||
286 | while (obj->type == OBJ_TYPE_PAIR) { | ||
287 | Object *car = eval(env, obj->car); | ||
288 | if (car == obj_err) { | ||
289 | return obj_err; | ||
290 | } | ||
291 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
292 | error_push((Error){ | ||
293 | .type = ERR_TYPE_RUNTIME, | ||
294 | .value = ERR_WRONG_ARG_TYPE, | ||
295 | }); | ||
296 | return obj_err; | ||
297 | } | ||
298 | tot += car->fixnum; | ||
299 | obj = obj->cdr; | ||
300 | } | ||
301 | return make_fixnum(tot); | ||
302 | } | ||
diff --git a/src/bootstrap/primitives.c b/src/bootstrap/primitives.c new file mode 100644 index 0000000..8369fa8 --- /dev/null +++ b/src/bootstrap/primitives.c | |||
@@ -0,0 +1,900 @@ | |||
1 | Object * | ||
2 | eval(Environment* env, Object *root) { | ||
3 | switch (root->type) { | ||
4 | case OBJ_TYPE_FIXNUM: | ||
5 | case OBJ_TYPE_BOOL: | ||
6 | case OBJ_TYPE_NIL: | ||
7 | case OBJ_TYPE_STRING: { | ||
8 | return root; | ||
9 | } break; | ||
10 | case OBJ_TYPE_SYMBOL: { | ||
11 | Object *val = env_lookup(env, root); | ||
12 | if (val == obj_err) { | ||
13 | error_push((Error){ | ||
14 | .type = ERR_TYPE_RUNTIME, | ||
15 | .value = ERR_SYMBOL_NOT_FOUND, | ||
16 | }); | ||
17 | return obj_err; | ||
18 | } | ||
19 | return val; | ||
20 | } break; | ||
21 | case OBJ_TYPE_PAIR: { | ||
22 | if (root->car->type == OBJ_TYPE_SYMBOL) { | ||
23 | Object *val = env_lookup(env, root->car); | ||
24 | if (val == obj_err) { | ||
25 | error_push((Error){ | ||
26 | .type = ERR_TYPE_RUNTIME, | ||
27 | .value = ERR_SYMBOL_NOT_FOUND, | ||
28 | }); | ||
29 | return obj_err; | ||
30 | } | ||
31 | if (val->type == OBJ_TYPE_PROCEDURE) { | ||
32 | return val->proc(env, root->cdr); | ||
33 | } | ||
34 | error_push((Error){ | ||
35 | .type = ERR_TYPE_RUNTIME, | ||
36 | .value = ERR_OBJ_NOT_CALLABLE, | ||
37 | }); | ||
38 | return obj_err; | ||
39 | } | ||
40 | } break; | ||
41 | default: { | ||
42 | break; | ||
43 | } break; | ||
44 | } | ||
45 | |||
46 | printf("DING\n"); | ||
47 | display(root); | ||
48 | printf("\nTYPE: %d\n", root->type); | ||
49 | |||
50 | error_push((Error){ | ||
51 | .type = ERR_TYPE_RUNTIME, | ||
52 | .value = ERR_UNKNOWN_OBJ_TYPE, | ||
53 | }); | ||
54 | return obj_err; | ||
55 | } | ||
56 | |||
57 | Object * | ||
58 | proc_quote(Environment *env, Object *obj) { | ||
59 | (void)env; | ||
60 | return obj->car; | ||
61 | } | ||
62 | |||
63 | // | ||
64 | // Arithmetic procedures. | ||
65 | // | ||
66 | |||
67 | Object * | ||
68 | proc_sum(Environment *env, Object *obj) { | ||
69 | // First argument. | ||
70 | if (obj == obj_nil) { | ||
71 | error_push((Error){ | ||
72 | .type = ERR_TYPE_RUNTIME, | ||
73 | .value = ERR_NOT_ENOUGH_ARGS, | ||
74 | }); | ||
75 | return obj_err; | ||
76 | } | ||
77 | Object *car = eval(env, obj->car); | ||
78 | if (car == obj_err) { | ||
79 | return obj_err; | ||
80 | } | ||
81 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
82 | error_push((Error){ | ||
83 | .type = ERR_TYPE_RUNTIME, | ||
84 | .value = ERR_WRONG_ARG_TYPE, | ||
85 | }); | ||
86 | return obj_err; | ||
87 | } | ||
88 | |||
89 | // Traverse the list. | ||
90 | obj = obj->cdr; | ||
91 | ssize_t tot = car->fixnum; | ||
92 | while (obj != obj_nil) { | ||
93 | car = eval(env, obj->car); | ||
94 | if (car == obj_err) { | ||
95 | return obj_err; | ||
96 | } | ||
97 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
98 | error_push((Error){ | ||
99 | .type = ERR_TYPE_RUNTIME, | ||
100 | .value = ERR_WRONG_ARG_TYPE, | ||
101 | }); | ||
102 | return obj_err; | ||
103 | } | ||
104 | tot += car->fixnum; | ||
105 | obj = obj->cdr; | ||
106 | } | ||
107 | return make_fixnum(tot); | ||
108 | } | ||
109 | |||
110 | Object * | ||
111 | proc_sub(Environment *env, Object *obj) { | ||
112 | // First argument. | ||
113 | if (obj == obj_nil) { | ||
114 | error_push((Error){ | ||
115 | .type = ERR_TYPE_RUNTIME, | ||
116 | .value = ERR_NOT_ENOUGH_ARGS, | ||
117 | }); | ||
118 | return obj_err; | ||
119 | } | ||
120 | Object *car = eval(env, obj->car); | ||
121 | if (car == obj_err) { | ||
122 | return obj_err; | ||
123 | } | ||
124 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
125 | error_push((Error){ | ||
126 | .type = ERR_TYPE_RUNTIME, | ||
127 | .value = ERR_WRONG_ARG_TYPE, | ||
128 | }); | ||
129 | return obj_err; | ||
130 | } | ||
131 | |||
132 | // Traverse the list. | ||
133 | obj = obj->cdr; | ||
134 | ssize_t tot = car->fixnum; | ||
135 | while (obj != obj_nil) { | ||
136 | car = eval(env, obj->car); | ||
137 | if (car == obj_err) { | ||
138 | return obj_err; | ||
139 | } | ||
140 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
141 | error_push((Error){ | ||
142 | .type = ERR_TYPE_RUNTIME, | ||
143 | .value = ERR_WRONG_ARG_TYPE, | ||
144 | }); | ||
145 | return obj_err; | ||
146 | } | ||
147 | tot -= car->fixnum; | ||
148 | obj = obj->cdr; | ||
149 | } | ||
150 | return make_fixnum(tot); | ||
151 | } | ||
152 | |||
153 | Object * | ||
154 | proc_mul(Environment *env, Object *obj) { | ||
155 | // First argument. | ||
156 | if (obj == obj_nil) { | ||
157 | error_push((Error){ | ||
158 | .type = ERR_TYPE_RUNTIME, | ||
159 | .value = ERR_NOT_ENOUGH_ARGS, | ||
160 | }); | ||
161 | return obj_err; | ||
162 | } | ||
163 | Object *car = eval(env, obj->car); | ||
164 | if (car == obj_err) { | ||
165 | return obj_err; | ||
166 | } | ||
167 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
168 | error_push((Error){ | ||
169 | .type = ERR_TYPE_RUNTIME, | ||
170 | .value = ERR_WRONG_ARG_TYPE, | ||
171 | }); | ||
172 | return obj_err; | ||
173 | } | ||
174 | |||
175 | // Traverse the list. | ||
176 | obj = obj->cdr; | ||
177 | ssize_t tot = car->fixnum; | ||
178 | while (obj != obj_nil) { | ||
179 | Object *car = eval(env, obj->car); | ||
180 | if (car == obj_err) { | ||
181 | return obj_err; | ||
182 | } | ||
183 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
184 | error_push((Error){ | ||
185 | .type = ERR_TYPE_RUNTIME, | ||
186 | .value = ERR_WRONG_ARG_TYPE, | ||
187 | }); | ||
188 | return obj_err; | ||
189 | } | ||
190 | tot *= car->fixnum; | ||
191 | obj = obj->cdr; | ||
192 | } | ||
193 | return make_fixnum(tot); | ||
194 | } | ||
195 | |||
196 | Object * | ||
197 | proc_div(Environment *env, Object *obj) { | ||
198 | // First argument. | ||
199 | if (obj == obj_nil) { | ||
200 | error_push((Error){ | ||
201 | .type = ERR_TYPE_RUNTIME, | ||
202 | .value = ERR_NOT_ENOUGH_ARGS, | ||
203 | }); | ||
204 | return obj_err; | ||
205 | } | ||
206 | Object *car = eval(env, obj->car); | ||
207 | if (car == obj_err) { | ||
208 | return obj_err; | ||
209 | } | ||
210 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
211 | error_push((Error){ | ||
212 | .type = ERR_TYPE_RUNTIME, | ||
213 | .value = ERR_WRONG_ARG_TYPE, | ||
214 | }); | ||
215 | return obj_err; | ||
216 | } | ||
217 | |||
218 | // Traverse the list. | ||
219 | obj = obj->cdr; | ||
220 | ssize_t tot = car->fixnum; | ||
221 | while (obj != obj_nil) { | ||
222 | Object *car = eval(env, obj->car); | ||
223 | if (car == obj_err) { | ||
224 | return obj_err; | ||
225 | } | ||
226 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
227 | error_push((Error){ | ||
228 | .type = ERR_TYPE_RUNTIME, | ||
229 | .value = ERR_WRONG_ARG_TYPE, | ||
230 | }); | ||
231 | return obj_err; | ||
232 | } | ||
233 | if (car->fixnum == 0) { | ||
234 | error_push((Error){ | ||
235 | .type = ERR_TYPE_RUNTIME, | ||
236 | .value = ERR_DIVISION_BY_ZERO, | ||
237 | }); | ||
238 | return obj_err; | ||
239 | } | ||
240 | tot /= car->fixnum; | ||
241 | obj = obj->cdr; | ||
242 | } | ||
243 | return make_fixnum(tot); | ||
244 | } | ||
245 | |||
246 | Object * | ||
247 | proc_mod(Environment *env, Object *obj) { | ||
248 | // First argument. | ||
249 | if (obj == obj_nil) { | ||
250 | error_push((Error){ | ||
251 | .type = ERR_TYPE_RUNTIME, | ||
252 | .value = ERR_NOT_ENOUGH_ARGS, | ||
253 | }); | ||
254 | return obj_err; | ||
255 | } | ||
256 | Object *car = eval(env, obj->car); | ||
257 | if (car == obj_err) { | ||
258 | return obj_err; | ||
259 | } | ||
260 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
261 | error_push((Error){ | ||
262 | .type = ERR_TYPE_RUNTIME, | ||
263 | .value = ERR_WRONG_ARG_TYPE, | ||
264 | }); | ||
265 | return obj_err; | ||
266 | } | ||
267 | |||
268 | // Traverse the list. | ||
269 | obj = obj->cdr; | ||
270 | ssize_t tot = car->fixnum; | ||
271 | while (obj != obj_nil) { | ||
272 | Object *car = eval(env, obj->car); | ||
273 | if (car == obj_err) { | ||
274 | return obj_err; | ||
275 | } | ||
276 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
277 | error_push((Error){ | ||
278 | .type = ERR_TYPE_RUNTIME, | ||
279 | .value = ERR_WRONG_ARG_TYPE, | ||
280 | }); | ||
281 | return obj_err; | ||
282 | } | ||
283 | if (car->fixnum == 0) { | ||
284 | error_push((Error){ | ||
285 | .type = ERR_TYPE_RUNTIME, | ||
286 | .value = ERR_DIVISION_BY_ZERO, | ||
287 | }); | ||
288 | return obj_err; | ||
289 | } | ||
290 | tot %= car->fixnum; | ||
291 | obj = obj->cdr; | ||
292 | } | ||
293 | return make_fixnum(tot); | ||
294 | } | ||
295 | |||
296 | // | ||
297 | // Display/Evaluation procedues. | ||
298 | // | ||
299 | |||
300 | Object * | ||
301 | proc_display(Environment *env, Object *obj) { | ||
302 | display(eval(env, obj->car)); | ||
303 | return obj_nil; | ||
304 | } | ||
305 | |||
306 | Object * | ||
307 | proc_print(Environment *env, Object *obj) { | ||
308 | if (obj == obj_nil) { | ||
309 | error_push((Error){ | ||
310 | .type = ERR_TYPE_RUNTIME, | ||
311 | .value = ERR_NOT_ENOUGH_ARGS, | ||
312 | }); | ||
313 | return obj_err; | ||
314 | } | ||
315 | Object *car = eval(env, obj->car); | ||
316 | if (car == obj_err) { | ||
317 | return obj_err; | ||
318 | } | ||
319 | if (car->type != OBJ_TYPE_STRING) { | ||
320 | error_push((Error){ | ||
321 | .type = ERR_TYPE_RUNTIME, | ||
322 | .value = ERR_WRONG_ARG_TYPE, | ||
323 | }); | ||
324 | return obj_err; | ||
325 | } | ||
326 | |||
327 | StringView scanner = (StringView) { | ||
328 | .start = car->string, | ||
329 | .n = car->string_n, | ||
330 | }; | ||
331 | while (scanner.n != 0) { | ||
332 | char c = sv_next(&scanner); | ||
333 | if (c == '\\' && sv_peek(&scanner) == 'n') { | ||
334 | putchar('\n'); | ||
335 | sv_next(&scanner); | ||
336 | continue; | ||
337 | } | ||
338 | if (c == '\\' && sv_peek(&scanner) == '"') { | ||
339 | putchar('"'); | ||
340 | sv_next(&scanner); | ||
341 | continue; | ||
342 | } | ||
343 | putchar(c); | ||
344 | } | ||
345 | return obj_nil; | ||
346 | } | ||
347 | |||
348 | Object * | ||
349 | proc_newline(Environment *env, Object *obj) { | ||
350 | printf("\n"); | ||
351 | (void)env; | ||
352 | (void)obj; | ||
353 | return obj_nil; | ||
354 | } | ||
355 | |||
356 | // | ||
357 | // Type info procedures. | ||
358 | // | ||
359 | |||
360 | Object * | ||
361 | proc_is_boolean(Environment *env, Object *obj) { | ||
362 | if (obj == obj_nil) { | ||
363 | error_push((Error){ | ||
364 | .type = ERR_TYPE_RUNTIME, | ||
365 | .value = ERR_NOT_ENOUGH_ARGS, | ||
366 | }); | ||
367 | return obj_err; | ||
368 | } | ||
369 | obj = eval(env, obj->car); | ||
370 | if (obj == obj_err) { | ||
371 | return obj_err; | ||
372 | } | ||
373 | return (obj == obj_true || obj == obj_false) ? obj_true : obj_false; | ||
374 | } | ||
375 | |||
376 | Object * | ||
377 | proc_is_nil(Environment *env, Object *obj) { | ||
378 | if (obj == obj_nil) { | ||
379 | error_push((Error){ | ||
380 | .type = ERR_TYPE_RUNTIME, | ||
381 | .value = ERR_NOT_ENOUGH_ARGS, | ||
382 | }); | ||
383 | return obj_err; | ||
384 | } | ||
385 | obj = eval(env, obj->car); | ||
386 | if (obj == obj_err) { | ||
387 | return obj_err; | ||
388 | } | ||
389 | return obj == obj_nil ? obj_true : obj_false; | ||
390 | } | ||
391 | |||
392 | Object * | ||
393 | proc_is_symbol(Environment *env, Object *obj) { | ||
394 | if (obj == obj_nil) { | ||
395 | error_push((Error){ | ||
396 | .type = ERR_TYPE_RUNTIME, | ||
397 | .value = ERR_NOT_ENOUGH_ARGS, | ||
398 | }); | ||
399 | return obj_err; | ||
400 | } | ||
401 | obj = eval(env, obj->car); | ||
402 | if (obj == obj_err) { | ||
403 | return obj_err; | ||
404 | } | ||
405 | return obj->type == OBJ_TYPE_SYMBOL ? obj_true : obj_false; | ||
406 | } | ||
407 | |||
408 | Object * | ||
409 | proc_is_string(Environment *env, Object *obj) { | ||
410 | if (obj == obj_nil) { | ||
411 | error_push((Error){ | ||
412 | .type = ERR_TYPE_RUNTIME, | ||
413 | .value = ERR_NOT_ENOUGH_ARGS, | ||
414 | }); | ||
415 | return obj_err; | ||
416 | } | ||
417 | obj = eval(env, obj->car); | ||
418 | if (obj == obj_err) { | ||
419 | return obj_err; | ||
420 | } | ||
421 | return obj->type == OBJ_TYPE_STRING ? obj_true : obj_false; | ||
422 | } | ||
423 | |||
424 | Object * | ||
425 | proc_is_fixnum(Environment *env, Object *obj) { | ||
426 | if (obj == obj_nil) { | ||
427 | error_push((Error){ | ||
428 | .type = ERR_TYPE_RUNTIME, | ||
429 | .value = ERR_NOT_ENOUGH_ARGS, | ||
430 | }); | ||
431 | return obj_err; | ||
432 | } | ||
433 | obj = eval(env, obj->car); | ||
434 | if (obj == obj_err) { | ||
435 | return obj_err; | ||
436 | } | ||
437 | return obj->type == OBJ_TYPE_FIXNUM ? obj_true : obj_false; | ||
438 | } | ||
439 | |||
440 | Object * | ||
441 | proc_is_pair(Environment *env, Object *obj) { | ||
442 | if (obj == obj_nil) { | ||
443 | error_push((Error){ | ||
444 | .type = ERR_TYPE_RUNTIME, | ||
445 | .value = ERR_NOT_ENOUGH_ARGS, | ||
446 | }); | ||
447 | return obj_err; | ||
448 | } | ||
449 | obj = eval(env, obj->car); | ||
450 | if (obj == obj_err) { | ||
451 | return obj_err; | ||
452 | } | ||
453 | return obj->type == OBJ_TYPE_PAIR ? obj_true : obj_false; | ||
454 | } | ||
455 | |||
456 | Object * | ||
457 | proc_is_procedure(Environment *env, Object *obj) { | ||
458 | if (obj == obj_nil) { | ||
459 | error_push((Error){ | ||
460 | .type = ERR_TYPE_RUNTIME, | ||
461 | .value = ERR_NOT_ENOUGH_ARGS, | ||
462 | }); | ||
463 | return obj_err; | ||
464 | } | ||
465 | obj = eval(env, obj->car); | ||
466 | if (obj == obj_err) { | ||
467 | return obj_err; | ||
468 | } | ||
469 | return obj->type == OBJ_TYPE_PROCEDURE ? obj_true : obj_false; | ||
470 | } | ||
471 | |||
472 | // | ||
473 | // Boolean/conditional procedures. | ||
474 | // | ||
475 | |||
476 | Object * | ||
477 | proc_not(Environment *env, Object *obj) { | ||
478 | if (obj == obj_nil) { | ||
479 | error_push((Error){ | ||
480 | .type = ERR_TYPE_RUNTIME, | ||
481 | .value = ERR_NOT_ENOUGH_ARGS, | ||
482 | }); | ||
483 | return obj_err; | ||
484 | } | ||
485 | obj = eval(env, obj->car); | ||
486 | if (obj == obj_err) { | ||
487 | return obj_err; | ||
488 | } | ||
489 | return obj == obj_false ? obj_true : obj_false; | ||
490 | } | ||
491 | |||
492 | Object * | ||
493 | proc_and(Environment *env, Object *obj) { | ||
494 | while (obj != obj_nil) { | ||
495 | if (proc_not(env, obj) == obj_true) { | ||
496 | return obj_false; | ||
497 | } | ||
498 | obj = obj->cdr; | ||
499 | } | ||
500 | return obj_true; | ||
501 | } | ||
502 | |||
503 | Object * | ||
504 | proc_or(Environment *env, Object *obj) { | ||
505 | while (obj != obj_nil) { | ||
506 | if (proc_not(env, obj) == obj_false) { | ||
507 | return obj_true; | ||
508 | } | ||
509 | obj = obj->cdr; | ||
510 | } | ||
511 | return obj_false; | ||
512 | } | ||
513 | |||
514 | Object * | ||
515 | proc_if(Environment *env, Object *obj) { | ||
516 | if (obj == obj_nil || obj->cdr == obj_nil) { | ||
517 | error_push((Error){ | ||
518 | .type = ERR_TYPE_RUNTIME, | ||
519 | .value = ERR_NOT_ENOUGH_ARGS, | ||
520 | }); | ||
521 | return obj_err; | ||
522 | } | ||
523 | Object *car = obj->car; | ||
524 | Object *cdr = obj->cdr; | ||
525 | Object *clause = eval(env, car); | ||
526 | if (obj == obj_err) { | ||
527 | return obj_err; | ||
528 | } | ||
529 | if (clause == obj_true) { | ||
530 | return eval(env, cdr->car); | ||
531 | } | ||
532 | if (obj->cdr->cdr != obj_nil) { | ||
533 | return eval(env, cdr->cdr->car); | ||
534 | } | ||
535 | |||
536 | return obj_nil; | ||
537 | } | ||
538 | |||
539 | Object * | ||
540 | proc_cond(Environment *env, Object *obj) { | ||
541 | if (obj == obj_nil) { | ||
542 | error_push((Error){ | ||
543 | .type = ERR_TYPE_RUNTIME, | ||
544 | .value = ERR_NOT_ENOUGH_ARGS, | ||
545 | }); | ||
546 | return obj_err; | ||
547 | } | ||
548 | |||
549 | if (obj->car->type != OBJ_TYPE_PAIR) { | ||
550 | error_push((Error){ | ||
551 | .type = ERR_TYPE_RUNTIME, | ||
552 | .value = ERR_WRONG_ARG_TYPE, | ||
553 | }); | ||
554 | return obj_err; | ||
555 | } | ||
556 | |||
557 | // TODO: review this, the cdr->car could cause issues? | ||
558 | while (obj != obj_nil) { | ||
559 | Object *clause = obj->car; | ||
560 | Object *result = eval(env, clause->car); | ||
561 | if (result == obj_err) { | ||
562 | return obj_err; | ||
563 | } | ||
564 | if (result == obj_true) { | ||
565 | return eval(env, clause->cdr->car); | ||
566 | } | ||
567 | obj = obj->cdr; | ||
568 | } | ||
569 | return obj_nil; | ||
570 | } | ||
571 | |||
572 | Object * | ||
573 | proc_num_less_than(Environment *env, Object *obj) { | ||
574 | // First argument. | ||
575 | if (obj == obj_nil) { | ||
576 | error_push((Error){ | ||
577 | .type = ERR_TYPE_RUNTIME, | ||
578 | .value = ERR_NOT_ENOUGH_ARGS, | ||
579 | }); | ||
580 | return obj_err; | ||
581 | } | ||
582 | Object *car = eval(env, obj->car); | ||
583 | if (car == obj_err) { | ||
584 | return obj_err; | ||
585 | } | ||
586 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
587 | error_push((Error){ | ||
588 | .type = ERR_TYPE_RUNTIME, | ||
589 | .value = ERR_WRONG_ARG_TYPE, | ||
590 | }); | ||
591 | return obj_err; | ||
592 | } | ||
593 | |||
594 | // Traverse the list. | ||
595 | obj = obj->cdr; | ||
596 | ssize_t prev = car->fixnum; | ||
597 | while (obj != obj_nil) { | ||
598 | car = eval(env, obj->car); | ||
599 | if (car == obj_err) { | ||
600 | return obj_err; | ||
601 | } | ||
602 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
603 | error_push((Error){ | ||
604 | .type = ERR_TYPE_RUNTIME, | ||
605 | .value = ERR_WRONG_ARG_TYPE, | ||
606 | }); | ||
607 | return obj_err; | ||
608 | } | ||
609 | if (prev >= car->fixnum) { | ||
610 | return obj_false; | ||
611 | } | ||
612 | prev = car->fixnum; | ||
613 | obj = obj->cdr; | ||
614 | } | ||
615 | return obj_true; | ||
616 | } | ||
617 | |||
618 | Object * | ||
619 | proc_num_greater_than(Environment *env, Object *obj) { | ||
620 | // First argument. | ||
621 | if (obj == obj_nil) { | ||
622 | error_push((Error){ | ||
623 | .type = ERR_TYPE_RUNTIME, | ||
624 | .value = ERR_NOT_ENOUGH_ARGS, | ||
625 | }); | ||
626 | return obj_err; | ||
627 | } | ||
628 | Object *car = eval(env, obj->car); | ||
629 | if (car == obj_err) { | ||
630 | return obj_err; | ||
631 | } | ||
632 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
633 | error_push((Error){ | ||
634 | .type = ERR_TYPE_RUNTIME, | ||
635 | .value = ERR_WRONG_ARG_TYPE, | ||
636 | }); | ||
637 | return obj_err; | ||
638 | } | ||
639 | |||
640 | // Traverse the list. | ||
641 | obj = obj->cdr; | ||
642 | ssize_t prev = car->fixnum; | ||
643 | while (obj != obj_nil) { | ||
644 | car = eval(env, obj->car); | ||
645 | if (car == obj_err) { | ||
646 | return obj_err; | ||
647 | } | ||
648 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
649 | error_push((Error){ | ||
650 | .type = ERR_TYPE_RUNTIME, | ||
651 | .value = ERR_WRONG_ARG_TYPE, | ||
652 | }); | ||
653 | return obj_err; | ||
654 | } | ||
655 | if (prev <= car->fixnum) { | ||
656 | return obj_false; | ||
657 | } | ||
658 | prev = car->fixnum; | ||
659 | obj = obj->cdr; | ||
660 | } | ||
661 | return obj_true; | ||
662 | } | ||
663 | |||
664 | Object * | ||
665 | proc_num_lesseq_than(Environment *env, Object *obj) { | ||
666 | // First argument. | ||
667 | if (obj == obj_nil) { | ||
668 | error_push((Error){ | ||
669 | .type = ERR_TYPE_RUNTIME, | ||
670 | .value = ERR_NOT_ENOUGH_ARGS, | ||
671 | }); | ||
672 | return obj_err; | ||
673 | } | ||
674 | Object *car = eval(env, obj->car); | ||
675 | if (car == obj_err) { | ||
676 | return obj_err; | ||
677 | } | ||
678 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
679 | error_push((Error){ | ||
680 | .type = ERR_TYPE_RUNTIME, | ||
681 | .value = ERR_WRONG_ARG_TYPE, | ||
682 | }); | ||
683 | return obj_err; | ||
684 | } | ||
685 | |||
686 | // Traverse the list. | ||
687 | obj = obj->cdr; | ||
688 | ssize_t prev = car->fixnum; | ||
689 | while (obj != obj_nil) { | ||
690 | car = eval(env, obj->car); | ||
691 | if (car == obj_err) { | ||
692 | return obj_err; | ||
693 | } | ||
694 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
695 | error_push((Error){ | ||
696 | .type = ERR_TYPE_RUNTIME, | ||
697 | .value = ERR_WRONG_ARG_TYPE, | ||
698 | }); | ||
699 | return obj_err; | ||
700 | } | ||
701 | if (prev > car->fixnum) { | ||
702 | return obj_false; | ||
703 | } | ||
704 | prev = car->fixnum; | ||
705 | obj = obj->cdr; | ||
706 | } | ||
707 | return obj_true; | ||
708 | } | ||
709 | |||
710 | Object * | ||
711 | proc_num_greatereq_than(Environment *env, Object *obj) { | ||
712 | // First argument. | ||
713 | if (obj == obj_nil) { | ||
714 | error_push((Error){ | ||
715 | .type = ERR_TYPE_RUNTIME, | ||
716 | .value = ERR_NOT_ENOUGH_ARGS, | ||
717 | }); | ||
718 | return obj_err; | ||
719 | } | ||
720 | Object *car = eval(env, obj->car); | ||
721 | if (car == obj_err) { | ||
722 | return obj_err; | ||
723 | } | ||
724 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
725 | error_push((Error){ | ||
726 | .type = ERR_TYPE_RUNTIME, | ||
727 | .value = ERR_WRONG_ARG_TYPE, | ||
728 | }); | ||
729 | return obj_err; | ||
730 | } | ||
731 | |||
732 | // Traverse the list. | ||
733 | obj = obj->cdr; | ||
734 | ssize_t prev = car->fixnum; | ||
735 | while (obj != obj_nil) { | ||
736 | car = eval(env, obj->car); | ||
737 | if (car == obj_err) { | ||
738 | return obj_err; | ||
739 | } | ||
740 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
741 | error_push((Error){ | ||
742 | .type = ERR_TYPE_RUNTIME, | ||
743 | .value = ERR_WRONG_ARG_TYPE, | ||
744 | }); | ||
745 | return obj_err; | ||
746 | } | ||
747 | if (prev < car->fixnum) { | ||
748 | return obj_false; | ||
749 | } | ||
750 | prev = car->fixnum; | ||
751 | obj = obj->cdr; | ||
752 | } | ||
753 | return obj_true; | ||
754 | } | ||
755 | |||
756 | Object * | ||
757 | proc_num_equal(Environment *env, Object *obj) { | ||
758 | // First argument. | ||
759 | if (obj == obj_nil) { | ||
760 | error_push((Error){ | ||
761 | .type = ERR_TYPE_RUNTIME, | ||
762 | .value = ERR_NOT_ENOUGH_ARGS, | ||
763 | }); | ||
764 | return obj_err; | ||
765 | } | ||
766 | Object *car = eval(env, obj->car); | ||
767 | if (car == obj_err) { | ||
768 | return obj_err; | ||
769 | } | ||
770 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
771 | error_push((Error){ | ||
772 | .type = ERR_TYPE_RUNTIME, | ||
773 | .value = ERR_WRONG_ARG_TYPE, | ||
774 | }); | ||
775 | return obj_err; | ||
776 | } | ||
777 | |||
778 | // Traverse the list. | ||
779 | obj = obj->cdr; | ||
780 | ssize_t prev = car->fixnum; | ||
781 | while (obj != obj_nil) { | ||
782 | car = eval(env, obj->car); | ||
783 | if (car == obj_err) { | ||
784 | return obj_err; | ||
785 | } | ||
786 | if (car->type != OBJ_TYPE_FIXNUM) { | ||
787 | error_push((Error){ | ||
788 | .type = ERR_TYPE_RUNTIME, | ||
789 | .value = ERR_WRONG_ARG_TYPE, | ||
790 | }); | ||
791 | return obj_err; | ||
792 | } | ||
793 | if (prev != car->fixnum) { | ||
794 | return obj_false; | ||
795 | } | ||
796 | prev = car->fixnum; | ||
797 | obj = obj->cdr; | ||
798 | } | ||
799 | return obj_true; | ||
800 | } | ||
801 | |||
802 | // | ||
803 | // List operation procedures. | ||
804 | // | ||
805 | |||
806 | Object * | ||
807 | proc_car(Environment *env, Object *obj) { | ||
808 | if (obj == obj_nil) { | ||
809 | error_push((Error){ | ||
810 | .type = ERR_TYPE_RUNTIME, | ||
811 | .value = ERR_NOT_ENOUGH_ARGS, | ||
812 | }); | ||
813 | return obj_err; | ||
814 | } | ||
815 | obj = eval(env, obj->car); | ||
816 | if (obj == obj_err) { | ||
817 | return obj_err; | ||
818 | } | ||
819 | if (obj->type != OBJ_TYPE_PAIR) { | ||
820 | error_push((Error){ | ||
821 | .type = ERR_TYPE_RUNTIME, | ||
822 | .value = ERR_WRONG_ARG_TYPE, | ||
823 | }); | ||
824 | return obj_err; | ||
825 | } | ||
826 | return obj->car; | ||
827 | } | ||
828 | |||
829 | Object * | ||
830 | proc_cdr(Environment *env, Object *obj) { | ||
831 | if (obj == obj_nil) { | ||
832 | error_push((Error){ | ||
833 | .type = ERR_TYPE_RUNTIME, | ||
834 | .value = ERR_NOT_ENOUGH_ARGS, | ||
835 | }); | ||
836 | return obj_err; | ||
837 | } | ||
838 | obj = eval(env, obj->car); | ||
839 | if (obj == obj_err) { | ||
840 | return obj_err; | ||
841 | } | ||
842 | if (obj->type != OBJ_TYPE_PAIR) { | ||
843 | error_push((Error){ | ||
844 | .type = ERR_TYPE_RUNTIME, | ||
845 | .value = ERR_WRONG_ARG_TYPE, | ||
846 | }); | ||
847 | return obj_err; | ||
848 | } | ||
849 | return obj->cdr; | ||
850 | } | ||
851 | |||
852 | Object * | ||
853 | proc_cons(Environment *env, Object *obj) { | ||
854 | if (obj == obj_nil || obj->cdr == obj_nil) { | ||
855 | fprintf(stderr, "error: not enough arguments\n"); | ||
856 | return obj_nil; | ||
857 | } | ||
858 | Object *a = eval(env, obj->car); | ||
859 | Object *b = eval(env, obj->cdr->car); | ||
860 | return make_pair(a, b); | ||
861 | } | ||
862 | |||
863 | Object * | ||
864 | proc_list(Environment *env, Object *obj) { | ||
865 | if (obj == obj_nil) { | ||
866 | return obj_nil; | ||
867 | } | ||
868 | Object *head = make_pair(eval(env, obj->car), obj_nil); | ||
869 | Object *curr = head; | ||
870 | obj = obj->cdr; | ||
871 | while (obj != obj_nil) { | ||
872 | curr->cdr = make_pair(eval(env, obj->car), obj_nil); | ||
873 | curr = curr->cdr; | ||
874 | obj = obj->cdr; | ||
875 | } | ||
876 | return head; | ||
877 | } | ||
878 | |||
879 | // | ||
880 | // Polymorphic procedures. | ||
881 | // | ||
882 | |||
883 | //Object * | ||
884 | //proc_equal(Object *args) { | ||
885 | // // TODO: stub | ||
886 | // (void) args; | ||
887 | // return NULL; | ||
888 | //} | ||
889 | |||
890 | //// TODO: fixnum left/right shift, mask, invert | ||
891 | //// TODO: implement and test missing procedures | ||
892 | //// TODO: add primitives for type transforms: string->symbol, symbol->string, etc | ||
893 | //// TODO: properly implement nested environments | ||
894 | //// TODO: implement support for quotes and semi-quotes | ||
895 | //// TODO: LAMBDA | ||
896 | //// TODO: let | ||
897 | //// TODO: better error handling? | ||
898 | //// TODO: Revise all instances where we are returning an object, since currently | ||
899 | //// we may be returning a pointer to an object instead of a new one. Check also | ||
900 | //// on eval function and everytime we do make_xxx(obj). | ||