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)
47 struct ao_lisp_stack {
57 static struct ao_lisp_stack *
58 ao_lisp_poly_stack(ao_poly p)
60 return ao_lisp_ref(p);
64 ao_lisp_stack_poly(struct ao_lisp_stack *stack)
66 return ao_lisp_poly(stack, AO_LISP_OTHER);
70 stack_size(void *addr)
73 return sizeof (struct ao_lisp_stack);
77 stack_mark(void *addr)
79 struct ao_lisp_stack *stack = addr;
81 ao_lisp_poly_mark(stack->actuals);
82 ao_lisp_poly_mark(stack->formals);
83 ao_lisp_poly_mark(stack->frame);
84 stack = ao_lisp_poly_stack(stack->prev);
85 if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack)))
90 static const struct ao_lisp_type ao_lisp_stack_type;
93 stack_move(void *addr)
95 struct ao_lisp_stack *stack = addr;
100 (void) ao_lisp_poly_move(&stack->actuals);
101 (void) ao_lisp_poly_move(&stack->formals);
102 (void) ao_lisp_poly_move(&stack->frame);
103 prev = ao_lisp_poly_stack(stack->prev);
104 ret = ao_lisp_move(&ao_lisp_stack_type, &prev);
105 if (prev != ao_lisp_poly_stack(stack->prev))
106 stack->prev = ao_lisp_stack_poly(prev);
109 stack = ao_lisp_poly_stack(stack->prev);
113 static const struct ao_lisp_type ao_lisp_stack_type = {
119 static struct ao_lisp_stack *ao_lisp_stack;
120 static ao_poly ao_lisp_v;
121 static uint8_t been_here;
124 ao_lisp_set_cond(struct ao_lisp_cons *c)
126 ao_lisp_stack->state = eval_cond;
127 ao_lisp_stack->actuals = ao_lisp_cons_poly(c);
132 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
134 stack->state = eval_sexpr;
136 stack->actuals = AO_LISP_NIL;
137 stack->formals = AO_LISP_NIL;
138 stack->formals_tail = AO_LISP_NIL;
139 stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
142 struct ao_lisp_stack *
143 ao_lisp_stack_push(void)
145 struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
148 stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
149 ao_lisp_stack = stack;
150 ao_lisp_stack_reset(stack);
151 DBGI("stack push\n");
156 struct ao_lisp_stack *
157 ao_lisp_stack_pop(void)
163 ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev);
165 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
167 ao_lisp_frame_current = NULL;
168 return ao_lisp_stack;
172 ao_lisp_stack_clear(void)
174 ao_lisp_stack = NULL;
175 ao_lisp_frame_current = NULL;
179 func_type(ao_poly func)
181 struct ao_lisp_cons *cons;
182 struct ao_lisp_cons *args;
185 DBGI("func type "); DBG_POLY(func); DBG("\n");
186 if (func == AO_LISP_NIL)
187 return ao_lisp_error(AO_LISP_INVALID, "func is nil");
188 if (ao_lisp_poly_type(func) == AO_LISP_BUILTIN) {
189 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(func);
191 } else if (ao_lisp_poly_type(func) == AO_LISP_CONS) {
192 cons = ao_lisp_poly_cons(func);
193 if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3))
195 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0))
197 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1))
199 args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1));
202 if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) {
203 return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f);
205 args = ao_lisp_poly_cons(args->cdr);
208 return ao_lisp_arg(cons, 0);
210 ao_lisp_error(AO_LISP_INVALID, "not a func");
217 ao_lisp_cons_length(struct ao_lisp_cons *cons)
222 cons = ao_lisp_poly_cons(cons->cdr);
228 ao_lisp_lambda(struct ao_lisp_cons *cons)
231 struct ao_lisp_cons *lambda;
232 struct ao_lisp_cons *args;
233 struct ao_lisp_frame *next_frame;
237 lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0));
238 DBGI("lambda "); DBG_CONS(lambda); DBG("\n");
239 type = ao_lisp_arg(lambda, 0);
240 args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1));
242 args_wanted = ao_lisp_cons_length(args);
244 /* Create a frame to hold the variables
246 if (type == _ao_lisp_atom_lambda)
247 args_provided = ao_lisp_cons_length(cons) - 1;
250 if (args_wanted != args_provided)
251 return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided);
252 next_frame = ao_lisp_frame_new(args_wanted);
253 DBGI("new frame %d\n", OFFSET(next_frame));
255 case _ao_lisp_atom_lambda: {
257 struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr);
259 for (f = 0; f < args_wanted; f++) {
260 next_frame->vals[f].atom = args->car;
261 next_frame->vals[f].val = vals->car;
262 args = ao_lisp_poly_cons(args->cdr);
263 vals = ao_lisp_poly_cons(vals->cdr);
267 case _ao_lisp_atom_lexpr:
268 case _ao_lisp_atom_nlambda:
269 next_frame->vals[0].atom = args->car;
270 next_frame->vals[0].val = cons->cdr;
272 case _ao_lisp_atom_macro:
273 next_frame->vals[0].atom = args->car;
274 next_frame->vals[0].val = ao_lisp_cons_poly(cons);
277 next_frame->next = ao_lisp_frame_poly(ao_lisp_frame_current);
278 ao_lisp_frame_current = next_frame;
279 ao_lisp_stack->frame = ao_lisp_frame_poly(next_frame);
280 return ao_lisp_arg(lambda, 2);
284 ao_lisp_eval(ao_poly _v)
286 struct ao_lisp_stack *stack;
292 ao_lisp_root_add(&ao_lisp_stack_type, &ao_lisp_stack);
293 ao_lisp_root_poly_add(&ao_lisp_v);
296 stack = ao_lisp_stack_push();
299 if (ao_lisp_exception)
301 switch (stack->state) {
303 DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n");
304 switch (ao_lisp_poly_type(ao_lisp_v)) {
306 if (ao_lisp_v == AO_LISP_NIL) {
307 stack->state = eval_exec;
310 stack->actuals = ao_lisp_v;
311 stack->state = eval_formal;
312 stack = ao_lisp_stack_push();
313 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
316 ao_lisp_v = ao_lisp_atom_get(ao_lisp_v);
320 stack->state = eval_val;
325 DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n");
326 stack = ao_lisp_stack_pop();
329 DBGI("..state %d\n", stack->state);
333 /* Check what kind of function we've got */
334 if (!stack->formals) {
335 switch (func_type(ao_lisp_v)) {
337 case _ao_lisp_atom_lambda:
339 case _ao_lisp_atom_lexpr:
340 DBGI(".. lambda or lexpr\n");
343 case _ao_lisp_atom_macro:
345 case AO_LISP_NLAMBDA:
346 case _ao_lisp_atom_nlambda:
347 DBGI(".. nlambda or macro\n");
348 stack->formals = stack->actuals;
349 stack->state = eval_exec_direct;
352 if (stack->state == eval_exec_direct)
356 formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL));
358 ao_lisp_stack_clear();
362 if (stack->formals_tail)
363 ao_lisp_poly_cons(stack->formals_tail)->cdr = formal;
365 stack->formals = formal;
366 stack->formals_tail = formal;
368 DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n");
370 ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->cdr;
372 stack->state = eval_sexpr;
376 if (!stack->formals) {
377 ao_lisp_v = AO_LISP_NIL;
378 stack->state = eval_val;
381 ao_lisp_v = ao_lisp_poly_cons(stack->formals)->car;
382 case eval_exec_direct:
383 DBGI("exec: macro %d ", stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n");
384 if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) {
385 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v);
386 struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr);
388 DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n");
390 stack->state = eval_sexpr;
392 stack->state = eval_val;
394 ao_lisp_v = ao_lisp_func(b) (f);
395 DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n");
396 if (ao_lisp_exception) {
397 ao_lisp_stack_clear();
402 ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals));
403 ao_lisp_stack_reset(stack);
407 DBGI("cond: "); DBG_POLY(stack->actuals); DBG("\n");
408 if (!stack->actuals) {
409 ao_lisp_v = AO_LISP_NIL;
410 stack->state = eval_val;
412 ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->car;
413 if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) {
414 ao_lisp_error(AO_LISP_INVALID, "invalid cond clause");
417 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
418 stack->state = eval_cond_test;
419 stack = ao_lisp_stack_push();
420 stack->state = eval_sexpr;
424 DBGI("cond_test "); DBG_POLY(ao_lisp_v); DBG("\n");
426 struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->actuals)->car);
427 struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr);
430 stack->state = eval_sexpr;
432 stack->state = eval_val;
435 stack->actuals = ao_lisp_poly_cons(stack->actuals)->cdr;
436 stack->state = eval_cond;
442 ao_lisp_stack_clear();