diff options
Diffstat (limited to 'src/bootstrap/primitives.c')
-rw-r--r-- | src/bootstrap/primitives.c | 900 |
1 files changed, 900 insertions, 0 deletions
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). | ||