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.
19 static int stack_depth;
20 #define DBG_INDENT() do { int _s; for(_s = 0; _s < stack_depth; _s++) printf(" "); } while(0)
21 #define DBG_IN() (++stack_depth)
22 #define DBG_OUT() (--stack_depth)
23 #define DBG(...) printf(__VA_ARGS__)
24 #define DBGI(...) do { DBG_INDENT(); DBG("%4d: ", __LINE__); DBG(__VA_ARGS__); } while (0)
25 #define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a))
26 #define DBG_POLY(a) ao_lisp_poly_print(a)
27 #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1)
48 struct ao_lisp_stack {
58 static struct ao_lisp_stack *
59 ao_lisp_poly_stack(ao_poly p)
61 return ao_lisp_ref(p);
65 ao_lisp_stack_poly(struct ao_lisp_stack *stack)
67 return ao_lisp_poly(stack, AO_LISP_OTHER);
71 stack_size(void *addr)
74 return sizeof (struct ao_lisp_stack);
78 stack_mark(void *addr)
80 struct ao_lisp_stack *stack = addr;
82 ao_lisp_poly_mark(stack->actuals, 0);
83 ao_lisp_poly_mark(stack->formals, 0);
84 /* no need to mark formals_tail */
85 ao_lisp_poly_mark(stack->frame, 0);
86 stack = ao_lisp_poly_stack(stack->prev);
87 if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack)))
92 static const struct ao_lisp_type ao_lisp_stack_type;
96 stack_validate_tail(struct ao_lisp_stack *stack)
98 struct ao_lisp_cons *head = ao_lisp_poly_cons(stack->formals);
99 struct ao_lisp_cons *tail = ao_lisp_poly_cons(stack->formals_tail);
100 struct ao_lisp_cons *cons;
101 for (cons = head; cons && cons->cdr && cons != tail; cons = ao_lisp_poly_cons(cons->cdr))
103 if (cons != tail || (tail && tail->cdr)) {
105 printf("tail null\n");
107 printf("tail validate fail head %d actual %d recorded %d\n",
108 OFFSET(head), OFFSET(cons), OFFSET(tail));
114 #define stack_validate_tail(s)
118 stack_move(void *addr)
120 struct ao_lisp_stack *stack = addr;
125 (void) ao_lisp_poly_move(&stack->actuals, 0);
126 (void) ao_lisp_poly_move(&stack->formals, 0);
127 (void) ao_lisp_poly_move(&stack->formals_tail, 0);
128 (void) ao_lisp_poly_move(&stack->frame, 0);
129 prev = ao_lisp_poly_stack(stack->prev);
130 ret = ao_lisp_move(&ao_lisp_stack_type, &prev);
131 if (prev != ao_lisp_poly_stack(stack->prev))
132 stack->prev = ao_lisp_stack_poly(prev);
133 stack_validate_tail(stack);
136 stack = ao_lisp_poly_stack(stack->prev);
140 static const struct ao_lisp_type ao_lisp_stack_type = {
146 static struct ao_lisp_stack *ao_lisp_stack;
147 static ao_poly ao_lisp_v;
148 static uint8_t been_here;
152 stack_validate_tails(void)
154 struct ao_lisp_stack *stack;
156 for (stack = ao_lisp_stack; stack; stack = ao_lisp_poly_stack(stack->prev))
157 stack_validate_tail(stack);
160 #define stack_validate_tails(s)
164 ao_lisp_set_cond(struct ao_lisp_cons *c)
166 ao_lisp_stack->state = eval_cond;
167 ao_lisp_stack->actuals = ao_lisp_cons_poly(c);
172 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
174 stack->state = eval_sexpr;
176 stack->actuals = AO_LISP_NIL;
177 stack->formals = AO_LISP_NIL;
178 stack->formals_tail = AO_LISP_NIL;
179 stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
180 stack_validate_tails();
184 ao_lisp_stack_push(void)
186 stack_validate_tails();
188 DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n");
189 DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n");
191 DBGI("stack push\n");
193 struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
196 stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
197 ao_lisp_stack = stack;
198 ao_lisp_stack_reset(stack);
199 stack_validate_tails();
204 ao_lisp_stack_pop(void)
208 stack_validate_tails();
211 ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev);
213 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
215 ao_lisp_frame_current = NULL;
217 DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n");
218 DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n");
223 ao_lisp_stack_clear(void)
225 stack_validate_tails();
226 ao_lisp_stack = NULL;
227 ao_lisp_frame_current = NULL;
231 func_type(ao_poly func)
233 struct ao_lisp_cons *cons;
234 struct ao_lisp_cons *args;
237 DBGI("func type "); DBG_POLY(func); DBG("\n");
238 if (func == AO_LISP_NIL)
239 return ao_lisp_error(AO_LISP_INVALID, "func is nil");
240 if (ao_lisp_poly_type(func) == AO_LISP_BUILTIN) {
241 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(func);
243 } else if (ao_lisp_poly_type(func) == AO_LISP_CONS) {
244 cons = ao_lisp_poly_cons(func);
245 if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3))
247 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0))
249 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1))
251 args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1));
254 if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) {
255 return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f);
257 args = ao_lisp_poly_cons(args->cdr);
260 return ao_lisp_arg(cons, 0);
262 ao_lisp_error(AO_LISP_INVALID, "not a func");
269 ao_lisp_cons_length(struct ao_lisp_cons *cons)
274 cons = ao_lisp_poly_cons(cons->cdr);
280 ao_lisp_lambda(struct ao_lisp_cons *cons)
283 struct ao_lisp_cons *lambda;
284 struct ao_lisp_cons *args;
285 struct ao_lisp_frame *next_frame;
289 lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0));
290 DBGI("lambda "); DBG_CONS(lambda); DBG("\n");
291 type = ao_lisp_arg(lambda, 0);
292 args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1));
294 args_wanted = ao_lisp_cons_length(args);
296 /* Create a frame to hold the variables
298 if (type == _ao_lisp_atom_lambda)
299 args_provided = ao_lisp_cons_length(cons) - 1;
302 if (args_wanted != args_provided)
303 return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided);
304 next_frame = ao_lisp_frame_new(args_wanted);
305 // DBGI("new frame %d\n", OFFSET(next_frame));
307 case _ao_lisp_atom_lambda: {
309 struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr);
311 for (f = 0; f < args_wanted; f++) {
312 next_frame->vals[f].atom = args->car;
313 next_frame->vals[f].val = vals->car;
314 args = ao_lisp_poly_cons(args->cdr);
315 vals = ao_lisp_poly_cons(vals->cdr);
319 case _ao_lisp_atom_lexpr:
320 case _ao_lisp_atom_nlambda:
321 next_frame->vals[0].atom = args->car;
322 next_frame->vals[0].val = cons->cdr;
324 case _ao_lisp_atom_macro:
325 next_frame->vals[0].atom = args->car;
326 next_frame->vals[0].val = ao_lisp_cons_poly(cons);
329 next_frame->next = ao_lisp_frame_poly(ao_lisp_frame_current);
330 ao_lisp_frame_current = next_frame;
331 ao_lisp_stack->frame = ao_lisp_frame_poly(next_frame);
332 return ao_lisp_arg(lambda, 2);
336 ao_lisp_eval(ao_poly _v)
343 ao_lisp_root_add(&ao_lisp_stack_type, &ao_lisp_stack);
344 ao_lisp_root_poly_add(&ao_lisp_v);
347 if (!ao_lisp_stack_push())
351 if (ao_lisp_exception)
353 switch (ao_lisp_stack->state) {
355 DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n");
356 switch (ao_lisp_poly_type(ao_lisp_v)) {
358 if (ao_lisp_v == AO_LISP_NIL) {
359 ao_lisp_stack->state = eval_exec;
362 ao_lisp_stack->actuals = ao_lisp_v;
363 DBGI("actuals now "); DBG_POLY(ao_lisp_v); DBG("\n");
364 ao_lisp_stack->state = eval_formal;
365 if (!ao_lisp_stack_push())
367 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
368 stack_validate_tails();
371 ao_lisp_v = ao_lisp_atom_get(ao_lisp_v);
375 case AO_LISP_BUILTIN:
376 ao_lisp_stack->state = eval_val;
381 DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n");
385 DBGI("..state %d\n", ao_lisp_stack->state);
389 /* Check what kind of function we've got */
390 if (!ao_lisp_stack->formals) {
391 switch (func_type(ao_lisp_v)) {
393 case _ao_lisp_atom_lambda:
395 case _ao_lisp_atom_lexpr:
396 DBGI(".. lambda or lexpr\n");
399 case _ao_lisp_atom_macro:
400 ao_lisp_stack->macro = 1;
401 case AO_LISP_NLAMBDA:
402 case _ao_lisp_atom_nlambda:
403 DBGI(".. nlambda or macro\n");
404 ao_lisp_stack->formals = ao_lisp_stack->actuals;
405 ao_lisp_stack->formals_tail = AO_LISP_NIL;
406 ao_lisp_stack->state = eval_exec_direct;
407 stack_validate_tails();
410 if (ao_lisp_stack->state == eval_exec_direct)
414 DBGI("add formal "); DBG_POLY(ao_lisp_v); DBG("\n");
415 stack_validate_tails();
416 formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL));
417 stack_validate_tails();
421 if (ao_lisp_stack->formals_tail)
422 ao_lisp_poly_cons(ao_lisp_stack->formals_tail)->cdr = formal;
424 ao_lisp_stack->formals = formal;
425 ao_lisp_stack->formals_tail = formal;
427 DBGI("formals now "); DBG_POLY(ao_lisp_stack->formals); DBG("\n");
429 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr;
431 stack_validate_tails();
432 ao_lisp_stack->state = eval_sexpr;
436 if (!ao_lisp_stack->formals) {
437 ao_lisp_v = AO_LISP_NIL;
438 ao_lisp_stack->state = eval_val;
441 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->formals)->car;
442 case eval_exec_direct:
443 DBGI("exec: macro %d ", ao_lisp_stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(ao_lisp_stack->formals); DBG ("\n");
444 if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) {
445 stack_validate_tails();
446 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v);
447 stack_validate_tails();
448 struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->formals)->cdr);
450 DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n");
451 stack_validate_tails();
452 if (ao_lisp_stack->macro)
453 ao_lisp_stack->state = eval_sexpr;
455 ao_lisp_stack->state = eval_val;
456 ao_lisp_stack->macro = 0;
457 ao_lisp_stack->actuals = ao_lisp_stack->formals = ao_lisp_stack->formals_tail = AO_LISP_NIL;
458 ao_lisp_v = ao_lisp_func(b) (f);
459 DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n");
460 if (ao_lisp_exception)
464 ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(ao_lisp_stack->formals));
465 ao_lisp_stack_reset(ao_lisp_stack);
469 DBGI("cond: "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n");
470 if (!ao_lisp_stack->actuals) {
471 ao_lisp_v = AO_LISP_NIL;
472 ao_lisp_stack->state = eval_val;
474 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->car;
475 if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) {
476 ao_lisp_error(AO_LISP_INVALID, "invalid cond clause");
479 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
480 ao_lisp_stack->state = eval_cond_test;
481 stack_validate_tails();
482 ao_lisp_stack_push();
483 stack_validate_tails();
484 ao_lisp_stack->state = eval_sexpr;
488 DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n");
490 struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->actuals)->car);
491 struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr);
494 ao_lisp_stack->state = eval_sexpr;
496 ao_lisp_stack->state = eval_val;
499 ao_lisp_stack->actuals = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr;
500 DBGI("actuals now "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n");
501 ao_lisp_stack->state = eval_cond;
507 ao_lisp_stack_clear();