X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Flisp%2Fao_lisp_eval.c;h=b7e7b9727639bb536c4a6f121f6261531eb9fc6f;hb=3366efb139653939f053c1fe4aba352ba3b66c94;hp=531e3b7263309fd7a0a35d8eaa0b85018368f153;hpb=56d46ceaa1413415f25e47e81036426132f99924;p=fw%2Faltos diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 531e3b72..b7e7b972 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -14,139 +14,431 @@ #include "ao_lisp.h" -/* - * Non-recursive eval - * - * Plan: walk actuals, construct formals - * - * stack > save > actuals > actual_1 - * v v - * formals . > actual_2 - */ +#if 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 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) +#else +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#endif -static struct ao_lisp_cons *stack; -static struct ao_lisp_cons *actuals; -static struct ao_lisp_cons *formals; -static struct ao_lisp_cons *formals_tail; -static uint8_t been_here; +enum eval_state { + eval_sexpr, + eval_val, + eval_formal, + eval_exec, + 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; + ao_poly frame; +}; -ao_lisp_poly -ao_lisp_eval(ao_lisp_poly v) +static struct ao_lisp_stack * +ao_lisp_poly_stack(ao_poly p) { - struct ao_lisp_cons *formal; - int cons = 0; + return ao_lisp_ref(p); +} - if (!been_here) { - been_here = 1; - ao_lisp_root_add(&ao_lisp_cons_type, &stack); - ao_lisp_root_add(&ao_lisp_cons_type, &actuals); - ao_lisp_root_add(&ao_lisp_cons_type, &formals); - ao_lisp_root_add(&ao_lisp_cons_type, &formals_tail); - } - stack = 0; - actuals = 0; - formals = 0; - formals_tail = 0; +static ao_poly +ao_lisp_stack_poly(struct ao_lisp_stack *stack) +{ + return ao_lisp_poly(stack, AO_LISP_OTHER); +} + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_lisp_stack *stack = addr; for (;;) { + ao_lisp_poly_mark(stack->actuals); + ao_lisp_poly_mark(stack->formals); + ao_lisp_poly_mark(stack->frame); + stack = ao_lisp_poly_stack(stack->prev); + if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) + break; + } +} - /* Build stack frames for each list */ - while (ao_lisp_poly_type(v) == AO_LISP_CONS) { - if (v == AO_LISP_NIL) - break; +static const struct ao_lisp_type ao_lisp_stack_type; + +static void +stack_move(void *addr) +{ + struct ao_lisp_stack *stack = addr; + + 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->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); + if (ret); + break; + stack = ao_lisp_poly_stack(stack->prev); + } +} + +static const struct ao_lisp_type ao_lisp_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move +}; + +static struct ao_lisp_stack *ao_lisp_stack; +static ao_poly ao_lisp_v; +static uint8_t been_here; + +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; +} + +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); +} + +struct ao_lisp_stack * +ao_lisp_stack_push(void) +{ + struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!stack) + return NULL; + stack->prev = ao_lisp_stack_poly(ao_lisp_stack); + ao_lisp_stack = stack; + ao_lisp_stack_reset(stack); + DBGI("stack push\n"); + DBG_IN(); + return stack; +} + +struct ao_lisp_stack * +ao_lisp_stack_pop(void) +{ + if (!ao_lisp_stack) + return NULL; + DBG_OUT(); + DBGI("stack pop\n"); + ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); + if (ao_lisp_stack) + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + else + ao_lisp_frame_current = NULL; + return ao_lisp_stack; +} + +static void +ao_lisp_stack_clear(void) +{ + ao_lisp_stack = NULL; + ao_lisp_frame_current = NULL; +} - /* Push existing frame on the stack */ - if (cons++) { - struct ao_lisp_cons *frame; +static ao_poly +func_type(ao_poly func) +{ + struct ao_lisp_cons *cons; + struct ao_lisp_cons *args; + int f; - frame = ao_lisp_cons(ao_lisp_cons_poly(actuals), formals); - stack = ao_lisp_cons(ao_lisp_cons_poly(frame), stack); + DBGI("func type "); DBG_POLY(func); DBG("\n"); + if (func == AO_LISP_NIL) + return ao_lisp_error(AO_LISP_INVALID, "func is nil"); + if (ao_lisp_poly_type(func) == AO_LISP_BUILTIN) { + struct ao_lisp_builtin *b = ao_lisp_poly_builtin(func); + return b->args; + } else if (ao_lisp_poly_type(func) == AO_LISP_CONS) { + cons = ao_lisp_poly_cons(func); + if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1)); + f = 0; + while (args) { + if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) { + return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f); } - actuals = ao_lisp_poly_cons(v); - formals = NULL; - formals_tail = NULL; - v = actuals->car; - - printf("start: stack"); ao_lisp_cons_print(stack); printf("\n"); - printf("start: actuals"); ao_lisp_cons_print(actuals); printf("\n"); - printf("start: formals"); ao_lisp_cons_print(formals); printf("\n"); + args = ao_lisp_poly_cons(args->cdr); + f++; } + return ao_lisp_arg(cons, 0); + } else { + ao_lisp_error(AO_LISP_INVALID, "not a func"); + abort(); + return AO_LISP_NIL; + } +} + +static int +ao_lisp_cons_length(struct ao_lisp_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_lisp_poly_cons(cons->cdr); + } + return len; +} - /* Evaluate primitive types */ +static ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons) +{ + ao_poly type; + struct ao_lisp_cons *lambda; + struct ao_lisp_cons *args; + struct ao_lisp_frame *next_frame; + int args_wanted; + int args_provided; - switch (ao_lisp_poly_type(v)) { - case AO_LISP_INT: - case AO_LISP_STRING: - break; - case AO_LISP_ATOM: - v = ao_lisp_poly_atom(v)->val; - break; + lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); + DBGI("lambda "); DBG_CONS(lambda); DBG("\n"); + type = ao_lisp_arg(lambda, 0); + args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1)); + + args_wanted = ao_lisp_cons_length(args); + + /* Create a frame to hold the variables + */ + if (type == _ao_lisp_atom_lambda) + args_provided = ao_lisp_cons_length(cons) - 1; + else + 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); + DBGI("new frame %d\n", OFFSET(next_frame)); + switch (type) { + case _ao_lisp_atom_lambda: { + int f; + struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); + + for (f = 0; f < args_wanted; f++) { + next_frame->vals[f].atom = args->car; + next_frame->vals[f].val = vals->car; + args = ao_lisp_poly_cons(args->cdr); + vals = ao_lisp_poly_cons(vals->cdr); } + break; + } + case _ao_lisp_atom_lexpr: + case _ao_lisp_atom_nlambda: + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = cons->cdr; + break; + case _ao_lisp_atom_macro: + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = ao_lisp_cons_poly(cons); + break; + } + next_frame->next = ao_lisp_frame_poly(ao_lisp_frame_current); + ao_lisp_frame_current = next_frame; + ao_lisp_stack->frame = ao_lisp_frame_poly(next_frame); + return ao_lisp_arg(lambda, 2); +} - for (;;) { - printf("add formal: "); ao_lisp_poly_print(v); printf("\n"); +ao_poly +ao_lisp_eval(ao_poly _v) +{ + struct ao_lisp_stack *stack; + ao_poly formal; - formal = ao_lisp_cons(v, NULL); - if (formals_tail) - formals_tail->cdr = formal; - else - formals = formal; - formals_tail = formal; - actuals = actuals->cdr; - - printf("formals: "); - ao_lisp_cons_print(formals); - printf("\n"); - printf("actuals: "); - ao_lisp_cons_print(actuals); - printf("\n"); - - /* Process all of the arguments */ - if (actuals) { - v = actuals->car; - printf ("actual: "); ao_lisp_poly_print(v); printf("\n"); + ao_lisp_v = _v; + if (!been_here) { + been_here = 1; + ao_lisp_root_add(&ao_lisp_stack_type, &ao_lisp_stack); + ao_lisp_root_poly_add(&ao_lisp_v); + } + + stack = ao_lisp_stack_push(); + + for (;;) { + if (ao_lisp_exception) + return AO_LISP_NIL; + switch (stack->state) { + case eval_sexpr: + DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); + switch (ao_lisp_poly_type(ao_lisp_v)) { + case AO_LISP_CONS: + if (ao_lisp_v == AO_LISP_NIL) { + stack->state = eval_exec; + break; + } + stack->actuals = ao_lisp_v; + stack->state = eval_formal; + stack = ao_lisp_stack_push(); + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + break; + case AO_LISP_ATOM: + ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); + /* fall through */ + case AO_LISP_INT: + case AO_LISP_STRING: + stack->state = eval_val; break; } + break; + case eval_val: + DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); + stack = ao_lisp_stack_pop(); + if (!stack) + return ao_lisp_v; + DBGI("..state %d\n", stack->state); + break; - v = formals->car; + case eval_formal: + /* Check what kind of function we've got */ + if (!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_MACRO: + case _ao_lisp_atom_macro: + 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; + break; + } + if (stack->state == eval_exec_direct) + break; + } - /* Evaluate the resulting list */ - if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); + formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); + if (!formal) { + ao_lisp_stack_clear(); + return AO_LISP_NIL; + } - v = b->func(formals->cdr); + if (stack->formals_tail) + ao_lisp_poly_cons(stack->formals_tail)->cdr = formal; + else + stack->formals = formal; + stack->formals_tail = formal; - printf ("eval: "); - ao_lisp_cons_print(formals); - printf(" -> "); - ao_lisp_poly_print(v); - printf ("\n"); - } else { - printf ("invalid eval\n"); - } + DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n"); - if (--cons) { - struct ao_lisp_cons *frame; + ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->cdr; - /* Pop the previous frame off the stack */ - frame = ao_lisp_poly_cons(stack->car); - actuals = ao_lisp_poly_cons(frame->car); - formals = frame->cdr; + stack->state = eval_sexpr; - /* Recompute the tail of the formals list */ - for (formal = formals; formal->cdr != NULL; formal = formal->cdr); - formals_tail = formal; + break; + case eval_exec: + if (!stack->formals) { + ao_lisp_v = AO_LISP_NIL; + stack->state = eval_val; + break; + } + ao_lisp_v = ao_lisp_poly_cons(stack->formals)->car; + case eval_exec_direct: + DBGI("exec: macro %d ", stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n"); + if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) { + struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v); + struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr); - stack = stack->cdr; - printf("stack pop: stack"); ao_lisp_cons_print(stack); printf("\n"); - printf("stack pop: actuals"); ao_lisp_cons_print(actuals); printf("\n"); - printf("stack pop: formals"); ao_lisp_cons_print(formals); printf("\n"); - } else { - printf("done func\n"); + DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n"); + if (stack->macro) + stack->state = eval_sexpr; + else + stack->state = eval_val; + stack->macro = 0; + ao_lisp_v = ao_lisp_func(b) (f); + DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n"); + if (ao_lisp_exception) { + ao_lisp_stack_clear(); + return AO_LISP_NIL; + } break; + } else { + ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals)); + ao_lisp_stack_reset(stack); } - } - if (!cons) break; + case eval_cond: + DBGI("cond: "); DBG_POLY(stack->actuals); DBG("\n"); + if (!stack->actuals) { + ao_lisp_v = AO_LISP_NIL; + stack->state = eval_val; + } else { + ao_lisp_v = ao_lisp_poly_cons(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; + } + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + stack->state = eval_cond_test; + stack = ao_lisp_stack_push(); + stack->state = eval_sexpr; + } + break; + case eval_cond_test: + DBGI("cond_test "); DBG_POLY(ao_lisp_v); DBG("\n"); + if (ao_lisp_v) { + struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->actuals)->car); + struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); + if (c) { + ao_lisp_v = c->car; + stack->state = eval_sexpr; + } else { + stack->state = eval_val; + } + } else { + stack->actuals = ao_lisp_poly_cons(stack->actuals)->cdr; + stack->state = eval_cond; + } + break; + } } - return v; +bail: + ao_lisp_stack_clear(); + return AO_LISP_NIL; }