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 {
53 static struct ao_lisp_stack *
54 ao_lisp_poly_stack(ao_poly p)
56 return ao_lisp_ref(p);
60 ao_lisp_stack_poly(struct ao_lisp_stack *stack)
62 return ao_lisp_poly(stack, AO_LISP_OTHER);
66 stack_size(void *addr)
69 return sizeof (struct ao_lisp_stack);
73 stack_mark(void *addr)
75 struct ao_lisp_stack *stack = addr;
77 ao_lisp_poly_mark(stack->actuals);
78 ao_lisp_poly_mark(stack->formals);
79 ao_lisp_poly_mark(stack->frame);
80 stack = ao_lisp_poly_stack(stack->prev);
81 if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack)))
87 stack_move(void *addr)
89 struct ao_lisp_stack *stack = addr;
92 struct ao_lisp_stack *prev;
93 stack->actuals = ao_lisp_poly_move(stack->actuals);
94 stack->formals = ao_lisp_poly_move(stack->formals);
95 stack->frame = ao_lisp_poly_move(stack->frame);
96 prev = ao_lisp_ref(stack->prev);
97 prev = ao_lisp_move_memory(prev, sizeof (struct ao_lisp_stack));
98 stack->prev = ao_lisp_stack_poly(prev);
103 static const struct ao_lisp_type ao_lisp_stack_type = {
110 static struct ao_lisp_stack *ao_lisp_stack;
111 static uint8_t been_here;
114 ao_lisp_set_cond(struct ao_lisp_cons *c)
120 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
122 stack->state = eval_sexpr;
123 stack->actuals = AO_LISP_NIL;
124 stack->formals = AO_LISP_NIL;
125 stack->formals_tail = AO_LISP_NIL;
126 stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
129 static struct ao_lisp_stack *
130 ao_lisp_stack_push(void)
132 struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
135 stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
136 ao_lisp_stack_reset(stack);
137 ao_lisp_stack = stack;
138 DBGI("stack push\n");
143 static struct ao_lisp_stack *
144 ao_lisp_stack_pop(void)
150 ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev);
152 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
154 ao_lisp_frame_current = NULL;
155 return ao_lisp_stack;
159 ao_lisp_stack_clear(void)
161 ao_lisp_stack = NULL;
162 ao_lisp_frame_current = NULL;
167 func_type(ao_poly func)
169 struct ao_lisp_cons *cons;
170 struct ao_lisp_cons *args;
173 DBGI("func type "); DBG_POLY(func); DBG("\n");
174 if (func == AO_LISP_NIL)
175 return ao_lisp_error(AO_LISP_INVALID, "func is nil");
176 if (ao_lisp_poly_type(func) == AO_LISP_BUILTIN) {
177 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(func);
179 } else if (ao_lisp_poly_type(func) == AO_LISP_CONS) {
180 cons = ao_lisp_poly_cons(func);
181 if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3))
183 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0))
185 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1))
187 args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1));
190 if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) {
191 return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f);
193 args = ao_lisp_poly_cons(args->cdr);
196 return ao_lisp_arg(cons, 0);
198 return ao_lisp_error(AO_LISP_INVALID, "not a func");
202 ao_lisp_cons_length(struct ao_lisp_cons *cons)
207 cons = ao_lisp_poly_cons(cons->cdr);
213 ao_lisp_lambda(struct ao_lisp_cons *cons)
216 struct ao_lisp_cons *lambda;
217 struct ao_lisp_cons *args;
218 struct ao_lisp_frame *next_frame;
222 lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0));
223 DBGI("lambda "); DBG_CONS(lambda); DBG("\n");
224 type = ao_lisp_arg(lambda, 0);
225 args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1));
227 args_wanted = ao_lisp_cons_length(args);
229 /* Create a frame to hold the variables
231 if (type == _ao_lisp_atom_lambda)
232 args_provided = ao_lisp_cons_length(cons) - 1;
235 if (args_wanted != args_provided)
236 return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided);
237 next_frame = ao_lisp_frame_new(args_wanted, 0);
238 DBGI("new frame %d\n", OFFSET(next_frame));
240 case _ao_lisp_atom_lambda: {
242 struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr);
244 for (f = 0; f < args_wanted; f++) {
245 next_frame->vals[f].atom = args->car;
246 next_frame->vals[f].val = vals->car;
247 args = ao_lisp_poly_cons(args->cdr);
248 vals = ao_lisp_poly_cons(vals->cdr);
252 case _ao_lisp_atom_lexpr:
253 case _ao_lisp_atom_nlambda:
254 next_frame->vals[0].atom = args->car;
255 next_frame->vals[0].val = cons->cdr;
257 case _ao_lisp_atom_macro:
258 next_frame->vals[0].atom = args->car;
259 next_frame->vals[0].val = ao_lisp_cons_poly(cons);
262 next_frame->next = ao_lisp_frame_poly(ao_lisp_frame_current);
263 ao_lisp_frame_current = next_frame;
264 ao_lisp_stack->frame = ao_lisp_frame_poly(next_frame);
265 return ao_lisp_arg(lambda, 2);
269 ao_lisp_eval(ao_poly v)
271 struct ao_lisp_stack *stack;
276 ao_lisp_root_add(&ao_lisp_stack_type, &stack);
279 stack = ao_lisp_stack_push();
282 if (ao_lisp_exception)
284 switch (stack->state) {
286 DBGI("sexpr: "); DBG_POLY(v); DBG("\n");
287 switch (ao_lisp_poly_type(v)) {
289 if (v == AO_LISP_NIL) {
290 stack->state = eval_exec;
294 stack = ao_lisp_stack_push();
295 v = ao_lisp_poly_cons(v)->car;
298 v = ao_lisp_atom_get(v);
302 stack->state = eval_val;
307 DBGI("val: "); DBG_POLY(v); DBG("\n");
308 stack = ao_lisp_stack_pop();
312 stack->state = eval_sexpr;
313 /* Check what kind of function we've got */
314 if (!stack->formals) {
315 switch (func_type(v)) {
317 case _ao_lisp_atom_lambda:
319 case _ao_lisp_atom_lexpr:
320 DBGI(".. lambda or lexpr\n");
322 case AO_LISP_NLAMBDA:
323 case _ao_lisp_atom_nlambda:
325 case _ao_lisp_atom_macro:
326 DBGI(".. nlambda or macro\n");
327 stack->formals = stack->actuals;
328 stack->state = eval_exec_direct;
331 if (stack->state == eval_exec_direct)
335 formal = ao_lisp_cons_poly(ao_lisp_cons_cons(v, NULL));
337 ao_lisp_stack_clear();
341 if (stack->formals_tail)
342 ao_lisp_poly_cons(stack->formals_tail)->cdr = formal;
344 stack->formals = formal;
345 stack->formals_tail = formal;
347 DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n");
349 v = ao_lisp_poly_cons(stack->actuals)->cdr;
353 v = ao_lisp_poly_cons(stack->formals)->car;
354 case eval_exec_direct:
355 DBGI("exec: "); DBG_POLY(v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n");
356 if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
357 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
359 v = ao_lisp_func(b) (ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr));
360 DBGI("builtin result:"); DBG_POLY(v); DBG ("\n");
361 if (ao_lisp_exception) {
362 ao_lisp_stack_clear();
365 stack->state = eval_val;
368 v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals));
369 ao_lisp_stack_reset(stack);
380 DBGI("cond is now "); DBG_CONS(cond); DBG("\n");
381 if (cond->car == AO_LISP_NIL) {
385 if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) {
386 ao_lisp_error(AO_LISP_INVALID, "malformed cond");
389 v = ao_lisp_poly_cons(cond->car)->car;
393 /* Build stack frames for each list */
394 while (ao_lisp_poly_type(v) == AO_LISP_CONS) {
395 if (v == AO_LISP_NIL)
398 /* Push existing bits on the stack */
400 if (!ao_lisp_stack_push())
403 actuals = ao_lisp_poly_cons(v);
411 // DBG("start: stack"); DBG_CONS(stack); DBG("\n");
412 // DBG("start: actuals"); DBG_CONS(actuals); DBG("\n");
413 // DBG("start: formals"); DBG_CONS(formals); DBG("\n");
416 if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
417 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
419 case AO_LISP_NLAMBDA:
424 v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
425 DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals));
426 DBG(" -> "); DBG_POLY(v);
428 if (ao_lisp_poly_type(v) != AO_LISP_CONS) {
429 ao_lisp_error(AO_LISP_INVALID, "macro didn't return list");
432 /* Reset frame to the new list */
433 actuals = ao_lisp_poly_cons(v);
437 /* Evaluate primitive types */
439 DBG ("actual: "); DBG_POLY(v); DBG("\n");
441 switch (ao_lisp_poly_type(v)) {
446 v = ao_lisp_atom_get(v);
451 DBG("add formal: "); DBG_POLY(v); DBG("\n");
453 /* We've processed the first element of the list, go check
454 * what kind of function we've got
456 if (formals == NULL) {
457 if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
458 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
460 case AO_LISP_NLAMBDA:
465 v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
466 DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals));
467 DBG(" -> "); DBG_POLY(v);
469 if (ao_lisp_poly_type(v) != AO_LISP_CONS) {
470 ao_lisp_error(AO_LISP_INVALID, "macro didn't return list");
473 /* Reset frame to the new list */
474 actuals = ao_lisp_poly_cons(v);
479 switch (func_type(v)) {
480 case _ao_lisp_atom_lambda:
481 case _ao_lisp_atom_lexpr:
483 case _ao_lisp_atom_nlambda:
486 case _ao_lisp_atom_macro:
489 ao_lisp_error(AO_LISP_INVALID, "operator is not a function");
495 formal = ao_lisp_cons_cons(v, NULL);
497 formals_tail->cdr = ao_lisp_cons_poly(formal);
500 formals_tail = formal;
501 actuals = ao_lisp_poly_cons(actuals->cdr);
510 /* Process all of the arguments */
520 /* Evaluate the resulting list */
521 if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
522 struct ao_lisp_cons *old_cond = cond;
523 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
525 v = ao_lisp_func(b) (ao_lisp_poly_cons(formals->cdr));
532 if (ao_lisp_exception)
535 if (cond != old_cond) {
536 DBG("cond changed from "); DBG_CONS(old_cond); DBG(" to "); DBG_CONS(cond); DBG("\n");
545 v = ao_lisp_lambda(formals);
546 if (ao_lisp_exception)
554 // DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n");
555 // DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n");
556 // DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n");
561 ao_lisp_frame_current = 0;
564 ao_lisp_frame_current = next_frame;
565 DBG("next frame %d\n", OFFSET(next_frame));
571 DBG("next cond cons is %d\n", cons);
573 v = ao_lisp_poly_cons(cond->car)->cdr;
576 if (v != AO_LISP_NIL) {
577 v = ao_lisp_poly_cons(v)->car;
578 DBG("cond complete, sexpr is "); DBG_POLY(v); DBG("\n");
582 cond = ao_lisp_poly_cons(cond->cdr);
583 DBG("next cond is "); DBG_CONS(cond); DBG("\n");
590 DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current));
593 ao_lisp_stack_clear();