aboutsummaryrefslogtreecommitdiffstats
path: root/src/bootstrap/primitives.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/bootstrap/primitives.c')
-rw-r--r--src/bootstrap/primitives.c710
1 files changed, 0 insertions, 710 deletions
diff --git a/src/bootstrap/primitives.c b/src/bootstrap/primitives.c
deleted file mode 100644
index 3c03b99..0000000
--- a/src/bootstrap/primitives.c
+++ /dev/null
@@ -1,710 +0,0 @@
1bool display(Object *root);
2
3void
4display_pair(Object *root) {
5 display(root->car);
6 if (root->cdr->type == OBJ_TYPE_PAIR) {
7 printf(" ");
8 display_pair(root->cdr);
9 } else if (root->cdr == obj_nil) {
10 return;
11 } else {
12 printf(" . ");
13 display(root->cdr);
14 }
15}
16
17bool
18display(Object *root) {
19 if (root == NULL) {
20 return false;
21 }
22
23 switch (root->type) {
24 case OBJ_TYPE_FIXNUM: {
25 printf("%zd", root->fixnum);
26 } break;
27 case OBJ_TYPE_BOOL: {
28 if (root->boolean) {
29 printf("true");
30 } else {
31 printf("false");
32 }
33 } break;
34 case OBJ_TYPE_NIL: {
35 printf("()");
36 } break;
37 case OBJ_TYPE_STRING: {
38 printf("\"%.*s\"", (int)root->string_n, root->string);
39 } break;
40 case OBJ_TYPE_SYMBOL: {
41 printf(":%.*s", (int)root->symbol_n, root->symbol);
42 } break;
43 case OBJ_TYPE_PAIR: {
44 printf("(");
45 display_pair(root);
46 printf(")");
47 } break;
48 case OBJ_TYPE_PROCEDURE: {
49 printf("#{procedure}");
50 } break;
51 }
52 return true;
53}
54
55Object *
56eval(Object *root) {
57 switch (root->type) {
58 case OBJ_TYPE_FIXNUM:
59 case OBJ_TYPE_BOOL:
60 case OBJ_TYPE_NIL:
61 case OBJ_TYPE_STRING: {
62 return root;
63 } break;
64 case OBJ_TYPE_SYMBOL: {
65 Object *value = env_find_symbol(root);
66 if (value == NULL) {
67 printf("error: symbol not found: `");
68 display(root);
69 printf("`\n");
70 return obj_nil;
71 }
72 return value;
73 } break;
74 case OBJ_TYPE_PAIR: {
75 if (root->car->type == OBJ_TYPE_SYMBOL) {
76 Object *value = env_find_symbol(root->car);
77 if (value == NULL) {
78 printf("error: symbol not found: `");
79 display(root->car);
80 printf("`\n");
81 return obj_nil;
82 }
83 if (value->type == OBJ_TYPE_PROCEDURE) {
84 return value->proc(root->cdr);
85 }
86 }
87 } break;
88 default: {
89 printf("error: can't eval type %d.\n", root->type);
90 } break;
91 }
92 return obj_nil;
93}
94
95//
96// Arithmetic procedures.
97//
98
99Object *
100proc_add(Object *args) {
101 // Extract first parameter.
102 Object *car = eval(args->car);
103 if (car == NULL) {
104 fprintf(stderr, "error: not enough arguments\n");
105 return obj_nil;
106 }
107 if (car->type != OBJ_TYPE_FIXNUM) {
108 fprintf(stderr, "addition not supported for type %d\n", car->type);
109 return obj_nil;
110 }
111 args = args->cdr;
112 ssize_t tot = car->fixnum;
113
114 while (args->type == OBJ_TYPE_PAIR) {
115 Object *car = eval(args->car);
116 if (car == NULL) {
117 car = obj_nil;
118 }
119 if (car->type != OBJ_TYPE_FIXNUM) {
120 fprintf(stderr, "addition not supported for type %d\n", car->type);
121 return obj_nil;
122 }
123 tot += car->fixnum;
124 args = args->cdr;
125 }
126 return make_fixnum(tot);
127}
128
129Object *
130proc_sub(Object *args) {
131 // Extract first parameter.
132 Object *car = eval(args->car);
133 if (car == NULL) {
134 fprintf(stderr, "error: not enough arguments\n");
135 return obj_nil;
136 }
137 if (car->type != OBJ_TYPE_FIXNUM) {
138 fprintf(stderr, "error: sub not supported for type %d\n", car->type);
139 return obj_nil;
140 }
141 args = args->cdr;
142 ssize_t tot = car->fixnum;
143
144 while (args->type == OBJ_TYPE_PAIR) {
145 car = eval(args->car);
146 if (car == NULL) {
147 car = obj_nil;
148 }
149 if (car->type != OBJ_TYPE_FIXNUM) {
150 fprintf(stderr, "error: sub not supported for type %d\n", car->type);
151 return obj_nil;
152 }
153 tot -= car->fixnum;
154 args = args->cdr;
155 }
156 return make_fixnum(tot);
157}
158
159Object *
160proc_mul(Object *args) {
161 // Extract first parameter.
162 Object *car = eval(args->car);
163 if (car == NULL) {
164 fprintf(stderr, "error: not enough arguments\n");
165 return obj_nil;
166 }
167 if (car->type != OBJ_TYPE_FIXNUM) {
168 fprintf(stderr, "error: mult not supported for type %d\n", car->type);
169 return obj_nil;
170 }
171 args = args->cdr;
172 ssize_t tot = car->fixnum;
173
174 while (args->type == OBJ_TYPE_PAIR) {
175 Object *car = eval(args->car);
176 if (car == NULL) {
177 car = obj_nil;
178 }
179 if (car->type != OBJ_TYPE_FIXNUM) {
180 fprintf(stderr, "error: mult not supported for type %d\n", car->type);
181 return obj_nil;
182 }
183 tot *= car->fixnum;
184 args = args->cdr;
185 }
186 return make_fixnum(tot);
187}
188
189Object *
190proc_div(Object *args) {
191 // Extract first parameter.
192 Object *car = eval(args->car);
193 if (car == NULL) {
194 fprintf(stderr, "error: not enough arguments\n");
195 return obj_nil;
196 }
197 args = args->cdr;
198 ssize_t tot = car->fixnum;
199
200 while (args->type == OBJ_TYPE_PAIR) {
201 Object *car = eval(args->car);
202 if (car == NULL) {
203 car = obj_nil;
204 }
205 if (car->type != OBJ_TYPE_FIXNUM) {
206 fprintf(stderr, "error: div not supported for type %d\n", car->type);
207 return obj_nil;
208 }
209 if (car->fixnum == 0) {
210 fprintf(stderr, "error: division by zero\n");
211 return obj_nil;
212 }
213 tot /= car->fixnum;
214 args = args->cdr;
215 }
216 return make_fixnum(tot);
217}
218
219Object *
220proc_mod(Object *args) {
221 // Extract first parameter.
222 Object *car = eval(args->car);
223 if (car == NULL) {
224 fprintf(stderr, "error: not enough arguments\n");
225 return obj_nil;
226 }
227 args = args->cdr;
228 ssize_t tot = car->fixnum;
229
230 while (args->type == OBJ_TYPE_PAIR) {
231 Object *car = eval(args->car);
232 if (car == NULL) {
233 car = obj_nil;
234 }
235 if (car->type != OBJ_TYPE_FIXNUM) {
236 fprintf(stderr, "error: div not supported for type %d\n", car->type);
237 return obj_nil;
238 }
239 if (car->fixnum == 0) {
240 fprintf(stderr, "error: division by zero\n");
241 return obj_nil;
242 }
243 tot %= car->fixnum;
244 args = args->cdr;
245 }
246 return make_fixnum(tot);
247}
248
249//
250// Display/Evaluation procedues.
251//
252
253Object *
254proc_display(Object *args) {
255 if (args == NULL) {
256 return obj_nil;
257 }
258 if (args->type == OBJ_TYPE_PAIR) {
259 display(eval(args->car));
260 }
261 return obj_nil;
262}
263
264Object *
265proc_print(Object *args) {
266 if (args == NULL) {
267 return NULL;
268 }
269 if (args->type == OBJ_TYPE_PAIR) {
270 Object *obj = args->car;
271 if (obj->type == OBJ_TYPE_STRING) {
272 StringView scanner = (StringView) {
273 .start = obj->string,
274 .n = obj->string_n,
275 };
276 while (scanner.n != 0) {
277 char c = sv_next(&scanner);
278 if (c == '\\' && sv_peek(&scanner) == 'n') {
279 putchar('\n');
280 sv_next(&scanner);
281 continue;
282 }
283 if (c == '\\' && sv_peek(&scanner) == '"') {
284 putchar('"');
285 sv_next(&scanner);
286 continue;
287 }
288 putchar(c);
289 }
290 } else {
291 fprintf(stderr, "error: print requires a string argument\n");
292 }
293 }
294 return NULL;
295}
296
297//
298// Type info procedures.
299//
300
301Object *
302proc_is_boolean(Object *args) {
303 if (args->type != OBJ_TYPE_PAIR) {
304 fprintf(stderr, "error: wrong number of arguments.\n");
305 return NULL;
306 }
307 Object *obj = eval(args->car);
308 return (obj == obj_true || obj == obj_false) ? obj_true : obj_false;
309}
310
311Object *
312proc_is_null(Object *args) {
313 if (args->type != OBJ_TYPE_PAIR) {
314 fprintf(stderr, "error: wrong number of arguments.\n");
315 return NULL;
316 }
317 Object *obj = eval(args->car);
318 return obj == obj_nil ? obj_true : obj_false;
319}
320
321Object *
322proc_is_symbol(Object *args) {
323 if (args->type != OBJ_TYPE_PAIR) {
324 fprintf(stderr, "error: wrong number of arguments.\n");
325 return NULL;
326 }
327 Object *obj = eval(args->car);
328 return obj->type == OBJ_TYPE_SYMBOL ? obj_true : obj_false;
329}
330
331Object *
332proc_is_string(Object *args) {
333 if (args->type != OBJ_TYPE_PAIR) {
334 fprintf(stderr, "error: wrong number of arguments.\n");
335 return NULL;
336 }
337 Object *obj = eval(args->car);
338 return obj->type == OBJ_TYPE_STRING ? obj_true : obj_false;
339}
340
341Object *
342proc_is_fixnum(Object *args) {
343 if (args->type != OBJ_TYPE_PAIR) {
344 fprintf(stderr, "error: wrong number of arguments.\n");
345 return NULL;
346 }
347 Object *obj = eval(args->car);
348 return obj->type == OBJ_TYPE_FIXNUM ? obj_true : obj_false;
349}
350
351Object *
352proc_is_pair(Object *args) {
353 if (args->type != OBJ_TYPE_PAIR) {
354 fprintf(stderr, "error: wrong number of arguments.\n");
355 return NULL;
356 }
357 Object *obj = eval(args->car);
358 return obj->type == OBJ_TYPE_PAIR ? obj_true : obj_false;
359}
360
361Object *
362proc_is_procedure(Object *args) {
363 if (args->type != OBJ_TYPE_PAIR) {
364 fprintf(stderr, "error: wrong number of arguments.\n");
365 return NULL;
366 }
367 Object *obj = eval(args->car);
368 return obj->type == OBJ_TYPE_PROCEDURE ? obj_true : obj_false;
369}
370
371//
372// Boolean/conditional procedures.
373//
374
375Object *
376proc_not(Object *args) {
377 if (args->type == OBJ_TYPE_PAIR) {
378 return eval(args->car) == obj_false ? obj_true : obj_false;
379 }
380 return eval(args) == obj_false ? obj_true : obj_false;
381}
382
383Object *
384proc_and(Object *args) {
385 while (args != NULL && args != obj_nil) {
386 Object *obj = args->car;
387 if (args->car->type == OBJ_TYPE_PAIR) {
388 obj = eval(args->car);
389 }
390 if (proc_not(obj) == obj_true) {
391 return obj_false;
392 }
393 args = args->cdr;
394 }
395 return obj_true;
396}
397
398Object *
399proc_or(Object *args) {
400 if (args->type != OBJ_TYPE_PAIR) {
401 return obj_false;
402 }
403
404 while (args != NULL && args != obj_nil) {
405 Object *obj = args->car;
406 if (args->car->type == OBJ_TYPE_PAIR) {
407 obj = eval(args->car);
408 }
409 if (proc_not(obj) == obj_false) {
410 return obj_true;
411 }
412 args = args->cdr;
413 }
414 return obj_false;
415}
416
417Object *
418proc_if(Object *args) {
419 if (args->type != OBJ_TYPE_PAIR || args->cdr->type != OBJ_TYPE_PAIR) {
420 fprintf(stderr, "error: wrong number of arguments.\n");
421 return NULL;
422 }
423
424 Object *condition = eval(args->car);
425 if (condition == obj_true) {
426 Object *ret = eval(args->cdr->car);
427 return ret;
428 }
429 if (args->cdr->cdr != obj_nil) {
430 Object *ret = eval(args->cdr->cdr->car);
431 return ret;
432 }
433
434 return obj_nil;
435}
436
437Object *
438proc_cond(Object *args) {
439 if (args->type != OBJ_TYPE_PAIR) {
440 fprintf(stderr, "error: wrong number of arguments.\n");
441 return NULL;
442 }
443
444 if (args->car->type != OBJ_TYPE_PAIR) {
445 fprintf(stderr, "error: wrong argument type.\n");
446 return NULL;
447 }
448
449 while (args != obj_nil) {
450 Object *clause = args->car;
451 if (eval(clause->car) == obj_true) {
452 return eval(clause->cdr->car);
453 }
454 args = args->cdr;
455 }
456
457 return obj_nil;
458}
459
460Object *
461proc_num_less_than(Object *args) {
462 if (args == obj_nil) {
463 fprintf(stderr, "error: wrong number of arguments type.\n");
464 return NULL;
465 }
466
467 Object *obj = eval(args->car);
468 if (obj->type != OBJ_TYPE_FIXNUM) {
469 fprintf(stderr, "error: wrong argument type.\n");
470 return NULL;
471 }
472 ssize_t prev = obj->fixnum;
473 args = args->cdr;
474
475 if (args == obj_nil) {
476 fprintf(stderr, "error: wrong number of arguments type.\n");
477 return NULL;
478 }
479 while (args != obj_nil) {
480 Object *obj = eval(args->car);
481 if (obj->type != OBJ_TYPE_FIXNUM) {
482 fprintf(stderr, "error: wrong argument type.\n");
483 return NULL;
484 }
485 if (prev >= obj->fixnum) {
486 return obj_false;
487 }
488 prev = obj->fixnum;
489 args = args->cdr;
490 }
491 return obj_true;
492}
493
494Object *
495proc_num_greater_than(Object *args) {
496 if (args == obj_nil) {
497 fprintf(stderr, "error: wrong number of arguments type.\n");
498 return NULL;
499 }
500
501 Object *obj = eval(args->car);
502 if (obj->type != OBJ_TYPE_FIXNUM) {
503 fprintf(stderr, "error: wrong argument type.\n");
504 return NULL;
505 }
506 ssize_t prev = obj->fixnum;
507 args = args->cdr;
508
509 if (args == obj_nil) {
510 fprintf(stderr, "error: wrong number of arguments type.\n");
511 return NULL;
512 }
513 while (args != obj_nil) {
514 Object *obj = eval(args->car);
515 if (obj->type != OBJ_TYPE_FIXNUM) {
516 fprintf(stderr, "error: wrong argument type.\n");
517 return NULL;
518 }
519 if (prev <= obj->fixnum) {
520 return obj_false;
521 }
522 prev = obj->fixnum;
523 args = args->cdr;
524 }
525 return obj_true;
526}
527
528Object *
529proc_num_lesseq_than(Object *args) {
530 if (args == obj_nil) {
531 fprintf(stderr, "error: wrong number of arguments type.\n");
532 return NULL;
533 }
534
535 Object *obj = eval(args->car);
536 if (obj->type != OBJ_TYPE_FIXNUM) {
537 fprintf(stderr, "error: wrong argument type.\n");
538 return NULL;
539 }
540 ssize_t prev = obj->fixnum;
541 args = args->cdr;
542
543 if (args == obj_nil) {
544 fprintf(stderr, "error: wrong number of arguments type.\n");
545 return NULL;
546 }
547 while (args != obj_nil) {
548 Object *obj = eval(args->car);
549 if (obj->type != OBJ_TYPE_FIXNUM) {
550 fprintf(stderr, "error: wrong argument type.\n");
551 return NULL;
552 }
553 if (prev > obj->fixnum) {
554 return obj_false;
555 }
556 prev = obj->fixnum;
557 args = args->cdr;
558 }
559 return obj_true;
560}
561
562Object *
563proc_num_greatereq_than(Object *args) {
564 if (args == obj_nil) {
565 fprintf(stderr, "error: wrong number of arguments type.\n");
566 return NULL;
567 }
568
569 Object *obj = eval(args->car);
570 if (obj->type != OBJ_TYPE_FIXNUM) {
571 fprintf(stderr, "error: wrong argument type.\n");
572 return NULL;
573 }
574 ssize_t prev = obj->fixnum;
575 args = args->cdr;
576
577 if (args == obj_nil) {
578 fprintf(stderr, "error: wrong number of arguments type.\n");
579 return NULL;
580 }
581 while (args != obj_nil) {
582 Object *obj = eval(args->car);
583 if (obj->type != OBJ_TYPE_FIXNUM) {
584 fprintf(stderr, "error: wrong argument type.\n");
585 return NULL;
586 }
587 if (prev < obj->fixnum) {
588 return obj_false;
589 }
590 prev = obj->fixnum;
591 args = args->cdr;
592 }
593 return obj_true;
594}
595
596Object *
597proc_num_equal(Object *args) {
598 if (args == obj_nil) {
599 fprintf(stderr, "error: wrong number of arguments type.\n");
600 return NULL;
601 }
602
603 Object *obj = eval(args->car);
604 if (obj->type != OBJ_TYPE_FIXNUM) {
605 fprintf(stderr, "error: wrong argument type.\n");
606 return NULL;
607 }
608 ssize_t prev = obj->fixnum;
609 args = args->cdr;
610
611 if (args == obj_nil) {
612 fprintf(stderr, "error: wrong number of arguments type.\n");
613 return NULL;
614 }
615 while (args != obj_nil) {
616 Object *obj = eval(args->car);
617 if (obj->type != OBJ_TYPE_FIXNUM) {
618 fprintf(stderr, "error: wrong argument type.\n");
619 return NULL;
620 }
621 if (prev != obj->fixnum) {
622 return obj_false;
623 }
624 prev = obj->fixnum;
625 args = args->cdr;
626 }
627 return obj_true;
628}
629
630//
631// List operation procedures.
632//
633
634Object *
635proc_car(Object *args) {
636 if (args == obj_nil) {
637 fprintf(stderr, "error: not enough arguments\n");
638 return obj_nil;
639 }
640 Object *obj = eval(args->car);
641 if (obj->type != OBJ_TYPE_PAIR) {
642 fprintf(stderr, "error: wrong argument type\n");
643 return obj_nil;
644 }
645 return obj->car;
646}
647
648Object *
649proc_cdr(Object *args) {
650 if (args == obj_nil) {
651 fprintf(stderr, "error: not enough arguments\n");
652 return obj_nil;
653 }
654 Object *obj = eval(args->car);
655 if (obj->type != OBJ_TYPE_PAIR) {
656 fprintf(stderr, "error: wrong argument type\n");
657 return obj_nil;
658 }
659 return obj->cdr;
660}
661
662Object *
663proc_cons(Object *args) {
664 if (args == obj_nil || args->cdr == obj_nil) {
665 fprintf(stderr, "error: not enough arguments\n");
666 return obj_nil;
667 }
668 Object *a = eval(args->car);
669 Object *b = eval(args->cdr->car);
670 return make_pair(a, b);
671}
672
673Object *
674proc_list(Object *args) {
675 if (args == obj_nil) {
676 return obj_nil;
677 }
678 Object *head = make_pair(eval(args->car), obj_nil);
679 Object *curr = head;
680 args = args->cdr;
681 while (args != obj_nil) {
682 curr->cdr = make_pair(eval(args->car), obj_nil);
683 curr = curr->cdr;
684 args = args->cdr;
685 }
686 return head;
687}
688
689//
690// Polymorphic procedures.
691//
692
693Object *
694proc_equal(Object *args) {
695 // TODO: stub
696 (void) args;
697 return NULL;
698}
699
700// TODO: fixnum left/right shift, mask, invert
701// TODO: implement and test missing procedures
702// TODO: add primitives for type transforms: string->symbol, symbol->string, etc
703// TODO: properly implement nested environments
704// TODO: implement support for quotes and semi-quotes
705// TODO: LAMBDA
706// TODO: let
707// TODO: better error handling?
708// TODO: Revise all instances where we are returning an object, since currently
709// we may be returning a pointer to an object instead of a new one. Check also
710// on eval function and everytime we do make_xxx(obj).
generated by cgit v1.2.1 (git 2.18.0) at 2024-05-17 05:35:16 +0000