Line data Source code
1 : #include <assert.h>
2 : #include <stdbool.h>
3 : #include <stdio.h>
4 : #include <stdlib.h>
5 : #include <string.h>
6 :
7 : #include "libstephen/lisp.h"
8 : #include "libstephen/ht.h"
9 :
10 : // General functions for types.
11 :
12 0 : static lisp_value *eval_error(lisp_runtime *rt, lisp_scope *s, lisp_value *v)
13 : {
14 : (void)s;
15 : (void)v;
16 0 : return (lisp_value*) lisp_error_new(rt, "cannot evaluate this object");
17 : }
18 :
19 0 : static lisp_value *eval_same(lisp_runtime *rt, lisp_scope *s, lisp_value *v)
20 : {
21 : (void)rt;
22 : (void)s;
23 0 : return v;
24 : }
25 :
26 0 : static lisp_value *call_error(lisp_runtime *rt, lisp_scope *s, lisp_value *c,
27 : lisp_value *v)
28 : {
29 : (void)s;
30 : (void)c;
31 : (void)v;
32 0 : return (lisp_value*) lisp_error_new(rt, "not callable!");
33 : }
34 :
35 0 : static lisp_value *call_same(lisp_runtime *rt, lisp_scope *s, lisp_value *c,
36 : lisp_value *v)
37 : {
38 : (void)rt;
39 : (void)s;
40 : (void)v;
41 0 : return c;
42 : }
43 :
44 0 : static DATA next_nop(struct smb_iter *iter, smb_status *status)
45 : {
46 : (void)iter;
47 : (void)status;
48 0 : return PTR(NULL);
49 : }
50 :
51 0 : static bool has_next_false(struct smb_iter *iter)
52 : {
53 : (void)iter;
54 0 : return false;
55 : }
56 :
57 0 : static bool has_next_index_lt_state(struct smb_iter *iter)
58 : {
59 0 : return iter->index < iter->state.data_llint;
60 : }
61 :
62 0 : static void destroy_nop(struct smb_iter *iter)
63 : {
64 : (void)iter;
65 0 : }
66 :
67 0 : static void delete_filler(struct smb_iter *iter)
68 : {
69 0 : iter->destroy(iter);
70 0 : free(iter);
71 0 : }
72 :
73 0 : static smb_iter expand_nothing(lisp_value *v)
74 : {
75 0 : smb_iter it = {
76 : .ds=v,
77 : .state=LLINT(0),
78 : .index=0,
79 : .next=next_nop,
80 : .has_next=has_next_false,
81 : .destroy=destroy_nop,
82 : .delete=delete_filler,
83 : };
84 0 : return it;
85 : }
86 :
87 : // type
88 :
89 : static void type_print(FILE *f, lisp_value *v);
90 : static lisp_value *type_new(void);
91 :
92 : static lisp_type type_type_obj = {
93 : .type=&type_type_obj,
94 : .name="type",
95 : .print=type_print,
96 : .new=type_new,
97 : .eval=eval_error,
98 : .free=free,
99 : .call=call_error,
100 : .expand=expand_nothing,
101 : };
102 : lisp_type *type_type = &type_type_obj;
103 :
104 0 : static void type_print(FILE *f, lisp_value *v)
105 : {
106 0 : lisp_type *value = (lisp_type*) v;
107 0 : fprintf(f, "%s", value->name);
108 0 : }
109 :
110 0 : static lisp_value *type_new(void)
111 : {
112 0 : lisp_type *type = malloc(sizeof(lisp_type));
113 0 : return (lisp_value*)type;
114 : }
115 :
116 : // scope
117 :
118 : static void scope_print(FILE *f, lisp_value*v);
119 : static lisp_value *scope_new(void);
120 : static void scope_free(void *v);
121 : static smb_iter scope_expand(lisp_value *);
122 :
123 : static lisp_type type_scope_obj = {
124 : .type=&type_type_obj,
125 : .name="scope",
126 : .print=scope_print,
127 : .new=scope_new,
128 : .eval=eval_error,
129 : .free=scope_free,
130 : .call=call_error,
131 : .expand=scope_expand,
132 : };
133 : lisp_type *type_scope = &type_scope_obj;
134 :
135 0 : static unsigned int symbol_hash(DATA symbol)
136 : {
137 0 : lisp_symbol *sym = symbol.data_ptr;
138 0 : return ht_string_hash(PTR(sym->sym));
139 : }
140 :
141 0 : static int symbol_compare(DATA d1, DATA d2)
142 : {
143 0 : lisp_symbol *sym1 = d1.data_ptr;
144 0 : lisp_symbol *sym2 = d2.data_ptr;
145 0 : return data_compare_string(PTR(sym1->sym), PTR(sym2->sym));;
146 : }
147 :
148 0 : static lisp_value *scope_new(void)
149 : {
150 0 : lisp_scope *scope = malloc(sizeof(lisp_scope));
151 0 : scope->up = NULL;
152 0 : ht_init(&scope->scope, symbol_hash, symbol_compare);
153 0 : return (lisp_value*)scope;
154 : }
155 :
156 0 : static void scope_free(void *v)
157 : {
158 0 : lisp_scope *scope = (lisp_scope*) v;
159 0 : ht_destroy(&scope->scope);
160 0 : free(scope);
161 0 : }
162 :
163 0 : static void scope_print(FILE *f, lisp_value *v)
164 : {
165 0 : lisp_scope *scope = (lisp_scope*) v;
166 0 : smb_iter it = ht_get_iter(&scope->scope);
167 0 : fprintf(f, "(scope:");
168 0 : while (it.has_next(&it)) {
169 0 : smb_status status = SMB_SUCCESS;
170 0 : lisp_value *key = it.next(&it, &status).data_ptr;
171 0 : assert(status == SMB_SUCCESS);
172 0 : lisp_value *value = ht_get(&scope->scope, PTR(key), &status).data_ptr;
173 0 : assert(status == SMB_SUCCESS);
174 0 : fprintf(f, " ");
175 0 : lisp_print(f, key);
176 0 : fprintf(f, ": ");
177 0 : lisp_print(f, value);
178 : }
179 0 : fprintf(f, ")");
180 0 : }
181 :
182 0 : static DATA scope_expand_next(struct smb_iter *it, smb_status *status)
183 : {
184 0 : smb_iter *htiter = it->ds;
185 0 : if (it->index == 0) {
186 0 : it->index++;
187 0 : return it->state; // contains the upper scope
188 0 : } else if (it->index % 2 == 1) {
189 : // odd index means grab a new key
190 0 : it->state = htiter->next(htiter, status);
191 0 : it->index++;
192 0 : return it->state; // contains the symbol that is key
193 : } else {
194 0 : it->index++;
195 0 : return ht_get(htiter->ds, it->state, status);
196 : }
197 : }
198 :
199 0 : static bool scope_expand_has_next(struct smb_iter *it)
200 : {
201 0 : smb_iter *htiter = it->ds;
202 0 : if (it->index % 2 == 0) {
203 0 : return true;
204 : } else {
205 0 : return htiter->has_next(htiter);
206 : }
207 : }
208 :
209 0 : static void scope_expand_destroy(struct smb_iter *it)
210 : {
211 0 : smb_iter *htiter = it->ds;
212 0 : htiter->delete(htiter);
213 0 : }
214 :
215 0 : static smb_iter scope_expand(lisp_value *v)
216 : {
217 0 : lisp_scope *scope = (lisp_scope*) v;
218 0 : smb_iter *htiter = malloc(sizeof(smb_iter));
219 0 : *htiter = ht_get_iter(&scope->scope);
220 0 : smb_iter it = {
221 : .ds=htiter,
222 : .state=PTR(scope),
223 : .index=0,
224 : .next=scope_expand_next,
225 : .has_next=scope_expand_has_next,
226 : .destroy=scope_expand_destroy,
227 : .delete=delete_filler,
228 : };
229 0 : return it;
230 : }
231 :
232 : // list
233 :
234 : static void list_print(FILE *f, lisp_value *v);
235 : static lisp_value *list_new(void);
236 : static lisp_value *list_eval(lisp_runtime*, lisp_scope*, lisp_value*);
237 : static smb_iter list_expand(lisp_value*);
238 :
239 : static lisp_type type_list_obj = {
240 : .type=&type_type_obj,
241 : .name="list",
242 : .print=list_print,
243 : .new=list_new,
244 : .eval=list_eval,
245 : .free=free,
246 : .call=call_error,
247 : .expand=list_expand,
248 : };
249 : lisp_type *type_list = &type_list_obj;
250 :
251 0 : static lisp_value *list_eval(lisp_runtime *rt, lisp_scope *scope, lisp_value *v)
252 : {
253 0 : lisp_list *list = (lisp_list*) v;
254 0 : if (list->right->type != type_list) {
255 0 : return (lisp_value*) lisp_error_new(rt, "bad function call syntax");
256 : }
257 0 : lisp_value *callable = lisp_eval(rt, scope, list->left);
258 0 : lisp_value *rv = lisp_call(rt, scope, callable, list->right);
259 0 : return rv;
260 : }
261 :
262 0 : static void list_print_internal(FILE *f, lisp_list *list)
263 : {
264 0 : if (lisp_nil_p((lisp_value*)list)) {
265 0 : return;
266 : }
267 0 : lisp_print(f, list->left);
268 0 : if (list->right->type != type_list) {
269 0 : fprintf(f, " . ");
270 0 : lisp_print(f, list->right);
271 0 : return;
272 0 : } else if (!lisp_nil_p((lisp_value*)list)) {
273 0 : fprintf(f, " ");
274 0 : list_print_internal(f, (lisp_list*)list->right);
275 : }
276 : }
277 :
278 0 : static void list_print(FILE *f, lisp_value *v)
279 : {
280 0 : fprintf(f, "(");
281 0 : list_print_internal(f, (lisp_list*)v);
282 0 : fprintf(f, ")");
283 0 : }
284 :
285 0 : static lisp_value *list_new(void)
286 : {
287 0 : lisp_list *list = malloc(sizeof(lisp_list));
288 0 : list->left = NULL;
289 0 : list->right = NULL;
290 0 : return (lisp_value*) list;
291 : }
292 :
293 0 : bool lisp_nil_p(lisp_value *l)
294 : {
295 0 : return (l->type == type_list) &&
296 0 : (((lisp_list*)l)->right == NULL) &&
297 0 : (((lisp_list*)l)->left == NULL);
298 : }
299 :
300 0 : static DATA list_expand_next(smb_iter *it, smb_status *status)
301 : {
302 : (void)status;
303 0 : lisp_list *l = (lisp_list*) it->ds;
304 0 : it->index++;
305 0 : switch (it->index) {
306 : case 1:
307 0 : return PTR(l->left);
308 : case 2:
309 0 : return PTR(l->right);
310 : default:
311 0 : return PTR(NULL);
312 : }
313 : }
314 :
315 0 : static bool list_has_next(smb_iter *it)
316 : {
317 0 : lisp_value *l = (lisp_value*)it->ds;
318 0 : if (lisp_nil_p(l)) {
319 0 : return false;
320 : } else {
321 0 : return it->index < it->state.data_llint;
322 : }
323 : }
324 :
325 0 : static smb_iter list_expand(lisp_value *v)
326 : {
327 0 : smb_iter it = {
328 : .ds=v,
329 : .state=LLINT(2),
330 : .index=0,
331 : .next=list_expand_next,
332 : .has_next=list_has_next,
333 : .destroy=destroy_nop,
334 : .delete=delete_filler,
335 : };
336 0 : return it;
337 : }
338 :
339 : // symbol
340 :
341 : static void symbol_print(FILE *f, lisp_value *v);
342 : static lisp_value *symbol_new(void);
343 : static lisp_value *symbol_eval(lisp_runtime*, lisp_scope*, lisp_value*);
344 : static void symbol_free(void *v);
345 : static smb_iter symbol_expand(lisp_value*v);
346 :
347 : static lisp_type type_symbol_obj = {
348 : .type=&type_type_obj,
349 : .name="symbol",
350 : .print=symbol_print,
351 : .new=symbol_new,
352 : .eval=symbol_eval,
353 : .free=symbol_free,
354 : .call=call_error,
355 : .expand=expand_nothing,
356 : };
357 : lisp_type *type_symbol = &type_symbol_obj;
358 :
359 0 : static void symbol_print(FILE *f, lisp_value *v)
360 : {
361 0 : lisp_symbol *symbol = (lisp_symbol*) v;
362 0 : fprintf(f, "%s", symbol->sym);
363 0 : }
364 :
365 0 : static lisp_value *symbol_new(void)
366 : {
367 0 : lisp_symbol *symbol = malloc(sizeof(lisp_symbol));
368 0 : symbol->sym = NULL;
369 0 : return (lisp_value*)symbol;
370 : }
371 :
372 0 : static lisp_value *symbol_eval(lisp_runtime *rt, lisp_scope *scope,
373 : lisp_value *value)
374 : {
375 : (void)rt;
376 0 : lisp_symbol *symbol = (lisp_symbol*) value;
377 0 : return lisp_scope_lookup(rt, scope, symbol);
378 : }
379 :
380 0 : static void symbol_free(void *v)
381 : {
382 0 : lisp_symbol *symbol = (lisp_symbol*) v;
383 0 : free(symbol->sym);
384 0 : free(symbol);
385 0 : }
386 :
387 : // error
388 :
389 : static void error_print(FILE *f, lisp_value *v);
390 : static lisp_value *error_new(void);
391 : static void error_free(void *v);
392 :
393 : static lisp_type type_error_obj = {
394 : .type=&type_type_obj,
395 : .name="error",
396 : .print=error_print,
397 : .new=error_new,
398 : .eval=eval_same,
399 : .free=error_free,
400 : .call=call_same,
401 : .expand=expand_nothing,
402 : };
403 : lisp_type *type_error = &type_error_obj;
404 :
405 0 : static void error_print(FILE *f, lisp_value *v)
406 : {
407 0 : lisp_error *error = (lisp_error*) v;
408 0 : fprintf(f, "error: %s", error->message);
409 0 : }
410 :
411 0 : static lisp_value *error_new(void)
412 : {
413 0 : lisp_error *error = malloc(sizeof(lisp_error));
414 0 : error->type = type_error;
415 0 : error->message = NULL;
416 0 : return (lisp_value*)error;
417 : }
418 :
419 0 : static void error_free(void *v)
420 : {
421 0 : lisp_error *error = (lisp_error*) v;
422 0 : free(error->message);
423 0 : free(error);
424 0 : }
425 :
426 : // integer
427 :
428 : static void integer_print(FILE *f, lisp_value *v);
429 : static lisp_value *integer_new(void);
430 :
431 : static lisp_type type_integer_obj = {
432 : .type=&type_type_obj,
433 : .name="integer",
434 : .print=integer_print,
435 : .new=integer_new,
436 : .eval=eval_same,
437 : .free=free,
438 : .call=call_error,
439 : .expand=expand_nothing,
440 : };
441 : lisp_type *type_integer = &type_integer_obj;
442 :
443 0 : static void integer_print(FILE *f, lisp_value *v)
444 : {
445 0 : lisp_integer *integer = (lisp_integer*) v;
446 0 : fprintf(f, "%d", integer->x);
447 0 : }
448 :
449 0 : static lisp_value *integer_new(void)
450 : {
451 0 : lisp_integer *integer = malloc(sizeof(lisp_integer));
452 0 : integer->x = 0;
453 0 : return (lisp_value*)integer;
454 : }
455 :
456 : // string
457 :
458 : static void string_print(FILE *f, lisp_value *v);
459 : static lisp_value *string_new(void);
460 : static void string_free(void *v);
461 :
462 : static lisp_type type_string_obj = {
463 : .type=&type_type_obj,
464 : .name="string",
465 : .print=string_print,
466 : .new=string_new,
467 : .eval=eval_same,
468 : .free=string_free,
469 : .call=call_error,
470 : .expand=expand_nothing,
471 : };
472 : lisp_type *type_string = &type_string_obj;
473 :
474 0 : static void string_print(FILE *f, lisp_value *v)
475 : {
476 0 : lisp_string *str = (lisp_string*) v;
477 0 : fprintf(f, "%s", str->s);
478 0 : }
479 :
480 0 : static lisp_value *string_new(void)
481 : {
482 0 : lisp_string *str = malloc(sizeof(lisp_string));
483 0 : str->s = NULL;
484 0 : return (lisp_value*)str;
485 : }
486 :
487 0 : static void string_free(void *v)
488 : {
489 0 : lisp_string *str = (lisp_string*) v;
490 0 : free(str->s);
491 0 : free(str);
492 0 : }
493 :
494 : // builtin
495 :
496 : static void builtin_print(FILE *f, lisp_value *v);
497 : static lisp_value *builtin_new(void);
498 : static lisp_value *builtin_call(lisp_runtime *rt, lisp_scope *scope,
499 : lisp_value *c, lisp_value *arguments);
500 :
501 : static lisp_type type_builtin_obj = {
502 : .type=&type_type_obj,
503 : .name="builtin",
504 : .print=builtin_print,
505 : .new=builtin_new,
506 : .eval=eval_error,
507 : .free=free,
508 : .call=builtin_call,
509 : .expand=expand_nothing,
510 : };
511 : lisp_type *type_builtin = &type_builtin_obj;
512 :
513 0 : static void builtin_print(FILE *f, lisp_value *v)
514 : {
515 0 : lisp_builtin *builtin = (lisp_builtin*) v;
516 0 : fprintf(f, "<builtin function %s>", builtin->name);
517 0 : }
518 :
519 0 : static lisp_value *builtin_new()
520 : {
521 0 : lisp_builtin *builtin = malloc(sizeof(lisp_builtin));
522 0 : builtin->call = NULL;
523 0 : builtin->name = NULL;
524 0 : return (lisp_value*) builtin;
525 : }
526 :
527 0 : static lisp_value *builtin_call(lisp_runtime *rt, lisp_scope *scope,
528 : lisp_value *c, lisp_value *arguments)
529 : {
530 0 : lisp_builtin *builtin = (lisp_builtin*) c;
531 0 : return builtin->call(rt, scope, arguments);
532 : }
533 :
534 : // lambda
535 :
536 : static void lambda_print(FILE *f, lisp_value *v);
537 : static lisp_value *lambda_new(void);
538 : static lisp_value *lambda_call(lisp_runtime *rt, lisp_scope *scope,
539 : lisp_value *c, lisp_value *arguments);
540 : static smb_iter lambda_expand(lisp_value *v);
541 :
542 : static lisp_type type_lambda_obj = {
543 : .type=&type_type_obj,
544 : .name="lambda",
545 : .print=lambda_print,
546 : .new=lambda_new,
547 : .eval=eval_error,
548 : .free=free,
549 : .call=lambda_call,
550 : .expand=lambda_expand,
551 : };
552 : lisp_type *type_lambda = &type_lambda_obj;
553 :
554 0 : static void lambda_print(FILE *f, lisp_value *v)
555 : {
556 : (void)v;
557 0 : fprintf(f, "<lambda function>");
558 0 : }
559 :
560 0 : static lisp_value *lambda_new()
561 : {
562 0 : lisp_lambda *lambda = malloc(sizeof(lisp_lambda));
563 0 : lambda->args = NULL;
564 0 : lambda->code = NULL;
565 0 : return (lisp_value*) lambda;
566 : }
567 :
568 0 : static lisp_value *lambda_call(lisp_runtime *rt, lisp_scope *scope,
569 : lisp_value *c, lisp_value *arguments)
570 : {
571 0 : lisp_lambda *lambda = (lisp_lambda*) c;
572 0 : lisp_list *argvalues = (lisp_list*)lisp_eval_list(rt, scope, arguments);
573 0 : lisp_scope *inner = (lisp_scope*)lisp_new(rt, type_scope);
574 0 : inner->up = lambda->closure;
575 :
576 0 : lisp_list *it1 = lambda->args, *it2 = argvalues;
577 0 : while (!lisp_nil_p((lisp_value*)it1) && !lisp_nil_p((lisp_value*)it2)) {
578 0 : lisp_scope_bind(inner, (lisp_symbol*) it1->left, it2->left);
579 0 : it1 = (lisp_list*) it1->right;
580 0 : it2 = (lisp_list*) it2->right;
581 : }
582 :
583 0 : if (!lisp_nil_p((lisp_value*)it1)) {
584 0 : return (lisp_value*) lisp_error_new(rt, "not enough arguments");
585 : }
586 0 : if (!lisp_nil_p((lisp_value*)it2)) {
587 0 : return (lisp_value*) lisp_error_new(rt, "too many arguments");
588 : }
589 :
590 0 : return lisp_eval(rt, inner, lambda->code);
591 : }
592 :
593 0 : static DATA lambda_expand_next(smb_iter *it, smb_status *status)
594 : {
595 : (void)status;
596 0 : lisp_lambda *l = (lisp_lambda*)it->ds;
597 0 : it->index++;
598 0 : switch (it->index) {
599 : case 1:
600 0 : return PTR(l->args);
601 : case 2:
602 0 : return PTR(l->code);
603 : case 3:
604 0 : return PTR(l->closure);
605 : default:
606 0 : return PTR(NULL);
607 : }
608 : }
609 :
610 0 : static smb_iter lambda_expand(lisp_value *v)
611 : {
612 0 : smb_iter it = {
613 : .ds=v,
614 : .state=LLINT(3),
615 : .index=0,
616 : .next=lambda_expand_next,
617 : .has_next=has_next_index_lt_state,
618 : .destroy=destroy_nop,
619 : .delete=delete_filler,
620 : };
621 0 : return it;
622 : }
623 :
624 : // Shortcuts for type objects.
625 :
626 0 : void lisp_print(FILE *f, lisp_value *value)
627 : {
628 0 : value->type->print(f, value);
629 0 : }
630 :
631 0 : void lisp_free(lisp_value *value)
632 : {
633 0 : value->type->free(value);
634 0 : }
635 :
636 0 : lisp_value *lisp_eval(lisp_runtime *rt, lisp_scope *scope, lisp_value *value)
637 : {
638 0 : return value->type->eval(rt, scope, value);
639 : }
640 :
641 0 : lisp_value *lisp_call(lisp_runtime *rt, lisp_scope *scope,
642 : lisp_value *callable, lisp_value *args)
643 : {
644 0 : if (callable->type == type_error) {
645 0 : return callable;
646 : }
647 :
648 0 : return callable->type->call(rt, scope, callable, args);
649 : }
650 :
651 0 : lisp_value *lisp_new(lisp_runtime *rt, lisp_type *typ)
652 : {
653 0 : lisp_value *new = typ->new();
654 0 : new->type = typ;
655 0 : new->next = NULL;
656 0 : new->mark = GC_NOMARK;
657 0 : if (rt->head == NULL) {
658 0 : rt->head = new;
659 0 : rt->tail = new;
660 : } else {
661 0 : rt->tail->next = new;
662 0 : rt->tail = new;
663 : }
664 0 : return new;
665 : }
|
