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 /* no need to mark formals_tail */
84 ao_lisp_poly_mark(stack->frame);
85 stack = ao_lisp_poly_stack(stack->prev);
86 if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack)))
91 static const struct ao_lisp_type ao_lisp_stack_type;
94 stack_move(void *addr)
96 struct ao_lisp_stack *stack = addr;
101 (void) ao_lisp_poly_move(&stack->actuals);
102 (void) ao_lisp_poly_move(&stack->formals);
103 (void) ao_lisp_poly_move(&stack->formals_tail);
104 (void) ao_lisp_poly_move(&stack->frame);
105 prev = ao_lisp_poly_stack(stack->prev);
106 ret = ao_lisp_move(&ao_lisp_stack_type, &prev);
107 if (prev != ao_lisp_poly_stack(stack->prev))
108 stack->prev = ao_lisp_stack_poly(prev);
111 stack = ao_lisp_poly_stack(stack->prev);
115 static const struct ao_lisp_type ao_lisp_stack_type = {
121 static struct ao_lisp_stack *ao_lisp_stack;
122 static ao_poly ao_lisp_v;
123 static uint8_t been_here;
126 ao_lisp_set_cond(struct ao_lisp_cons *c)
128 ao_lisp_stack->state = eval_cond;
129 ao_lisp_stack->actuals = ao_lisp_cons_poly(c);
134 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
136 stack->state = eval_sexpr;
138 stack->actuals = AO_LISP_NIL;
139 stack->formals = AO_LISP_NIL;
140 stack->formals_tail = AO_LISP_NIL;
141 stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
144 struct ao_lisp_stack *
145 ao_lisp_stack_push(void)
147 struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
150 stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
151 ao_lisp_stack = stack;
152 ao_lisp_stack_reset(stack);
153 DBGI("stack push\n");
158 struct ao_lisp_stack *
159 ao_lisp_stack_pop(void)
165 ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev);
167 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
169 ao_lisp_frame_current = NULL;
170 return ao_lisp_stack;
174 ao_lisp_stack_clear(void)
176 ao_lisp_stack = NULL;
177 ao_lisp_frame_current = NULL;
181 func_type(ao_poly func)
183 struct ao_lisp_cons *cons;
184 struct ao_lisp_cons *args;
187 DBGI("func type "); DBG_POLY(func); DBG("\n");
188 if (func == AO_LISP_NIL)
189 return ao_lisp_error(AO_LISP_INVALID, "func is nil");
190 if (ao_lisp_poly_type(func) == AO_LISP_BUILTIN) {
191 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(func);
193 } else if (ao_lisp_poly_type(func) == AO_LISP_CONS) {
194 cons = ao_lisp_poly_cons(func);
195 if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3))
197 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0))
199 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1))
201 args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1));
204 if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) {
205 return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f);
207 args = ao_lisp_poly_cons(args->cdr);
210 return ao_lisp_arg(cons, 0);
212 ao_lisp_error(AO_LISP_INVALID, "not a func");
219 ao_lisp_cons_length(struct ao_lisp_cons *cons)
224 cons = ao_lisp_poly_cons(cons->cdr);
230 ao_lisp_lambda(struct ao_lisp_cons *cons)
233 struct ao_lisp_cons *lambda;
234 struct ao_lisp_cons *args;
235 struct ao_lisp_frame *next_frame;
239 lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0));
240 DBGI("lambda "); DBG_CONS(lambda); DBG("\n");
241 type = ao_lisp_arg(lambda, 0);
242 args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1));
244 args_wanted = ao_lisp_cons_length(args);
246 /* Create a frame to hold the variables
248 if (type == _ao_lisp_atom_lambda)
249 args_provided = ao_lisp_cons_length(cons) - 1;
252 if (args_wanted != args_provided)
253 return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided);
254 next_frame = ao_lisp_frame_new(args_wanted);
255 // DBGI("new frame %d\n", OFFSET(next_frame));
257 case _ao_lisp_atom_lambda: {
259 struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr);
261 for (f = 0; f < args_wanted; f++) {
262 next_frame->vals[f].atom = args->car;
263 next_frame->vals[f].val = vals->car;
264 args = ao_lisp_poly_cons(args->cdr);
265 vals = ao_lisp_poly_cons(vals->cdr);
269 case _ao_lisp_atom_lexpr:
270 case _ao_lisp_atom_nlambda:
271 next_frame->vals[0].atom = args->car;
272 next_frame->vals[0].val = cons->cdr;
274 case _ao_lisp_atom_macro:
275 next_frame->vals[0].atom = args->car;
276 next_frame->vals[0].val = ao_lisp_cons_poly(cons);
279 next_frame->next = ao_lisp_frame_poly(ao_lisp_frame_current);
280 ao_lisp_frame_current = next_frame;
281 ao_lisp_stack->frame = ao_lisp_frame_poly(next_frame);
282 return ao_lisp_arg(lambda, 2);
286 ao_lisp_eval(ao_poly _v)
288 struct ao_lisp_stack *stack;
294 ao_lisp_root_add(&ao_lisp_stack_type, &ao_lisp_stack);
295 ao_lisp_root_poly_add(&ao_lisp_v);
298 stack = ao_lisp_stack_push();
301 if (ao_lisp_exception)
303 switch (stack->state) {
305 DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n");
306 switch (ao_lisp_poly_type(ao_lisp_v)) {
308 if (ao_lisp_v == AO_LISP_NIL) {
309 stack->state = eval_exec;
312 stack->actuals = ao_lisp_v;
313 stack->state = eval_formal;
314 stack = ao_lisp_stack_push();
315 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
318 ao_lisp_v = ao_lisp_atom_get(ao_lisp_v);
322 stack->state = eval_val;
327 DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n");
328 stack = ao_lisp_stack_pop();
331 DBGI("..state %d\n", stack->state);
335 /* Check what kind of function we've got */
336 if (!stack->formals) {
337 switch (func_type(ao_lisp_v)) {
339 case _ao_lisp_atom_lambda:
341 case _ao_lisp_atom_lexpr:
342 DBGI(".. lambda or lexpr\n");
345 case _ao_lisp_atom_macro:
347 case AO_LISP_NLAMBDA:
348 case _ao_lisp_atom_nlambda:
349 DBGI(".. nlambda or macro\n");
350 stack->formals = stack->actuals;
351 stack->state = eval_exec_direct;
354 if (stack->state == eval_exec_direct)
358 formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL));
360 ao_lisp_stack_clear();
364 if (stack->formals_tail)
365 ao_lisp_poly_cons(stack->formals_tail)->cdr = formal;
367 stack->formals = formal;
368 stack->formals_tail = formal;
370 DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n");
372 ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->cdr;
374 stack->state = eval_sexpr;
378 if (!stack->formals) {
379 ao_lisp_v = AO_LISP_NIL;
380 stack->state = eval_val;
383 ao_lisp_v = ao_lisp_poly_cons(stack->formals)->car;
384 case eval_exec_direct:
385 DBGI("exec: macro %d ", stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n");
386 if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) {
387 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v);
388 struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr);
390 DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n");
392 stack->state = eval_sexpr;
394 stack->state = eval_val;
396 ao_lisp_v = ao_lisp_func(b) (f);
397 DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n");
398 if (ao_lisp_exception) {
399 ao_lisp_stack_clear();
404 ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals));
405 ao_lisp_stack_reset(stack);
409 DBGI("cond: "); DBG_POLY(stack->actuals); DBG("\n");
410 if (!stack->actuals) {
411 ao_lisp_v = AO_LISP_NIL;
412 stack->state = eval_val;
414 ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->car;
415 if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) {
416 ao_lisp_error(AO_LISP_INVALID, "invalid cond clause");
419 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
420 stack->state = eval_cond_test;
421 stack = ao_lisp_stack_push();
422 stack->state = eval_sexpr;
426 DBGI("cond_test "); DBG_POLY(ao_lisp_v); DBG("\n");
428 struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->actuals)->car);
429 struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr);
432 stack->state = eval_sexpr;
434 stack->state = eval_val;
437 stack->actuals = ao_lisp_poly_cons(stack->actuals)->cdr;
438 stack->state = eval_cond;
444 ao_lisp_stack_clear();