2 * Copyright © 2016 Keith Packard <keithp@keithp.com>
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation, either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * General Public License for more details.
18 static int stack_depth;
19 #define DBG_INDENT() do { int _s; for(_s = 0; _s < stack_depth; _s++) printf(" "); } while(0)
20 #define DBG_IN() (++stack_depth)
21 #define DBG_OUT() (--stack_depth)
22 #define DBG(...) printf(__VA_ARGS__)
23 #define DBGI(...) do { DBG_INDENT(); DBG(__VA_ARGS__); } while (0)
24 #define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a))
25 #define DBG_POLY(a) ao_lisp_poly_print(a)
26 #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1)
44 struct ao_lisp_stack {
54 static struct ao_lisp_stack *
55 ao_lisp_poly_stack(ao_poly p)
57 return ao_lisp_ref(p);
61 ao_lisp_stack_poly(struct ao_lisp_stack *stack)
63 return ao_lisp_poly(stack, AO_LISP_OTHER);
67 stack_size(void *addr)
70 return sizeof (struct ao_lisp_stack);
74 stack_mark(void *addr)
76 struct ao_lisp_stack *stack = addr;
78 ao_lisp_poly_mark(stack->actuals);
79 ao_lisp_poly_mark(stack->formals);
80 ao_lisp_poly_mark(stack->frame);
81 stack = ao_lisp_poly_stack(stack->prev);
82 if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack)))
88 stack_move(void *addr)
90 struct ao_lisp_stack *stack = addr;
93 struct ao_lisp_stack *prev;
94 stack->actuals = ao_lisp_poly_move(stack->actuals);
95 stack->formals = ao_lisp_poly_move(stack->formals);
96 stack->frame = ao_lisp_poly_move(stack->frame);
97 prev = ao_lisp_ref(stack->prev);
98 prev = ao_lisp_move_memory(prev, sizeof (struct ao_lisp_stack));
99 stack->prev = ao_lisp_stack_poly(prev);
104 static const struct ao_lisp_type ao_lisp_stack_type = {
111 static struct ao_lisp_stack *ao_lisp_stack;
112 static uint8_t been_here;
115 ao_lisp_set_cond(struct ao_lisp_cons *c)
121 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
123 stack->state = eval_sexpr;
125 stack->actuals = AO_LISP_NIL;
126 stack->formals = AO_LISP_NIL;
127 stack->formals_tail = AO_LISP_NIL;
128 stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
131 static struct ao_lisp_stack *
132 ao_lisp_stack_push(void)
134 struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
137 stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
138 ao_lisp_stack_reset(stack);
139 ao_lisp_stack = stack;
140 DBGI("stack push\n");
145 static struct ao_lisp_stack *
146 ao_lisp_stack_pop(void)
152 ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev);
154 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
156 ao_lisp_frame_current = NULL;
157 return ao_lisp_stack;
161 ao_lisp_stack_clear(void)
163 ao_lisp_stack = NULL;
164 ao_lisp_frame_current = NULL;
169 func_type(ao_poly func)
171 struct ao_lisp_cons *cons;
172 struct ao_lisp_cons *args;
175 DBGI("func type "); DBG_POLY(func); DBG("\n");
176 if (func == AO_LISP_NIL)
177 return ao_lisp_error(AO_LISP_INVALID, "func is nil");
178 if (ao_lisp_poly_type(func) == AO_LISP_BUILTIN) {
179 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(func);
181 } else if (ao_lisp_poly_type(func) == AO_LISP_CONS) {
182 cons = ao_lisp_poly_cons(func);
183 if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3))
185 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0))
187 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1))
189 args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1));
192 if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) {
193 return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f);
195 args = ao_lisp_poly_cons(args->cdr);
198 return ao_lisp_arg(cons, 0);
200 return ao_lisp_error(AO_LISP_INVALID, "not a func");
204 ao_lisp_cons_length(struct ao_lisp_cons *cons)
209 cons = ao_lisp_poly_cons(cons->cdr);
215 ao_lisp_lambda(struct ao_lisp_cons *cons)
218 struct ao_lisp_cons *lambda;
219 struct ao_lisp_cons *args;
220 struct ao_lisp_frame *next_frame;
224 lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0));
225 DBGI("lambda "); DBG_CONS(lambda); DBG("\n");
226 type = ao_lisp_arg(lambda, 0);
227 args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1));
229 args_wanted = ao_lisp_cons_length(args);
231 /* Create a frame to hold the variables
233 if (type == _ao_lisp_atom_lambda)
234 args_provided = ao_lisp_cons_length(cons) - 1;
237 if (args_wanted != args_provided)
238 return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided);
239 next_frame = ao_lisp_frame_new(args_wanted, 0);
240 DBGI("new frame %d\n", OFFSET(next_frame));
242 case _ao_lisp_atom_lambda: {
244 struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr);
246 for (f = 0; f < args_wanted; f++) {
247 next_frame->vals[f].atom = args->car;
248 next_frame->vals[f].val = vals->car;
249 args = ao_lisp_poly_cons(args->cdr);
250 vals = ao_lisp_poly_cons(vals->cdr);
254 case _ao_lisp_atom_lexpr:
255 case _ao_lisp_atom_nlambda:
256 next_frame->vals[0].atom = args->car;
257 next_frame->vals[0].val = cons->cdr;
259 case _ao_lisp_atom_macro:
260 next_frame->vals[0].atom = args->car;
261 next_frame->vals[0].val = ao_lisp_cons_poly(cons);
264 next_frame->next = ao_lisp_frame_poly(ao_lisp_frame_current);
265 ao_lisp_frame_current = next_frame;
266 ao_lisp_stack->frame = ao_lisp_frame_poly(next_frame);
267 return ao_lisp_arg(lambda, 2);
271 ao_lisp_eval(ao_poly v)
273 struct ao_lisp_stack *stack;
278 ao_lisp_root_add(&ao_lisp_stack_type, &stack);
281 stack = ao_lisp_stack_push();
284 if (ao_lisp_exception)
286 switch (stack->state) {
288 DBGI("sexpr: "); DBG_POLY(v); DBG("\n");
289 switch (ao_lisp_poly_type(v)) {
291 if (v == AO_LISP_NIL) {
292 stack->state = eval_exec;
296 stack = ao_lisp_stack_push();
297 v = ao_lisp_poly_cons(v)->car;
300 v = ao_lisp_atom_get(v);
304 stack->state = eval_val;
309 DBGI("val: "); DBG_POLY(v); DBG("\n");
310 stack = ao_lisp_stack_pop();
314 stack->state = eval_sexpr;
315 /* Check what kind of function we've got */
316 if (!stack->formals) {
317 switch (func_type(v)) {
319 case _ao_lisp_atom_lambda:
321 case _ao_lisp_atom_lexpr:
322 DBGI(".. lambda or lexpr\n");
325 case _ao_lisp_atom_macro:
327 case AO_LISP_NLAMBDA:
328 case _ao_lisp_atom_nlambda:
329 DBGI(".. nlambda or macro\n");
330 stack->formals = stack->actuals;
331 stack->state = eval_exec_direct;
334 if (stack->state == eval_exec_direct)
338 formal = ao_lisp_cons_poly(ao_lisp_cons_cons(v, NULL));
340 ao_lisp_stack_clear();
344 if (stack->formals_tail)
345 ao_lisp_poly_cons(stack->formals_tail)->cdr = formal;
347 stack->formals = formal;
348 stack->formals_tail = formal;
350 DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n");
352 v = ao_lisp_poly_cons(stack->actuals)->cdr;
356 v = ao_lisp_poly_cons(stack->formals)->car;
357 case eval_exec_direct:
358 DBGI("exec: macro %d ", stack->macro); DBG_POLY(v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n");
359 if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
360 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
361 struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr);
363 DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n");
364 v = ao_lisp_func(b) (f);
365 DBGI("builtin result:"); DBG_POLY(v); DBG ("\n");
366 if (ao_lisp_exception) {
367 ao_lisp_stack_clear();
371 stack->state = eval_sexpr;
373 stack->state = eval_val;
377 v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals));
378 ao_lisp_stack_reset(stack);
389 DBGI("cond is now "); DBG_CONS(cond); DBG("\n");
390 if (cond->car == AO_LISP_NIL) {
394 if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) {
395 ao_lisp_error(AO_LISP_INVALID, "malformed cond");
398 v = ao_lisp_poly_cons(cond->car)->car;
402 /* Build stack frames for each list */
403 while (ao_lisp_poly_type(v) == AO_LISP_CONS) {
404 if (v == AO_LISP_NIL)
407 /* Push existing bits on the stack */
409 if (!ao_lisp_stack_push())
412 actuals = ao_lisp_poly_cons(v);
420 // DBG("start: stack"); DBG_CONS(stack); DBG("\n");
421 // DBG("start: actuals"); DBG_CONS(actuals); DBG("\n");
422 // DBG("start: formals"); DBG_CONS(formals); DBG("\n");
425 if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
426 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
428 case AO_LISP_NLAMBDA:
433 v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
434 DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals));
435 DBG(" -> "); DBG_POLY(v);
437 if (ao_lisp_poly_type(v) != AO_LISP_CONS) {
438 ao_lisp_error(AO_LISP_INVALID, "macro didn't return list");
441 /* Reset frame to the new list */
442 actuals = ao_lisp_poly_cons(v);
446 /* Evaluate primitive types */
448 DBG ("actual: "); DBG_POLY(v); DBG("\n");
450 switch (ao_lisp_poly_type(v)) {
455 v = ao_lisp_atom_get(v);
460 DBG("add formal: "); DBG_POLY(v); DBG("\n");
462 /* We've processed the first element of the list, go check
463 * what kind of function we've got
465 if (formals == NULL) {
466 if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
467 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
469 case AO_LISP_NLAMBDA:
474 v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
475 DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals));
476 DBG(" -> "); DBG_POLY(v);
478 if (ao_lisp_poly_type(v) != AO_LISP_CONS) {
479 ao_lisp_error(AO_LISP_INVALID, "macro didn't return list");
482 /* Reset frame to the new list */
483 actuals = ao_lisp_poly_cons(v);
488 switch (func_type(v)) {
489 case _ao_lisp_atom_lambda:
490 case _ao_lisp_atom_lexpr:
492 case _ao_lisp_atom_nlambda:
495 case _ao_lisp_atom_macro:
498 ao_lisp_error(AO_LISP_INVALID, "operator is not a function");
504 formal = ao_lisp_cons_cons(v, NULL);
506 formals_tail->cdr = ao_lisp_cons_poly(formal);
509 formals_tail = formal;
510 actuals = ao_lisp_poly_cons(actuals->cdr);
519 /* Process all of the arguments */
529 /* Evaluate the resulting list */
530 if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
531 struct ao_lisp_cons *old_cond = cond;
532 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
534 v = ao_lisp_func(b) (ao_lisp_poly_cons(formals->cdr));
541 if (ao_lisp_exception)
544 if (cond != old_cond) {
545 DBG("cond changed from "); DBG_CONS(old_cond); DBG(" to "); DBG_CONS(cond); DBG("\n");
554 v = ao_lisp_lambda(formals);
555 if (ao_lisp_exception)
563 // DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n");
564 // DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n");
565 // DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n");
570 ao_lisp_frame_current = 0;
573 ao_lisp_frame_current = next_frame;
574 DBG("next frame %d\n", OFFSET(next_frame));
580 DBG("next cond cons is %d\n", cons);
582 v = ao_lisp_poly_cons(cond->car)->cdr;
585 if (v != AO_LISP_NIL) {
586 v = ao_lisp_poly_cons(v)->car;
587 DBG("cond complete, sexpr is "); DBG_POLY(v); DBG("\n");
591 cond = ao_lisp_poly_cons(cond->cdr);
592 DBG("next cond is "); DBG_CONS(cond); DBG("\n");
599 DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current));
602 ao_lisp_stack_clear();