diff options
Diffstat (limited to 'src/bootstrap/primitives.c')
-rw-r--r-- | src/bootstrap/primitives.c | 918 |
1 files changed, 0 insertions, 918 deletions
diff --git a/src/bootstrap/primitives.c b/src/bootstrap/primitives.c deleted file mode 100644 index 8b0d407..0000000 --- a/src/bootstrap/primitives.c +++ /dev/null | |||
@@ -1,918 +0,0 @@ | |||
1 | #include "primitives.h" | ||
2 | |||
3 | Object * | ||
4 | eval(Environment *env, Object *root) { | ||
5 | Object* lambda = NULL; | ||
6 | Object* args = NULL; | ||
7 | Object* ret = NULL; | ||
8 | bool recursion_active = false; | ||
9 | eval_start: | ||
10 | switch (root->type) { | ||
11 | case OBJ_TYPE_ERR: | ||
12 | case OBJ_TYPE_PROCEDURE: | ||
13 | case OBJ_TYPE_LAMBDA: | ||
14 | case OBJ_TYPE_FIXNUM: | ||
15 | case OBJ_TYPE_BOOL: | ||
16 | case OBJ_TYPE_NIL: | ||
17 | case OBJ_TYPE_STRING: { | ||
18 | ret = root; | ||
19 | goto eval_success; | ||
20 | } break; | ||
21 | case OBJ_TYPE_SYMBOL: { | ||
22 | Object *val = env_lookup(env, root); | ||
23 | if (val == obj_err) { | ||
24 | error_push((Error){ | ||
25 | .type = ERR_TYPE_RUNTIME, | ||
26 | .value = ERR_SYMBOL_NOT_FOUND, | ||
27 | }); | ||
28 | return obj_err; | ||
29 | } | ||
30 | ret = val; | ||
31 | goto eval_success; | ||
32 | } break; | ||
33 | case OBJ_TYPE_PAIR: { | ||
34 | if (root->car->type == OBJ_TYPE_SYMBOL) { | ||
35 | Object *val = env_lookup(env, root->car); | ||
36 | if (val == obj_err) { | ||
37 | error_push((Error){ | ||
38 | .type = ERR_TYPE_RUNTIME, | ||
39 | .value = ERR_SYMBOL_NOT_FOUND, | ||
40 | }); | ||
41 | return obj_err; | ||
42 | } | ||
43 | |||
44 | // Primitive `if` procedure with TCO. | ||
45 | if (val == proc_if) { | ||
46 | Object *obj = root->cdr; | ||
47 | if (obj == obj_nil || obj->cdr == obj_nil) { | ||
48 | error_push((Error){ | ||
49 | .type = ERR_TYPE_RUNTIME, | ||
50 | .value = ERR_NOT_ENOUGH_ARGS, | ||
51 | }); | ||
52 | return obj_err; | ||
53 | } | ||
54 | Object *car = obj->car; | ||
55 | Object *cdr = obj->cdr; | ||
56 | Object *condition = eval(env, car); | ||
57 | if (condition == obj_err) { | ||
58 | return obj_err; | ||
59 | } | ||
60 | if (condition == obj_true) { | ||
61 | root = cdr->car; | ||
62 | } else if (cdr->cdr != obj_nil) { | ||
63 | root = cdr->cdr->car; | ||
64 | } else { | ||
65 | return obj_nil; | ||
66 | } | ||
67 | goto eval_start; | ||
68 | } | ||
69 | |||
70 | if (val->type == OBJ_TYPE_PROCEDURE) { | ||
71 | ret = val->proc(env, root->cdr); | ||
72 | goto eval_success; | ||
73 | } | ||
74 | if (val->type == OBJ_TYPE_LAMBDA) { | ||
75 | lambda = val; | ||
76 | goto eval_lambda; | ||
77 | } | ||
78 | error_push((Error){ | ||
79 | .type = ERR_TYPE_RUNTIME, | ||
80 | .value = ERR_OBJ_NOT_CALLABLE, | ||
81 | }); | ||
82 | return obj_err; | ||
83 | } | ||
84 | lambda = eval(env, root->car); | ||
85 | if (lambda == obj_err) { | ||
86 | return obj_err; | ||
87 | } | ||
88 | if (lambda->type != OBJ_TYPE_LAMBDA) { | ||
89 | error_push((Error){ | ||
90 | .type = ERR_TYPE_RUNTIME, | ||
91 | .value = ERR_OBJ_NOT_CALLABLE, | ||
92 | }); | ||
93 | return obj_err; | ||
94 | } | ||
95 | |||
96 | eval_lambda: | ||
97 | args = root->cdr; | ||
98 | Object *params = lambda->params; | ||
99 | if (!recursion_active) { | ||
100 | recursion_active = true; | ||
101 | // Protect current stack. | ||
102 | Environment *tmp = env_create(lambda->env); | ||
103 | push_active_env(tmp); | ||
104 | // Extend environment. | ||
105 | env = env_extend(tmp, env); | ||
106 | } | ||
107 | |||
108 | // Create temporary environment to store bindings. | ||
109 | Environment *tmp = env_create(env); | ||
110 | push_active_env(tmp); | ||
111 | |||
112 | // Evaluate arguments in temporary environment. | ||
113 | while (params != obj_nil) { | ||
114 | if (args == obj_nil) { | ||
115 | error_push((Error){ | ||
116 | .type = ERR_TYPE_RUNTIME, | ||
117 | .value = ERR_NOT_ENOUGH_ARGS, | ||
118 | }); | ||
119 | return obj_err; | ||
120 | } | ||
121 | if (args->car == obj_nil) { | ||
122 | error_push((Error){ | ||
123 | .type = ERR_TYPE_RUNTIME, | ||
124 | .value = ERR_NOT_ENOUGH_ARGS, | ||
125 | }); | ||
126 | return obj_err; | ||
127 | } | ||
128 | Object *symbol = params->car; | ||
129 | Object *value = eval(env, args->car); | ||
130 | if (value == obj_err) { | ||
131 | return obj_err; | ||
132 | } | ||
133 | env_add_or_update_current(tmp, symbol, value); | ||
134 | args = args->cdr; | ||
135 | params = params->cdr; | ||
136 | } | ||
137 | if (args != obj_nil) { | ||
138 | error_push((Error){ | ||
139 | .type = ERR_TYPE_RUNTIME, | ||
140 | .value = ERR_TOO_MANY_ARGS, | ||
141 | }); | ||
142 | return obj_err; | ||
143 | } | ||
144 | |||
145 | // Copy temporary environment values to closure environment. | ||
146 | args = root->cdr; | ||
147 | params = lambda->params; | ||
148 | while (params != obj_nil) { | ||
149 | Object *symbol = params->car; | ||
150 | Object *value = env_lookup(tmp, symbol); | ||
151 | env_add_or_update_current(env, symbol, value); | ||
152 | args = args->cdr; | ||
153 | params = params->cdr; | ||
154 | } | ||
155 | |||
156 | // Release the temporary environment protection. | ||
157 | pop_active_env(); | ||
158 | |||
159 | // Run the body of the function. | ||
160 | root = lambda->body; | ||
161 | while (root->cdr != obj_nil) { | ||
162 | if (eval(env, root->car) == obj_err) { | ||
163 | return obj_err; | ||
164 | }; | ||
165 | root = root->cdr; | ||
166 | } | ||
167 | root = root->car; | ||
168 | goto eval_start; | ||
169 | } break; | ||
170 | } | ||
171 | |||
172 | error_push((Error){ | ||
173 | .type = ERR_TYPE_RUNTIME, | ||
174 | .value = ERR_UNKNOWN_OBJ_TYPE, | ||
175 | }); | ||
176 | return obj_err; | ||
177 | |||
178 | eval_success: | ||
179 | if (recursion_active) { | ||
180 | // Remove stack protector. | ||
181 | pop_active_env(); | ||
182 | } | ||
183 | return ret; | ||
184 | } | ||
185 | |||
186 | Object * | ||
187 | proc_quote(Environment *env, Object *obj) { | ||
188 | (void)env; | ||
189 | return obj->car; | ||
190 | } | ||
191 | |||
192 | static inline Object * | ||
193 | extract_car_with_type(Environment *env, Object *obj, ObjectType expected_type) { | ||
194 | if (obj == obj_nil) { | ||
195 | error_push((Error){ | ||
196 | .type = ERR_TYPE_RUNTIME, | ||
197 | .value = ERR_NOT_ENOUGH_ARGS, | ||
198 | }); | ||
199 | return obj_err; | ||
200 | } | ||
201 | Object *car = eval(env, obj->car); | ||
202 | if (car == obj_err) { | ||
203 | return obj_err; | ||
204 | } | ||
205 | if (car->type != expected_type) { | ||
206 | error_push((Error){ | ||
207 | .type = ERR_TYPE_RUNTIME, | ||
208 | .value = ERR_WRONG_ARG_TYPE, | ||
209 | }); | ||
210 | return obj_err; | ||
211 | } | ||
212 | return car; | ||
213 | } | ||
214 | |||
215 | // | ||
216 | // Arithmetic procedures. | ||
217 | // | ||
218 | |||
219 | Object * | ||
220 | proc_sum(Environment *env, Object *obj) { | ||
221 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
222 | obj = obj->cdr; | ||
223 | ssize_t tot = car->fixnum; | ||
224 | while (obj != obj_nil) { | ||
225 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
226 | tot += car->fixnum; | ||
227 | obj = obj->cdr; | ||
228 | } | ||
229 | return make_fixnum(tot); | ||
230 | } | ||
231 | |||
232 | Object * | ||
233 | proc_sub(Environment *env, Object *obj) { | ||
234 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
235 | obj = obj->cdr; | ||
236 | ssize_t tot = car->fixnum; | ||
237 | while (obj != obj_nil) { | ||
238 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
239 | tot -= car->fixnum; | ||
240 | obj = obj->cdr; | ||
241 | } | ||
242 | return make_fixnum(tot); | ||
243 | } | ||
244 | |||
245 | Object * | ||
246 | proc_mul(Environment *env, Object *obj) { | ||
247 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
248 | obj = obj->cdr; | ||
249 | ssize_t tot = car->fixnum; | ||
250 | while (obj != obj_nil) { | ||
251 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
252 | tot *= car->fixnum; | ||
253 | obj = obj->cdr; | ||
254 | } | ||
255 | return make_fixnum(tot); | ||
256 | } | ||
257 | |||
258 | Object * | ||
259 | proc_div(Environment *env, Object *obj) { | ||
260 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
261 | obj = obj->cdr; | ||
262 | ssize_t tot = car->fixnum; | ||
263 | while (obj != obj_nil) { | ||
264 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
265 | if (car->fixnum == 0) { | ||
266 | error_push((Error){ | ||
267 | .type = ERR_TYPE_RUNTIME, | ||
268 | .value = ERR_DIVISION_BY_ZERO, | ||
269 | }); | ||
270 | return obj_err; | ||
271 | } | ||
272 | tot /= car->fixnum; | ||
273 | obj = obj->cdr; | ||
274 | } | ||
275 | return make_fixnum(tot); | ||
276 | } | ||
277 | |||
278 | Object * | ||
279 | proc_mod(Environment *env, Object *obj) { | ||
280 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
281 | obj = obj->cdr; | ||
282 | ssize_t tot = car->fixnum; | ||
283 | while (obj != obj_nil) { | ||
284 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
285 | if (car->fixnum == 0) { | ||
286 | error_push((Error){ | ||
287 | .type = ERR_TYPE_RUNTIME, | ||
288 | .value = ERR_DIVISION_BY_ZERO, | ||
289 | }); | ||
290 | return obj_err; | ||
291 | } | ||
292 | tot %= car->fixnum; | ||
293 | obj = obj->cdr; | ||
294 | } | ||
295 | return make_fixnum(tot); | ||
296 | } | ||
297 | |||
298 | // | ||
299 | // Display/Evaluation procedues. | ||
300 | // | ||
301 | |||
302 | Object * | ||
303 | proc_display(Environment *env, Object *obj) { | ||
304 | display(eval(env, obj->car)); | ||
305 | return obj_nil; | ||
306 | } | ||
307 | |||
308 | Object * | ||
309 | proc_print(Environment *env, Object *obj) { | ||
310 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_STRING); | ||
311 | StringView scanner = (StringView) { | ||
312 | .start = car->string, | ||
313 | .n = array_size(car->string), | ||
314 | }; | ||
315 | while (scanner.n != 0) { | ||
316 | char c = sv_next(&scanner); | ||
317 | if (c == '\\' && sv_peek(&scanner) == 'n') { | ||
318 | putchar('\n'); | ||
319 | sv_next(&scanner); | ||
320 | continue; | ||
321 | } | ||
322 | if (c == '\\' && sv_peek(&scanner) == '"') { | ||
323 | putchar('"'); | ||
324 | sv_next(&scanner); | ||
325 | continue; | ||
326 | } | ||
327 | putchar(c); | ||
328 | } | ||
329 | return obj_nil; | ||
330 | } | ||
331 | |||
332 | Object * | ||
333 | proc_newline(Environment *env, Object *obj) { | ||
334 | printf("\n"); | ||
335 | (void)env; | ||
336 | (void)obj; | ||
337 | return obj_nil; | ||
338 | } | ||
339 | |||
340 | // | ||
341 | // Type info procedures. | ||
342 | // | ||
343 | |||
344 | Object * | ||
345 | proc_is_boolean(Environment *env, Object *obj) { | ||
346 | if (obj == obj_nil) { | ||
347 | error_push((Error){ | ||
348 | .type = ERR_TYPE_RUNTIME, | ||
349 | .value = ERR_NOT_ENOUGH_ARGS, | ||
350 | }); | ||
351 | return obj_err; | ||
352 | } | ||
353 | obj = eval(env, obj->car); | ||
354 | if (obj == obj_err) { | ||
355 | return obj_err; | ||
356 | } | ||
357 | return (obj == obj_true || obj == obj_false) ? obj_true : obj_false; | ||
358 | } | ||
359 | |||
360 | Object * | ||
361 | proc_is_nil(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_nil ? obj_true : obj_false; | ||
374 | } | ||
375 | |||
376 | Object * | ||
377 | proc_is_symbol(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->type == OBJ_TYPE_SYMBOL ? obj_true : obj_false; | ||
390 | } | ||
391 | |||
392 | Object * | ||
393 | proc_is_string(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_STRING ? obj_true : obj_false; | ||
406 | } | ||
407 | |||
408 | Object * | ||
409 | proc_is_fixnum(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_FIXNUM ? obj_true : obj_false; | ||
422 | } | ||
423 | |||
424 | Object * | ||
425 | proc_is_pair(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_PAIR ? obj_true : obj_false; | ||
438 | } | ||
439 | |||
440 | Object * | ||
441 | proc_is_procedure(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_PROCEDURE ? obj_true : obj_false; | ||
454 | } | ||
455 | |||
456 | Object * | ||
457 | proc_is_error(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_true; | ||
468 | } | ||
469 | return 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_cond(Environment *env, Object *obj) { | ||
516 | if (obj == obj_nil) { | ||
517 | error_push((Error){ | ||
518 | .type = ERR_TYPE_RUNTIME, | ||
519 | .value = ERR_NOT_ENOUGH_ARGS, | ||
520 | }); | ||
521 | return obj_err; | ||
522 | } | ||
523 | while (obj != obj_nil) { | ||
524 | Object *clause = obj->car; | ||
525 | if (clause->type != OBJ_TYPE_PAIR || clause->cdr == obj_nil) { | ||
526 | error_push((Error){ | ||
527 | .type = ERR_TYPE_RUNTIME, | ||
528 | .value = ERR_WRONG_ARG_TYPE, | ||
529 | }); | ||
530 | return obj_err; | ||
531 | } | ||
532 | Object *test = clause->car; | ||
533 | Object *value = clause->cdr->car; | ||
534 | Object *result = eval(env, test); | ||
535 | if (result == obj_err) { | ||
536 | return obj_err; | ||
537 | } | ||
538 | if (result == obj_true) { | ||
539 | return eval(env, value); | ||
540 | } | ||
541 | obj = obj->cdr; | ||
542 | } | ||
543 | return obj_nil; | ||
544 | } | ||
545 | |||
546 | Object * | ||
547 | proc_num_less_than(Environment *env, Object *obj) { | ||
548 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
549 | obj = obj->cdr; | ||
550 | ssize_t prev = car->fixnum; | ||
551 | while (obj != obj_nil) { | ||
552 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
553 | if (prev >= car->fixnum) { | ||
554 | return obj_false; | ||
555 | } | ||
556 | prev = car->fixnum; | ||
557 | obj = obj->cdr; | ||
558 | } | ||
559 | return obj_true; | ||
560 | } | ||
561 | |||
562 | Object * | ||
563 | proc_num_greater_than(Environment *env, Object *obj) { | ||
564 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
565 | obj = obj->cdr; | ||
566 | ssize_t prev = car->fixnum; | ||
567 | while (obj != obj_nil) { | ||
568 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
569 | if (prev <= car->fixnum) { | ||
570 | return obj_false; | ||
571 | } | ||
572 | prev = car->fixnum; | ||
573 | obj = obj->cdr; | ||
574 | } | ||
575 | return obj_true; | ||
576 | } | ||
577 | |||
578 | Object * | ||
579 | proc_num_lesseq_than(Environment *env, Object *obj) { | ||
580 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
581 | obj = obj->cdr; | ||
582 | ssize_t prev = car->fixnum; | ||
583 | while (obj != obj_nil) { | ||
584 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
585 | if (prev > car->fixnum) { | ||
586 | return obj_false; | ||
587 | } | ||
588 | prev = car->fixnum; | ||
589 | obj = obj->cdr; | ||
590 | } | ||
591 | return obj_true; | ||
592 | } | ||
593 | |||
594 | Object * | ||
595 | proc_num_greatereq_than(Environment *env, Object *obj) { | ||
596 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
597 | obj = obj->cdr; | ||
598 | ssize_t prev = car->fixnum; | ||
599 | while (obj != obj_nil) { | ||
600 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
601 | if (prev < car->fixnum) { | ||
602 | return obj_false; | ||
603 | } | ||
604 | prev = car->fixnum; | ||
605 | obj = obj->cdr; | ||
606 | } | ||
607 | return obj_true; | ||
608 | } | ||
609 | |||
610 | Object * | ||
611 | proc_num_equal(Environment *env, Object *obj) { | ||
612 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
613 | obj = obj->cdr; | ||
614 | ssize_t prev = car->fixnum; | ||
615 | while (obj != obj_nil) { | ||
616 | car = extract_car_with_type(env, obj, OBJ_TYPE_FIXNUM); | ||
617 | if (prev != car->fixnum) { | ||
618 | return obj_false; | ||
619 | } | ||
620 | prev = car->fixnum; | ||
621 | obj = obj->cdr; | ||
622 | } | ||
623 | return obj_true; | ||
624 | } | ||
625 | |||
626 | // | ||
627 | // List operation procedures. | ||
628 | // | ||
629 | |||
630 | Object * | ||
631 | proc_car(Environment *env, Object *obj) { | ||
632 | if (obj == obj_nil) { | ||
633 | error_push((Error){ | ||
634 | .type = ERR_TYPE_RUNTIME, | ||
635 | .value = ERR_NOT_ENOUGH_ARGS, | ||
636 | }); | ||
637 | return obj_err; | ||
638 | } | ||
639 | obj = eval(env, obj->car); | ||
640 | if (obj == obj_err) { | ||
641 | return obj_err; | ||
642 | } | ||
643 | if (obj->type != OBJ_TYPE_PAIR) { | ||
644 | error_push((Error){ | ||
645 | .type = ERR_TYPE_RUNTIME, | ||
646 | .value = ERR_WRONG_ARG_TYPE, | ||
647 | }); | ||
648 | return obj_err; | ||
649 | } | ||
650 | return obj->car; | ||
651 | } | ||
652 | |||
653 | Object * | ||
654 | proc_cdr(Environment *env, Object *obj) { | ||
655 | if (obj == obj_nil) { | ||
656 | error_push((Error){ | ||
657 | .type = ERR_TYPE_RUNTIME, | ||
658 | .value = ERR_NOT_ENOUGH_ARGS, | ||
659 | }); | ||
660 | return obj_err; | ||
661 | } | ||
662 | obj = eval(env, obj->car); | ||
663 | if (obj == obj_err) { | ||
664 | return obj_err; | ||
665 | } | ||
666 | if (obj->type != OBJ_TYPE_PAIR) { | ||
667 | error_push((Error){ | ||
668 | .type = ERR_TYPE_RUNTIME, | ||
669 | .value = ERR_WRONG_ARG_TYPE, | ||
670 | }); | ||
671 | return obj_err; | ||
672 | } | ||
673 | return obj->cdr; | ||
674 | } | ||
675 | |||
676 | Object * | ||
677 | proc_cons(Environment *env, Object *obj) { | ||
678 | if (obj == obj_nil) { | ||
679 | error_push((Error){ | ||
680 | .type = ERR_TYPE_RUNTIME, | ||
681 | .value = ERR_NOT_ENOUGH_ARGS, | ||
682 | }); | ||
683 | return obj_err; | ||
684 | } | ||
685 | Object *head = make_pair(obj_nil, obj_nil); | ||
686 | push_root(head); | ||
687 | head->car = eval(env, obj->car); | ||
688 | if (head->car == obj_err) { | ||
689 | pop_root(); | ||
690 | return obj_err; | ||
691 | } | ||
692 | head->cdr = eval(env, obj->cdr->car); | ||
693 | if (head->cdr == obj_err) { | ||
694 | pop_root(); | ||
695 | return obj_err; | ||
696 | } | ||
697 | pop_root(); | ||
698 | return head; | ||
699 | } | ||
700 | |||
701 | Object * | ||
702 | proc_list(Environment *env, Object *obj) { | ||
703 | if (obj == obj_nil) { | ||
704 | return obj_nil; | ||
705 | } | ||
706 | |||
707 | Object *head = make_pair(obj_nil, obj_nil); | ||
708 | push_root(head); | ||
709 | Object *tmp = eval(env, obj->car); | ||
710 | if (tmp == obj_err) { | ||
711 | pop_root(); | ||
712 | return obj_err; | ||
713 | } | ||
714 | head->car = tmp; | ||
715 | Object *curr = head; | ||
716 | obj = obj->cdr; | ||
717 | while (obj != obj_nil) { | ||
718 | tmp = eval(env, obj->car); | ||
719 | if (tmp == obj_err) { | ||
720 | pop_root(); | ||
721 | return obj_err; | ||
722 | } | ||
723 | curr->cdr = make_pair(tmp, obj_nil); | ||
724 | curr = curr->cdr; | ||
725 | obj = obj->cdr; | ||
726 | } | ||
727 | pop_root(); | ||
728 | return head; | ||
729 | } | ||
730 | |||
731 | // | ||
732 | // Polymorphic procedures. | ||
733 | // | ||
734 | |||
735 | Object * | ||
736 | proc_equal(Environment *env, Object *obj) { | ||
737 | if (obj == obj_nil || obj->cdr == obj_nil) { | ||
738 | error_push((Error){ | ||
739 | .type = ERR_TYPE_RUNTIME, | ||
740 | .value = ERR_NOT_ENOUGH_ARGS, | ||
741 | }); | ||
742 | return obj_err; | ||
743 | } | ||
744 | Object *a = eval(env, obj->car); | ||
745 | if (a == obj_err) { | ||
746 | return obj_err; | ||
747 | } | ||
748 | Object *b = eval(env, obj->cdr->car); | ||
749 | if (b == obj_err) { | ||
750 | return obj_err; | ||
751 | } | ||
752 | return obj_eq(a, b) ? obj_true : obj_false; | ||
753 | } | ||
754 | |||
755 | // | ||
756 | // Variables and declarations. | ||
757 | // | ||
758 | |||
759 | Object * | ||
760 | proc_define(Environment *env, Object *obj) { | ||
761 | if (obj == obj_nil || obj->cdr == obj_nil) { | ||
762 | error_push((Error){ | ||
763 | .type = ERR_TYPE_RUNTIME, | ||
764 | .value = ERR_NOT_ENOUGH_ARGS, | ||
765 | }); | ||
766 | return obj_err; | ||
767 | } | ||
768 | |||
769 | Object *symbol = obj->car; | ||
770 | if (symbol->type != OBJ_TYPE_SYMBOL) { | ||
771 | error_push((Error){ | ||
772 | .type = ERR_TYPE_RUNTIME, | ||
773 | .value = ERR_WRONG_ARG_TYPE, | ||
774 | }); | ||
775 | return obj_err; | ||
776 | } | ||
777 | |||
778 | Object *value = eval(env, obj->cdr->car); | ||
779 | if (value == obj_err) { | ||
780 | return obj_err; | ||
781 | } | ||
782 | |||
783 | env_add_or_update_current(env, symbol, value); | ||
784 | return obj_nil; | ||
785 | } | ||
786 | |||
787 | Object * | ||
788 | proc_set(Environment *env, Object *obj) { | ||
789 | if (obj == obj_nil || obj->cdr == obj_nil) { | ||
790 | error_push((Error){ | ||
791 | .type = ERR_TYPE_RUNTIME, | ||
792 | .value = ERR_NOT_ENOUGH_ARGS, | ||
793 | }); | ||
794 | return obj_err; | ||
795 | } | ||
796 | |||
797 | Object *symbol = obj->car; | ||
798 | if (symbol->type != OBJ_TYPE_SYMBOL) { | ||
799 | error_push((Error){ | ||
800 | .type = ERR_TYPE_RUNTIME, | ||
801 | .value = ERR_WRONG_ARG_TYPE, | ||
802 | }); | ||
803 | return obj_err; | ||
804 | } | ||
805 | |||
806 | Object *value = eval(env, obj->cdr->car); | ||
807 | if (value == obj_err) { | ||
808 | return obj_err; | ||
809 | } | ||
810 | |||
811 | return env_update(env, symbol, value); | ||
812 | } | ||
813 | |||
814 | Object * | ||
815 | proc_lambda(Environment *env, Object *obj) { | ||
816 | if (obj == obj_nil || obj->cdr == obj_nil) { | ||
817 | error_push((Error){ | ||
818 | .type = ERR_TYPE_RUNTIME, | ||
819 | .value = ERR_NOT_ENOUGH_ARGS, | ||
820 | }); | ||
821 | return obj_err; | ||
822 | } | ||
823 | Object *params = obj->car; | ||
824 | if (params != obj_nil && params->type != OBJ_TYPE_PAIR) { | ||
825 | error_push((Error){ | ||
826 | .type = ERR_TYPE_RUNTIME, | ||
827 | .value = ERR_WRONG_ARG_TYPE, | ||
828 | }); | ||
829 | return obj_err; | ||
830 | } | ||
831 | Object *body = obj->cdr; | ||
832 | Object *fun = alloc_object(OBJ_TYPE_LAMBDA); | ||
833 | fun->params = params; | ||
834 | fun->body = body; | ||
835 | fun->env = env; | ||
836 | return fun; | ||
837 | } | ||
838 | |||
839 | Object * | ||
840 | proc_fun(Environment *env, Object *obj) { | ||
841 | if (obj == obj_nil || obj->cdr == obj_nil || obj->cdr->cdr == obj_nil) { | ||
842 | error_push((Error){ | ||
843 | .type = ERR_TYPE_RUNTIME, | ||
844 | .value = ERR_NOT_ENOUGH_ARGS, | ||
845 | }); | ||
846 | return obj_err; | ||
847 | } | ||
848 | |||
849 | Object *name = obj->car; | ||
850 | if (name->type != OBJ_TYPE_SYMBOL) { | ||
851 | error_push((Error){ | ||
852 | .type = ERR_TYPE_RUNTIME, | ||
853 | .value = ERR_WRONG_ARG_TYPE, | ||
854 | }); | ||
855 | return obj_err; | ||
856 | } | ||
857 | |||
858 | Object *params = obj->cdr->car; | ||
859 | if (params != obj_nil && params->type != OBJ_TYPE_PAIR) { | ||
860 | error_push((Error){ | ||
861 | .type = ERR_TYPE_RUNTIME, | ||
862 | .value = ERR_WRONG_ARG_TYPE, | ||
863 | }); | ||
864 | return obj_err; | ||
865 | } | ||
866 | Object *body = obj->cdr->cdr; | ||
867 | Object *fun = alloc_object(OBJ_TYPE_LAMBDA); | ||
868 | fun->params = params; | ||
869 | fun->body = body; | ||
870 | fun->env = env; | ||
871 | env_add_or_update_current(env, name, fun); | ||
872 | return obj_nil; | ||
873 | } | ||
874 | |||
875 | // | ||
876 | // Evaluation. | ||
877 | // | ||
878 | |||
879 | Object * | ||
880 | proc_eval(Environment *env, Object *obj) { | ||
881 | if (obj == obj_nil) { | ||
882 | error_push((Error){ | ||
883 | .type = ERR_TYPE_RUNTIME, | ||
884 | .value = ERR_NOT_ENOUGH_ARGS, | ||
885 | }); | ||
886 | return obj_err; | ||
887 | } | ||
888 | return eval(env, eval(env, obj->car)); | ||
889 | } | ||
890 | |||
891 | // | ||
892 | // Runtime configuration options. | ||
893 | // | ||
894 | |||
895 | Object * | ||
896 | proc_supress_errors(Environment *env, Object *obj) { | ||
897 | Object *car = extract_car_with_type(env, obj, OBJ_TYPE_BOOL); | ||
898 | if (car == obj_err) { | ||
899 | return obj_err; | ||
900 | } | ||
901 | |||
902 | if (car == obj_true) { | ||
903 | supress_errors = true; | ||
904 | } else if (car == obj_false) { | ||
905 | supress_errors = false; | ||
906 | } | ||
907 | return obj_nil; | ||
908 | } | ||
909 | |||
910 | // TODO: map | ||
911 | // TODO: apply | ||
912 | // TODO: filter | ||
913 | |||
914 | // TODO: fixnum left/right shift, mask, invert | ||
915 | // TODO: add primitives for type transforms: string->symbol, symbol->string, etc | ||
916 | // TODO: implement support for semi-quotes | ||
917 | // TODO: LAMBDA | ||
918 | // TODO: let | ||