X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Flisp%2Fao_lisp_eval.c;h=e3d653b99e1635e078967db28d84cf3a8ee26475;hb=d8cf97fe22acefab40d7bb321138e46d4483fef7;hp=5e4908ffdf0ddb8fa0f86a3dbf4ede23ce91b75a;hpb=c9456362c8bad8cd9be717f591f2d0841f88eb50;p=fw%2Faltos diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 5e4908ff..e3d653b9 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -14,13 +14,14 @@ #include "ao_lisp.h" -#if 1 +#if 0 +#define DBG_CODE 1 static int stack_depth; #define DBG_INDENT() do { int _s; for(_s = 0; _s < stack_depth; _s++) printf(" "); } while(0) #define DBG_IN() (++stack_depth) #define DBG_OUT() (--stack_depth) #define DBG(...) printf(__VA_ARGS__) -#define DBGI(...) do { DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBGI(...) do { DBG_INDENT(); DBG("%4d: ", __LINE__); DBG(__VA_ARGS__); } while (0) #define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) #define DBG_POLY(a) ao_lisp_poly_print(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) @@ -37,13 +38,17 @@ static int stack_depth; enum eval_state { eval_sexpr, eval_val, + eval_formal, eval_exec, - eval_exec_direct + eval_exec_direct, + eval_cond, + eval_cond_test }; struct ao_lisp_stack { ao_poly prev; uint8_t state; + uint8_t macro; ao_poly actuals; ao_poly formals; ao_poly formals_tail; @@ -76,6 +81,7 @@ stack_mark(void *addr) for (;;) { ao_lisp_poly_mark(stack->actuals); ao_lisp_poly_mark(stack->formals); + /* no need to mark formals_tail */ ao_lisp_poly_mark(stack->frame); stack = ao_lisp_poly_stack(stack->prev); if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) @@ -83,20 +89,51 @@ stack_mark(void *addr) } } +static const struct ao_lisp_type ao_lisp_stack_type; + +#if DBG_CODE +static void +stack_validate_tail(struct ao_lisp_stack *stack) +{ + struct ao_lisp_cons *head = ao_lisp_poly_cons(stack->formals); + struct ao_lisp_cons *tail = ao_lisp_poly_cons(stack->formals_tail); + struct ao_lisp_cons *cons; + for (cons = head; cons && cons->cdr && cons != tail; cons = ao_lisp_poly_cons(cons->cdr)) + ; + if (cons != tail || (tail && tail->cdr)) { + if (!tail) { + printf("tail null\n"); + } else { + printf("tail validate fail head %d actual %d recorded %d\n", + OFFSET(head), OFFSET(cons), OFFSET(tail)); + abort(); + } + } +} +#else +#define stack_validate_tail(s) +#endif + static void stack_move(void *addr) { struct ao_lisp_stack *stack = addr; - for (;;) { - struct ao_lisp_stack *prev; - stack->actuals = ao_lisp_poly_move(stack->actuals); - stack->formals = ao_lisp_poly_move(stack->formals); - stack->frame = ao_lisp_poly_move(stack->frame); - prev = ao_lisp_ref(stack->prev); - prev = ao_lisp_move_memory(prev, sizeof (struct ao_lisp_stack)); - stack->prev = ao_lisp_stack_poly(prev); - stack = prev; + while (stack) { + void *prev; + int ret; + (void) ao_lisp_poly_move(&stack->actuals); + (void) ao_lisp_poly_move(&stack->formals); + (void) ao_lisp_poly_move(&stack->formals_tail); + (void) ao_lisp_poly_move(&stack->frame); + prev = ao_lisp_poly_stack(stack->prev); + ret = ao_lisp_move(&ao_lisp_stack_type, &prev); + if (prev != ao_lisp_poly_stack(stack->prev)) + stack->prev = ao_lisp_stack_poly(prev); + stack_validate_tail(stack); + if (ret) + break; + stack = ao_lisp_poly_stack(stack->prev); } } @@ -106,45 +143,69 @@ static const struct ao_lisp_type ao_lisp_stack_type = { .move = stack_move }; - static struct ao_lisp_stack *ao_lisp_stack; +static ao_poly ao_lisp_v; static uint8_t been_here; +#if DBG_CODE +static void +stack_validate_tails(void) +{ + struct ao_lisp_stack *stack; + + for (stack = ao_lisp_stack; stack; stack = ao_lisp_poly_stack(stack->prev)) + stack_validate_tail(stack); +} +#else +#define stack_validate_tails(s) +#endif + ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { + ao_lisp_stack->state = eval_cond; + ao_lisp_stack->actuals = ao_lisp_cons_poly(c); return AO_LISP_NIL; } -static void +void ao_lisp_stack_reset(struct ao_lisp_stack *stack) { stack->state = eval_sexpr; + stack->macro = 0; stack->actuals = AO_LISP_NIL; stack->formals = AO_LISP_NIL; stack->formals_tail = AO_LISP_NIL; stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + stack_validate_tails(); } -static struct ao_lisp_stack * +int ao_lisp_stack_push(void) { + stack_validate_tails(); + if (ao_lisp_stack) { + DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); + DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + } + DBGI("stack push\n"); + DBG_IN(); struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); if (!stack) - return NULL; + return 0; stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - ao_lisp_stack_reset(stack); ao_lisp_stack = stack; - DBGI("stack push\n"); - DBG_IN(); - return stack; + ao_lisp_stack_reset(stack); + stack_validate_tails(); + return 1; } -static struct ao_lisp_stack * +void ao_lisp_stack_pop(void) { if (!ao_lisp_stack) - return NULL; + return; + stack_validate_tails(); DBG_OUT(); DBGI("stack pop\n"); ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); @@ -152,17 +213,20 @@ ao_lisp_stack_pop(void) ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); else ao_lisp_frame_current = NULL; - return ao_lisp_stack; + if (ao_lisp_stack) { + DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); + DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + } } static void ao_lisp_stack_clear(void) { + stack_validate_tails(); ao_lisp_stack = NULL; ao_lisp_frame_current = NULL; } - static ao_poly func_type(ao_poly func) { @@ -194,8 +258,11 @@ func_type(ao_poly func) f++; } return ao_lisp_arg(cons, 0); - } else - return ao_lisp_error(AO_LISP_INVALID, "not a func"); + } else { + ao_lisp_error(AO_LISP_INVALID, "not a func"); + abort(); + return AO_LISP_NIL; + } } static int @@ -234,8 +301,8 @@ ao_lisp_lambda(struct ao_lisp_cons *cons) args_provided = 1; if (args_wanted != args_provided) return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); - next_frame = ao_lisp_frame_new(args_wanted, 0); - DBGI("new frame %d\n", OFFSET(next_frame)); + next_frame = ao_lisp_frame_new(args_wanted); +// DBGI("new frame %d\n", OFFSET(next_frame)); switch (type) { case _ao_lisp_atom_lambda: { int f; @@ -266,331 +333,177 @@ ao_lisp_lambda(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_eval(ao_poly v) +ao_lisp_eval(ao_poly _v) { - struct ao_lisp_stack *stack; ao_poly formal; + ao_lisp_v = _v; if (!been_here) { been_here = 1; - ao_lisp_root_add(&ao_lisp_stack_type, &stack); + ao_lisp_root_add(&ao_lisp_stack_type, &ao_lisp_stack); + ao_lisp_root_poly_add(&ao_lisp_v); } - stack = ao_lisp_stack_push(); + if (!ao_lisp_stack_push()) + goto bail; for (;;) { if (ao_lisp_exception) - return AO_LISP_NIL; - switch (stack->state) { + goto bail; + switch (ao_lisp_stack->state) { case eval_sexpr: - DBGI("sexpr: "); DBG_POLY(v); DBG("\n"); - switch (ao_lisp_poly_type(v)) { + DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); + switch (ao_lisp_poly_type(ao_lisp_v)) { case AO_LISP_CONS: - if (v == AO_LISP_NIL) { - stack->state = eval_exec; + if (ao_lisp_v == AO_LISP_NIL) { + ao_lisp_stack->state = eval_exec; break; } - stack->actuals = v; - stack = ao_lisp_stack_push(); - v = ao_lisp_poly_cons(v)->car; + ao_lisp_stack->actuals = ao_lisp_v; + DBGI("actuals now "); DBG_POLY(ao_lisp_v); DBG("\n"); + ao_lisp_stack->state = eval_formal; + if (!ao_lisp_stack_push()) + goto bail; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + stack_validate_tails(); break; case AO_LISP_ATOM: - v = ao_lisp_atom_get(v); + ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); /* fall through */ case AO_LISP_INT: case AO_LISP_STRING: - stack->state = eval_val; + case AO_LISP_BUILTIN: + ao_lisp_stack->state = eval_val; break; } break; case eval_val: - DBGI("val: "); DBG_POLY(v); DBG("\n"); - stack = ao_lisp_stack_pop(); - if (!stack) - return v; + DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); + ao_lisp_stack_pop(); + if (!ao_lisp_stack) + return ao_lisp_v; + DBGI("..state %d\n", ao_lisp_stack->state); + break; - stack->state = eval_sexpr; + case eval_formal: /* Check what kind of function we've got */ - if (!stack->formals) { - switch (func_type(v)) { + if (!ao_lisp_stack->formals) { + switch (func_type(ao_lisp_v)) { case AO_LISP_LAMBDA: case _ao_lisp_atom_lambda: case AO_LISP_LEXPR: case _ao_lisp_atom_lexpr: DBGI(".. lambda or lexpr\n"); break; - case AO_LISP_NLAMBDA: - case _ao_lisp_atom_nlambda: case AO_LISP_MACRO: case _ao_lisp_atom_macro: + ao_lisp_stack->macro = 1; + case AO_LISP_NLAMBDA: + case _ao_lisp_atom_nlambda: DBGI(".. nlambda or macro\n"); - stack->formals = stack->actuals; - stack->state = eval_exec_direct; + ao_lisp_stack->formals = ao_lisp_stack->actuals; + ao_lisp_stack->formals_tail = AO_LISP_NIL; + ao_lisp_stack->state = eval_exec_direct; + stack_validate_tails(); break; } - if (stack->state == eval_exec_direct) + if (ao_lisp_stack->state == eval_exec_direct) break; } - formal = ao_lisp_cons_poly(ao_lisp_cons_cons(v, NULL)); - if (!formal) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } + DBGI("add formal "); DBG_POLY(ao_lisp_v); DBG("\n"); + stack_validate_tails(); + formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); + stack_validate_tails(); + if (!formal) + goto bail; - if (stack->formals_tail) - ao_lisp_poly_cons(stack->formals_tail)->cdr = formal; + if (ao_lisp_stack->formals_tail) + ao_lisp_poly_cons(ao_lisp_stack->formals_tail)->cdr = formal; else - stack->formals = formal; - stack->formals_tail = formal; + ao_lisp_stack->formals = formal; + ao_lisp_stack->formals_tail = formal; + + DBGI("formals now "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n"); + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; - v = ao_lisp_poly_cons(stack->actuals)->cdr; + stack_validate_tails(); + ao_lisp_stack->state = eval_sexpr; break; case eval_exec: - v = ao_lisp_poly_cons(stack->formals)->car; + if (!ao_lisp_stack->formals) { + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + break; + } + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->formals)->car; case eval_exec_direct: - DBGI("exec: "); DBG_POLY(v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n"); - if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - - v = ao_lisp_func(b) (ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr)); - DBGI("builtin result:"); DBG_POLY(v); DBG ("\n"); - if (ao_lisp_exception) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } - stack->state = eval_val; + DBGI("exec: macro %d ", ao_lisp_stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(ao_lisp_stack->formals); DBG ("\n"); + if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) { + stack_validate_tails(); + struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v); + stack_validate_tails(); + struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->formals)->cdr); + + DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n"); + stack_validate_tails(); + if (ao_lisp_stack->macro) + ao_lisp_stack->state = eval_sexpr; + else + ao_lisp_stack->state = eval_val; + ao_lisp_stack->macro = 0; + ao_lisp_stack->actuals = ao_lisp_stack->formals = ao_lisp_stack->formals_tail = AO_LISP_NIL; + ao_lisp_v = ao_lisp_func(b) (f); + DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n"); + if (ao_lisp_exception) + goto bail; break; } else { - v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals)); - ao_lisp_stack_reset(stack); + ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(ao_lisp_stack->formals)); + ao_lisp_stack_reset(ao_lisp_stack); } break; - } - } -} -#if 0 - - - restart: - if (cond) { - DBGI("cond is now "); DBG_CONS(cond); DBG("\n"); - if (cond->car == AO_LISP_NIL) { - cond = AO_LISP_NIL; - v = AO_LISP_NIL; + case eval_cond: + DBGI("cond: "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + if (!ao_lisp_stack->actuals) { + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; } else { - if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "malformed cond"); + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->car; + if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { + ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); goto bail; } - v = ao_lisp_poly_cons(cond->car)->car; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + ao_lisp_stack->state = eval_cond_test; + stack_validate_tails(); + ao_lisp_stack_push(); + stack_validate_tails(); + ao_lisp_stack->state = eval_sexpr; } - } - - /* Build stack frames for each list */ - while (ao_lisp_poly_type(v) == AO_LISP_CONS) { - if (v == AO_LISP_NIL) - break; - - /* Push existing bits on the stack */ - if (cons++) - if (!ao_lisp_stack_push()) - goto bail; - - actuals = ao_lisp_poly_cons(v); - formals = NULL; - formals_tail = NULL; - save_cond = cond; - cond = NULL; - - v = actuals->car; - -// DBG("start: stack"); DBG_CONS(stack); DBG("\n"); -// DBG("start: actuals"); DBG_CONS(actuals); DBG("\n"); -// DBG("start: formals"); DBG_CONS(formals); DBG("\n"); - } - - if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - switch (b->args) { - case AO_LISP_NLAMBDA: - formals = actuals; - goto eval; - - case AO_LISP_MACRO: - v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); - DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals)); - DBG(" -> "); DBG_POLY(v); - DBG("\n"); - if (ao_lisp_poly_type(v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "macro didn't return list"); - goto bail; - } - /* Reset frame to the new list */ - actuals = ao_lisp_poly_cons(v); - v = actuals->car; - goto restart; - } - /* Evaluate primitive types */ - - DBG ("actual: "); DBG_POLY(v); DBG("\n"); - - switch (ao_lisp_poly_type(v)) { - case AO_LISP_INT: - case AO_LISP_STRING: break; - case AO_LISP_ATOM: - v = ao_lisp_atom_get(v); - break; - } - - while (cons) { - DBG("add formal: "); DBG_POLY(v); DBG("\n"); - - /* We've processed the first element of the list, go check - * what kind of function we've got - */ - if (formals == NULL) { - if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - switch (b->args) { - case AO_LISP_NLAMBDA: - formals = actuals; - goto eval; - - case AO_LISP_MACRO: - v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); - DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals)); - DBG(" -> "); DBG_POLY(v); - DBG("\n"); - if (ao_lisp_poly_type(v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "macro didn't return list"); - goto bail; - } - /* Reset frame to the new list */ - actuals = ao_lisp_poly_cons(v); - v = actuals->car; - goto restart; - } + case eval_cond_test: + DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + if (ao_lisp_v) { + struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->actuals)->car); + struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); + if (c) { + ao_lisp_v = c->car; + ao_lisp_stack->state = eval_sexpr; } else { - switch (func_type(v)) { - case _ao_lisp_atom_lambda: - case _ao_lisp_atom_lexpr: - break; - case _ao_lisp_atom_nlambda: - formals = actuals; - goto eval; - case _ao_lisp_atom_macro: - break; - default: - ao_lisp_error(AO_LISP_INVALID, "operator is not a function"); - goto bail; - } + ao_lisp_stack->state = eval_val; } - } - - formal = ao_lisp_cons_cons(v, NULL); - if (formals_tail) - formals_tail->cdr = ao_lisp_cons_poly(formal); - else - formals = formal; - formals_tail = formal; - actuals = ao_lisp_poly_cons(actuals->cdr); - - DBG("formals: "); - DBG_CONS(formals); - DBG("\n"); - DBG("actuals: "); - DBG_CONS(actuals); - DBG("\n"); - - /* Process all of the arguments */ - if (actuals) { - v = actuals->car; - break; - } - - v = formals->car; - - eval: - - /* Evaluate the resulting list */ - if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { - struct ao_lisp_cons *old_cond = cond; - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - - v = ao_lisp_func(b) (ao_lisp_poly_cons(formals->cdr)); - - DBG ("eval: "); - DBG_CONS(formals); - DBG(" -> "); - DBG_POLY(v); - DBG ("\n"); - if (ao_lisp_exception) - goto bail; - - if (cond != old_cond) { - DBG("cond changed from "); DBG_CONS(old_cond); DBG(" to "); DBG_CONS(cond); DBG("\n"); - actuals = NULL; - formals = 0; - formals_tail = 0; - save_cons = cons; - cons = 0; - goto restart; - } - } else { - v = ao_lisp_lambda(formals); - if (ao_lisp_exception) - goto bail; - } - - cond_done: - --cons; - if (cons) { - ao_lisp_stack_pop(); -// DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); -// DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); -// DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); } else { - actuals = 0; - formals = 0; - formals_tail = 0; - ao_lisp_frame_current = 0; - } - if (next_frame) { - ao_lisp_frame_current = next_frame; - DBG("next frame %d\n", OFFSET(next_frame)); - next_frame = 0; - goto restart; + ao_lisp_stack->actuals = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; + DBGI("actuals now "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + ao_lisp_stack->state = eval_cond; } - } - if (cond) { - DBG("next cond cons is %d\n", cons); - if (v) { - v = ao_lisp_poly_cons(cond->car)->cdr; - cond = 0; - cons = save_cons; - if (v != AO_LISP_NIL) { - v = ao_lisp_poly_cons(v)->car; - DBG("cond complete, sexpr is "); DBG_POLY(v); DBG("\n"); - } - goto cond_done; - } else { - cond = ao_lisp_poly_cons(cond->cdr); - DBG("next cond is "); DBG_CONS(cond); DBG("\n"); - goto restart; - } - } - if (!cons) break; + } } - DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current)); - return v; bail: ao_lisp_stack_clear(); return AO_LISP_NIL; -#endif - +}