From 77db0e8162cd01c2b42737b3d71b38cea942484f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 3 Nov 2016 21:49:50 -0700 Subject: altos: Add lambda support to lisp Signed-off-by: Keith Packard --- src/lisp/ao_lisp_error.c | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 src/lisp/ao_lisp_error.c (limited to 'src/lisp/ao_lisp_error.c') diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c new file mode 100644 index 00000000..ea8111d9 --- /dev/null +++ b/src/lisp/ao_lisp_error.c @@ -0,0 +1,29 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" +#include + +ao_poly +ao_lisp_error(int error, char *format, ...) +{ + va_list args; + + ao_lisp_exception |= error; + va_start(args, format); + vprintf(format, args); + va_end(args); + printf("\n"); + return AO_LISP_NIL; +} -- cgit v1.2.3 From 794718abc62f4610495fe2bd535a2b67bc46573c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 9 Nov 2016 09:14:50 -0800 Subject: altos/lisp: working on lexical scoping Not working yet Signed-off-by: Keith Packard --- src/lisp/Makefile | 4 +- src/lisp/ao_lisp.h | 147 ++++++++- src/lisp/ao_lisp_atom.c | 4 +- src/lisp/ao_lisp_builtin.c | 96 +++++- src/lisp/ao_lisp_const.lisp | 136 +++++++- src/lisp/ao_lisp_error.c | 81 +++++ src/lisp/ao_lisp_eval.c | 730 +++++++++++++++++++++--------------------- src/lisp/ao_lisp_frame.c | 21 ++ src/lisp/ao_lisp_make_const.c | 85 +++-- src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_prim.c | 10 +- src/test/Makefile | 2 +- 12 files changed, 876 insertions(+), 441 deletions(-) (limited to 'src/lisp/ao_lisp_error.c') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index be19b432..f7edbe41 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -18,7 +18,9 @@ SRCS=\ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ - ao_lisp_error.c + ao_lisp_lambda.c \ + ao_lisp_eval.c \ + ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 17f1e0f5..6a35d8ce 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -42,7 +42,9 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_car _atom("car") #define _ao_lisp_atom_cdr _atom("cdr") #define _ao_lisp_atom_cons _atom("cons") +#define _ao_lisp_atom_last _atom("last") #define _ao_lisp_atom_cond _atom("cond") +#define _ao_lisp_atom_lambda _atom("lambda") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -66,7 +68,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #define AO_LISP_ATOM 4 #define AO_LISP_BUILTIN 5 #define AO_LISP_FRAME 6 -#define AO_LISP_NUM_TYPE 7 +#define AO_LISP_LAMBDA 7 +#define AO_LISP_NUM_TYPE 8 #define AO_LISP_NIL 0 @@ -114,8 +117,8 @@ ao_lisp_poly(const void *addr, ao_poly type) { } struct ao_lisp_type { - void (*mark)(void *addr); int (*size)(void *addr); + void (*mark)(void *addr); void (*move)(void *addr); }; @@ -153,10 +156,47 @@ ao_lisp_frame_poly(struct ao_lisp_frame *frame) { return ao_lisp_poly(frame, AO_LISP_OTHER); } -#define AO_LISP_LAMBDA 0 -#define AO_LISP_NLAMBDA 1 -#define AO_LISP_MACRO 2 -#define AO_LISP_LEXPR 3 +struct ao_lisp_stack { + ao_poly prev; + uint8_t state; + uint8_t macro; + ao_poly sexprs; + ao_poly values; + ao_poly values_tail; + ao_poly frame; + ao_poly macro_frame; + ao_poly list; +}; + +enum eval_state { + eval_sexpr, + eval_val, + eval_formal, + eval_exec, + eval_lambda_done, + eval_cond, + eval_cond_test +}; + +static inline struct ao_lisp_stack * +ao_lisp_poly_stack(ao_poly p) +{ + return ao_lisp_ref(p); +} + +static inline ao_poly +ao_lisp_stack_poly(struct ao_lisp_stack *stack) +{ + return ao_lisp_poly(stack, AO_LISP_OTHER); +} + +extern struct ao_lisp_stack *ao_lisp_stack; +extern ao_poly ao_lisp_v; + +#define AO_LISP_FUNC_LAMBDA 0 +#define AO_LISP_FUNC_NLAMBDA 1 +#define AO_LISP_FUNC_MACRO 2 +#define AO_LISP_FUNC_LEXPR 3 struct ao_lisp_builtin { uint8_t type; @@ -165,9 +205,14 @@ struct ao_lisp_builtin { }; enum ao_lisp_builtin_id { + builtin_lambda, + builtin_lexpr, + builtin_nlambda, + builtin_macro, builtin_car, builtin_cdr, builtin_cons, + builtin_last, builtin_quote, builtin_set, builtin_setq, @@ -184,7 +229,7 @@ enum ao_lisp_builtin_id { builtin_greater, builtin_less_equal, builtin_greater_equal, - builtin_last + _builtin_last }; typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); @@ -197,6 +242,25 @@ ao_lisp_func(struct ao_lisp_builtin *b) return ao_lisp_builtins[b->func]; } +struct ao_lisp_lambda { + uint8_t type; + uint8_t args; + ao_poly code; + ao_poly frame; +}; + +static inline struct ao_lisp_lambda * +ao_lisp_poly_lambda(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_lambda_poly(struct ao_lisp_lambda *lambda) +{ + return ao_lisp_poly(lambda, AO_LISP_OTHER); +} + static inline void * ao_lisp_poly_other(ao_poly poly) { return ao_lisp_ref(poly); @@ -360,9 +424,9 @@ ao_lisp_string_patom(ao_poly s); /* atom */ extern const struct ao_lisp_type ao_lisp_atom_type; -extern struct ao_lisp_atom *ao_lisp_atoms; - -extern struct ao_lisp_frame *ao_lisp_frame_current; +extern struct ao_lisp_atom *ao_lisp_atoms; +extern struct ao_lisp_frame *ao_lisp_frame_global; +extern struct ao_lisp_frame *ao_lisp_frame_current; void ao_lisp_atom_print(ao_poly a); @@ -420,6 +484,9 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, ao_poly ao_lisp_arg(struct ao_lisp_cons *cons, int argc); +char * +ao_lisp_args_name(uint8_t args); + /* read */ ao_poly ao_lisp_read(void); @@ -440,9 +507,69 @@ ao_lisp_frame_new(int num); struct ao_lisp_frame * ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); +void +ao_lisp_frame_print(ao_poly p); + +/* lambda */ +extern const struct ao_lisp_type ao_lisp_lambda_type; + +struct ao_lisp_lambda * +ao_lisp_lambda_new(ao_poly cons); + +void +ao_lisp_lambda_print(ao_poly lambda); + +ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_lexpr(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_nlambda(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_macro(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, + struct ao_lisp_cons *cons); + /* error */ +void +ao_lisp_stack_print(void); + ao_poly ao_lisp_error(int error, char *format, ...); +/* debugging macros */ + +#if DBG_EVAL +#define DBG_CODE 1 +int ao_lisp_stack_depth; +#define DBG_DO(a) a +#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_lisp_stack_depth; _s++) printf(" "); } while(0) +#define DBG_IN() (++ao_lisp_stack_depth) +#define DBG_OUT() (--ao_lisp_stack_depth) +#define DBG_RESET() (ao_lisp_stack_depth = 0) +#define DBG(...) printf(__VA_ARGS__) +#define DBGI(...) do { DBG("%4d: ", __LINE__); 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) +#define DBG_STACK() ao_lisp_stack_print() +#else +#define DBG_DO(a) +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#endif + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 41ba97f5..d7cb1996 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -89,8 +89,8 @@ ao_lisp_atom_intern(char *name) return atom; } -static struct ao_lisp_frame *ao_lisp_frame_global; -struct ao_lisp_frame *ao_lisp_frame_current; +struct ao_lisp_frame *ao_lisp_frame_global; +struct ao_lisp_frame *ao_lisp_frame_current; static void ao_lisp_atom_init(void) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 49b6c37d..c38ba165 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -39,11 +39,71 @@ const struct ao_lisp_type ao_lisp_builtin_type = { .move = builtin_move }; +#ifdef AO_LISP_MAKE_CONST +char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { + return "???"; +} +char *ao_lisp_args_name(uint8_t args) { + return "???"; +} +#else +static const ao_poly builtin_names[] = { + [builtin_lambda] = _ao_lisp_atom_lambda, + [builtin_lexpr] = _ao_lisp_atom_lexpr, + [builtin_nlambda] = _ao_lisp_atom_nlambda, + [builtin_macro] = _ao_lisp_atom_macro, + [builtin_car] = _ao_lisp_atom_car, + [builtin_cdr] = _ao_lisp_atom_cdr, + [builtin_cons] = _ao_lisp_atom_cons, + [builtin_last] = _ao_lisp_atom_last, + [builtin_quote] = _ao_lisp_atom_quote, + [builtin_set] = _ao_lisp_atom_set, + [builtin_setq] = _ao_lisp_atom_setq, + [builtin_cond] = _ao_lisp_atom_cond, + [builtin_print] = _ao_lisp_atom_print, + [builtin_patom] = _ao_lisp_atom_patom, + [builtin_plus] = _ao_lisp_atom_2b, + [builtin_minus] = _ao_lisp_atom_2d, + [builtin_times] = _ao_lisp_atom_2a, + [builtin_divide] = _ao_lisp_atom_2f, + [builtin_mod] = _ao_lisp_atom_25, + [builtin_equal] = _ao_lisp_atom_3d, + [builtin_less] = _ao_lisp_atom_3c, + [builtin_greater] = _ao_lisp_atom_3e, + [builtin_less_equal] = _ao_lisp_atom_3c3d, + [builtin_greater_equal] = _ao_lisp_atom_3e3d, +}; + +static char * +ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { + if (0 <= b && b < _builtin_last) + return ao_lisp_poly_atom(builtin_names[b])->name; + return "???"; +} + +static const ao_poly ao_lisp_args_atoms[] = { + [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, + [AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr, + [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, + [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, +}; + +char * +ao_lisp_args_name(uint8_t args) +{ + if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0]) + return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name; + return "(unknown)"; +} +#endif + void ao_lisp_builtin_print(ao_poly b) { - (void) b; - printf("[builtin]"); + struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); + printf("[builtin %s %s]", + ao_lisp_args_name(builtin->args), + ao_lisp_builtin_name(builtin->func)); } ao_poly @@ -116,6 +176,24 @@ ao_lisp_cons(struct ao_lisp_cons *cons) return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); } +ao_poly +ao_lisp_last(struct ao_lisp_cons *cons) +{ + ao_poly l; + if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + l = ao_lisp_arg(cons, 0); + while (l) { + struct ao_lisp_cons *list = ao_lisp_poly_cons(l); + if (!list->cdr) + return list->car; + l = list->cdr; + } + return AO_LISP_NIL; +} + ao_poly ao_lisp_quote(struct ao_lisp_cons *cons) { @@ -151,15 +229,6 @@ ao_lisp_setq(struct ao_lisp_cons *cons) ao_poly ao_lisp_cond(struct ao_lisp_cons *cons) { - int argc; - struct ao_lisp_cons *arg; - - argc = 0; - for (arg = cons, argc = 0; arg; arg = ao_lisp_poly_cons(arg->cdr), argc++) { - if (ao_lisp_poly_type(arg->car) != AO_LISP_CONS) - return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", - ao_lisp_poly_atom(_ao_lisp_atom_cond)->name, argc); - } ao_lisp_set_cond(cons); return AO_LISP_NIL; } @@ -380,9 +449,14 @@ ao_lisp_greater_equal(struct ao_lisp_cons *cons) } ao_lisp_func_t ao_lisp_builtins[] = { + [builtin_lambda] = ao_lisp_lambda, + [builtin_lexpr] = ao_lisp_lexpr, + [builtin_nlambda] = ao_lisp_nlambda, + [builtin_macro] = ao_lisp_macro, [builtin_car] = ao_lisp_car, [builtin_cdr] = ao_lisp_cdr, [builtin_cons] = ao_lisp_cons, + [builtin_last] = ao_lisp_last, [builtin_quote] = ao_lisp_quote, [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 5ca89bd4..621fefc4 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -1,7 +1,129 @@ -cadr (lambda (l) (car (cdr l))) -caddr (lambda (l) (car (cdr (cdr l)))) -list (lexpr (l) l) -1+ (lambda (x) (+ x 1)) -1- (lambda (x) (- x 1)) -last (lambda (x) (cond ((cdr x) (last (cdr x))) ((car x)))) -prog* (lexpr (l) (last l)) + ; basic list accessors + + +(setq cadr (lambda (l) (car (cdr l)))) +(setq caddr (lambda (l) (car (cdr (cdr l))))) +(setq list (lexpr (l) l)) + + ; evaluate a list of sexprs + +(setq progn (lexpr (l) (last l))) + + ; simple math operators + +(setq 1+ (lambda (x) (+ x 1))) +(setq 1- (lambda (x) (- x 1))) + + ; define a variable without returning the value + +(set 'def (macro (def-param) + (list + 'progn + (list + 'set + (list + 'quote + (car def-param)) + (cadr def-param) + ) + (list + 'quote + (car def-param) + ) + ) + ) + ) + + ; define a set of local + ; variables and then evaluate + ; a list of sexprs + ; + ; (let (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let ((x 1) (y)) (setq y (+ x 1)) y) + +(def let (macro (let-param) + ((lambda (vars exprs make-names make-exprs make-nils) + (progn + + ; + ; make the list of names in the let + ; + + (set 'make-names (lambda (vars) + (cond (vars + (cons (car (car vars)) + (make-names (cdr vars)))) + ) + ) + ) + ; + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + ; + (set 'make-exprs (lambda (vars exprs) + (progn + (cond (vars (cons + (list set + (list quote + (car (car vars)) + ) + (cadr (car vars)) + ) + (make-exprs (cdr vars) exprs) + ) + ) + (exprs) + ) + ) + ) + ) + (set 'exprs (make-exprs vars exprs)) + + ; + ; the parameters to the lambda is a list + ; of nils of the right length + ; + (set 'make-nils (lambda (vars) + (cond (vars (cons nil (make-nils (cdr vars)))) + ) + ) + ) + ; + ; build the lambda. + ; + (set 'last-let-value + (cons + (list + 'lambda + (make-names vars) + (cond ((cdr exprs) (cons 'progn exprs)) + ((car exprs)) + ) + ) + (make-nils vars) + ) + ) + ) + + ) + (car let-param) + (cdr let-param) + () + () + () + ) + ) + ) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index ea8111d9..cedc107c 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -15,6 +15,86 @@ #include "ao_lisp.h" #include +static void +ao_lisp_error_cons(char *name, struct ao_lisp_cons *cons) +{ + int first = 1; + printf("\t\t%s(", name); + if (cons) { + while (cons) { + if (!first) + printf("\t\t "); + else + first = 0; + ao_lisp_poly_print(cons->car); + printf("\n"); + cons = ao_lisp_poly_cons(cons->cdr); + } + printf("\t\t )\n"); + } else + printf(")\n"); +} + +static void tabs(int indent) +{ + while (indent--) + printf("\t"); +} + +static void +ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) +{ + int f; + + tabs(indent); + printf ("%s{", name); + if (frame) { + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + printf("\n"); + } + if (frame->next) + ao_lisp_error_frame(indent + 1, "next: ", ao_lisp_poly_frame(frame->next)); + } + tabs(indent); + printf(" }\n"); +} + +static const char *state_names[] = { + "sexpr", + "val", + "formal", + "exec", + "cond", + "cond_test", +}; + +void +ao_lisp_stack_print(void) +{ + struct ao_lisp_stack *s; + printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + ao_lisp_error_frame(0, "Frame: ", ao_lisp_frame_current); + printf("Stack:\n"); + for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { + printf("\t[\n"); + printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); + printf("\t\tstate: %s\n", state_names[s->state]); + printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); + ao_lisp_error_cons ("sexprs: ", ao_lisp_poly_cons(s->sexprs)); + ao_lisp_error_cons ("values: ", ao_lisp_poly_cons(s->values)); + ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); + ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); + printf("\t]\n"); + } +} + ao_poly ao_lisp_error(int error, char *format, ...) { @@ -25,5 +105,6 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); + ao_lisp_stack_print(); return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index a5c74250..f4196219 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,60 +12,9 @@ * General Public License for more details. */ +#define DBG_EVAL 1 #include "ao_lisp.h" - -#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("%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) -#else -#define DBG_INDENT() -#define DBG_IN() -#define DBG_OUT() -#define DBG(...) -#define DBGI(...) -#define DBG_CONS(a) -#define DBG_POLY(a) -#endif - -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; -}; - -static struct ao_lisp_stack * -ao_lisp_poly_stack(ao_poly p) -{ - return ao_lisp_ref(p); -} - -static ao_poly -ao_lisp_stack_poly(struct ao_lisp_stack *stack) -{ - return ao_lisp_poly(stack, AO_LISP_OTHER); -} +#include static int stack_size(void *addr) @@ -79,10 +28,11 @@ stack_mark(void *addr) { struct ao_lisp_stack *stack = addr; for (;;) { - ao_lisp_poly_mark(stack->actuals, 0); - ao_lisp_poly_mark(stack->formals, 0); - /* no need to mark formals_tail */ + ao_lisp_poly_mark(stack->sexprs, 0); + ao_lisp_poly_mark(stack->values, 0); + /* no need to mark values_tail */ ao_lisp_poly_mark(stack->frame, 0); + ao_lisp_poly_mark(stack->macro_frame, 0); stack = ao_lisp_poly_stack(stack->prev); if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) break; @@ -91,29 +41,6 @@ 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) { @@ -122,15 +49,15 @@ stack_move(void *addr) while (stack) { void *prev; int ret; - (void) ao_lisp_poly_move(&stack->actuals, 0); - (void) ao_lisp_poly_move(&stack->formals, 0); - (void) ao_lisp_poly_move(&stack->formals_tail, 0); + (void) ao_lisp_poly_move(&stack->sexprs, 0); + (void) ao_lisp_poly_move(&stack->values, 0); + (void) ao_lisp_poly_move(&stack->values_tail, 0); (void) ao_lisp_poly_move(&stack->frame, 0); + (void) ao_lisp_poly_move(&stack->macro_frame, 0); 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); @@ -143,199 +70,421 @@ 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 +struct ao_lisp_stack *ao_lisp_stack; +ao_poly ao_lisp_v; 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); + ao_lisp_stack->sexprs = ao_lisp_cons_poly(c); return AO_LISP_NIL; } -void +static 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(); + stack->sexprs = AO_LISP_NIL; + stack->values = AO_LISP_NIL; + stack->values_tail = AO_LISP_NIL; } -int -ao_lisp_stack_push(void) +static void +ao_lisp_frames_dump(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"); + struct ao_lisp_stack *s; + DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { + DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); + DBGI(".. macro frame: "); DBG_POLY(s->frame); DBG("\n"); } +} + +static int +ao_lisp_stack_push(void) +{ DBGI("stack push\n"); DBG_IN(); struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); if (!stack) return 0; stack->prev = ao_lisp_stack_poly(ao_lisp_stack); + stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + stack->list = AO_LISP_NIL; ao_lisp_stack = stack; ao_lisp_stack_reset(stack); - stack_validate_tails(); + ao_lisp_frames_dump(); return 1; } -void +static void ao_lisp_stack_pop(void) { if (!ao_lisp_stack) return; - stack_validate_tails(); + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); 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; - if (ao_lisp_stack) { - DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); - } + ao_lisp_frames_dump(); } static void ao_lisp_stack_clear(void) { - stack_validate_tails(); ao_lisp_stack = NULL; ao_lisp_frame_current = NULL; + ao_lisp_v = AO_LISP_NIL; } -static ao_poly +static int func_type(ao_poly func) { - struct ao_lisp_cons *cons; - struct ao_lisp_cons *args; - int f; - - 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); - } - args = ao_lisp_poly_cons(args->cdr); - f++; - } - return ao_lisp_arg(cons, 0); - } else { + switch (ao_lisp_poly_type(func)) { + case AO_LISP_BUILTIN: + return ao_lisp_poly_builtin(func)->args; + case AO_LISP_LAMBDA: + return ao_lisp_poly_lambda(func)->args; + default: ao_lisp_error(AO_LISP_INVALID, "not a func"); - abort(); - return AO_LISP_NIL; + return -1; } } +/* + * Flattened eval to avoid stack issues + */ + +/* + * Evaluate an s-expression + * + * For a list, evaluate all of the elements and + * then execute the resulting function call. + * + * Each element of the list is evaluated in + * a clean stack context. + * + * The current stack state is set to 'formal' so that + * when the evaluation is complete, the value + * will get appended to the values list. + * + * For other types, compute the value directly. + */ + static int -ao_lisp_cons_length(struct ao_lisp_cons *cons) +ao_lisp_eval_sexpr(void) { - int len = 0; - while (cons) { - len++; - cons = ao_lisp_poly_cons(cons->cdr); + 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) { + if (!ao_lisp_stack->values) { + /* + * empty list evaluates to empty list + */ + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + /* + * done with arguments, go execute it + */ + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; + ao_lisp_stack->state = eval_exec; + } + } else { + if (!ao_lisp_stack->values) + ao_lisp_stack->list = ao_lisp_v; + /* + * Evaluate another argument and then switch + * to 'formal' to add the value to the values + * list + */ + ao_lisp_stack->sexprs = ao_lisp_v; + ao_lisp_stack->state = eval_formal; + if (!ao_lisp_stack_push()) + return 0; + /* + * push will reset the state to 'sexpr', which + * will evaluate the expression + */ + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + } + break; + case AO_LISP_ATOM: + DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); + /* fall through */ + case AO_LISP_INT: + case AO_LISP_STRING: + case AO_LISP_BUILTIN: + case AO_LISP_LAMBDA: + ao_lisp_stack->state = eval_val; + break; } - return len; + DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n"); + return 1; } -static ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons) +/* + * A value has been computed. + * + * If the value was computed from a macro, + * then we want to reset the current context + * to evaluate the macro result again. + * + * If not a macro, then pop the stack. + * If the stack is empty, we're done. + * Otherwise, the stack will contain + * the next state. + */ + +static int +ao_lisp_eval_val(void) { - 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; + DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); + if (ao_lisp_stack->macro) { + DBGI("..macro %d\n", ao_lisp_stack->macro); + DBGI("..current frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI("..saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + DBGI("..macro frame "); DBG_POLY(ao_lisp_stack->macro_frame); DBG("\n"); + DBGI("..sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI("..values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + /* + * Re-use the current stack to evaluate + * the value from the macro + */ + ao_lisp_stack->state = eval_sexpr; +// assert(ao_lisp_stack->frame == ao_lisp_stack->macro_frame); + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->macro_frame); + ao_lisp_stack->frame = ao_lisp_stack->macro_frame; + ao_lisp_stack->macro = 0; + ao_lisp_stack->macro_frame = AO_LISP_NIL; + ao_lisp_stack->sexprs = AO_LISP_NIL; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; + } else { + /* + * Value computed, pop the stack + * to figure out what to do with the value + */ + ao_lisp_stack_pop(); + } + DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1); + return 1; +} - 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)); +/* + * A formal has been computed. + * + * If this is the first formal, then + * check to see if we've got a lamda/lexpr or + * macro/nlambda. + * + * For lambda/lexpr, go compute another formal. + * This will terminate when the sexpr state + * sees nil. + * + * For macro/nlambda, we're done, so move the + * sexprs into the values and go execute it. + */ - args_wanted = ao_lisp_cons_length(args); +static int +ao_lisp_eval_formal(void) +{ + ao_poly formal; - /* 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); + DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); + + /* Check what kind of function we've got */ + if (!ao_lisp_stack->values) { + switch (func_type(ao_lisp_v)) { + case AO_LISP_FUNC_LAMBDA: + case AO_LISP_FUNC_LEXPR: + DBGI(".. lambda or lexpr\n"); + break; + case AO_LISP_FUNC_MACRO: + ao_lisp_stack->macro = 1; + DBGI(".. macro %d\n", ao_lisp_stack->macro); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + ao_lisp_stack->macro_frame = ao_lisp_stack->frame; + /* fall through ... */ + case AO_LISP_FUNC_NLAMBDA: + DBGI(".. nlambda or macro\n"); + ao_lisp_stack->values = ao_lisp_stack->sexprs; + ao_lisp_stack->values_tail = AO_LISP_NIL; + ao_lisp_stack->state = eval_exec; + return 1; + case -1: + return 0; } - 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; + + /* Append formal to list of values */ + formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); + if (!formal) + return 0; + + if (ao_lisp_stack->values_tail) + ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal; + else + ao_lisp_stack->values = formal; + ao_lisp_stack->values_tail = formal; + + DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + + /* + * Step to the next argument, if this is last, then + * 'sexpr' will end up switching to 'exec' + */ + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + + ao_lisp_stack->state = eval_sexpr; + + DBGI(".. "); DBG_POLY(ao_lisp_v); DBG("\n"); + return 1; +} + +/* + * Start executing a function call + * + * Most builtins are easy, just call the function. + * 'cond' is magic; it sticks the list of clauses + * in 'sexprs' and switches to 'cond' state. That + * bit of magic is done in ao_lisp_set_cond. + * + * Lambdas build a new frame to hold the locals and + * then re-use the current stack context to evaluate + * the s-expression from the lambda. + */ + +static int +ao_lisp_eval_exec(void) +{ + ao_poly v; + DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); + ao_lisp_stack->sexprs = AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_v)) { + case AO_LISP_BUILTIN: + ao_lisp_stack->state = eval_val; + v = ao_lisp_func(ao_lisp_poly_builtin(ao_lisp_v)) ( + ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); + DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + ao_poly atom = ao_lisp_arg(cons, 1); + ao_poly val = ao_lisp_arg(cons, 2); + DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); + }); + ao_lisp_v = v; + DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; - case _ao_lisp_atom_macro: - next_frame->vals[0].atom = args->car; - next_frame->vals[0].val = ao_lisp_cons_poly(cons); + case AO_LISP_LAMBDA: + ao_lisp_stack->state = eval_sexpr; + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + ao_lisp_v = ao_lisp_lambda_eval(ao_lisp_poly_lambda(ao_lisp_v), + ao_lisp_poly_cons(ao_lisp_stack->values)); + DBGI(".. sexpr "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); 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); + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; + return 1; } +static int +ao_lisp_eval_lambda_done(void) +{ + DBGI("lambda_done: "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBG_STACK(); + return 1; +} + +/* + * Start evaluating the next cond clause + * + * If the list of clauses is empty, then + * the result of the cond is nil. + * + * Otherwise, set the current stack state to 'cond_test' and create a + * new stack context to evaluate the test s-expression. Once that's + * complete, we'll land in 'cond_test' to finish the clause. + */ +static int +ao_lisp_eval_cond(void) +{ + DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + if (!ao_lisp_stack->sexprs) { + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; + if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { + ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); + return 0; + } + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + ao_lisp_stack->state = eval_cond_test; + if (!ao_lisp_stack_push()) + return 0; + ao_lisp_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Finish a cond clause. + * + * Check the value from the test expression, if + * non-nil, then set up to evaluate the value expression. + * + * Otherwise, step to the next clause and go back to the 'cond' + * state + */ +static int +ao_lisp_eval_cond_test(void) +{ + DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + if (ao_lisp_v) { + struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); + struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); + + ao_lisp_stack->state = eval_val; + if (c) { + ao_lisp_v = c->car; + if (!ao_lisp_stack_push()) + return 0; + } + } else { + ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + ao_lisp_stack->state = eval_cond; + } + return 1; +} + +static int (*const evals[])(void) = { + [eval_sexpr] = ao_lisp_eval_sexpr, + [eval_val] = ao_lisp_eval_val, + [eval_formal] = ao_lisp_eval_formal, + [eval_exec] = ao_lisp_eval_exec, + [eval_cond] = ao_lisp_eval_cond, + [eval_cond_test] = ao_lisp_eval_cond_test, +}; + ao_poly ao_lisp_eval(ao_poly _v) { - ao_poly formal; + static uint8_t been_here; ao_lisp_v = _v; if (!been_here) { @@ -345,165 +494,16 @@ ao_lisp_eval(ao_poly _v) } if (!ao_lisp_stack_push()) - goto bail; - - for (;;) { - if (ao_lisp_exception) - goto bail; - switch (ao_lisp_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) { - ao_lisp_stack->state = eval_exec; - break; - } - 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: - ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); - /* fall through */ - case AO_LISP_INT: - case AO_LISP_STRING: - case AO_LISP_BUILTIN: - ao_lisp_stack->state = eval_val; - break; - } - break; - case eval_val: - 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; - - case eval_formal: - /* Check what kind of function we've got */ - 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_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"); - 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 (ao_lisp_stack->state == eval_exec_direct) - break; - } - - 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 (ao_lisp_stack->formals_tail) - ao_lisp_poly_cons(ao_lisp_stack->formals_tail)->cdr = formal; - else - ao_lisp_stack->formals = formal; - ao_lisp_stack->formals_tail = formal; - - DBGI("formals now "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; - - stack_validate_tails(); - ao_lisp_stack->state = eval_sexpr; + return AO_LISP_NIL; - break; - case eval_exec: - 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: 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 { - ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(ao_lisp_stack->formals)); - ao_lisp_stack_reset(ao_lisp_stack); - } - break; - 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 { - 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; - } - 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; - } - break; - 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 { - ao_lisp_stack->state = eval_val; - } - } else { - 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; - } - break; + while (ao_lisp_stack) { +// DBG_STACK(); + if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { + ao_lisp_stack_clear(); + return AO_LISP_NIL; } } -bail: - ao_lisp_stack_clear(); - return AO_LISP_NIL; + DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");}); + ao_lisp_frame_current = NULL; + return ao_lisp_v; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 8791c4de..7978f20a 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -100,6 +100,27 @@ const struct ao_lisp_type ao_lisp_frame_type = { .move = frame_move }; +void +ao_lisp_frame_print(ao_poly p) +{ + struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); + int f; + + printf ("{"); + if (frame) { + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + } + if (frame->next) + ao_lisp_poly_print(frame->next); + } + printf("}"); +} + ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f2e3cea1..501052b9 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -33,34 +33,32 @@ struct builtin_func { }; struct builtin_func funcs[] = { - "car", AO_LISP_LEXPR, builtin_car, - "cdr", AO_LISP_LEXPR, builtin_cdr, - "cons", AO_LISP_LEXPR, builtin_cons, - "quote", AO_LISP_NLAMBDA,builtin_quote, - "set", AO_LISP_LEXPR, builtin_set, - "setq", AO_LISP_MACRO, builtin_setq, - "cond", AO_LISP_NLAMBDA,builtin_cond, - "print", AO_LISP_LEXPR, builtin_print, - "patom", AO_LISP_LEXPR, builtin_patom, - "+", AO_LISP_LEXPR, builtin_plus, - "-", AO_LISP_LEXPR, builtin_minus, - "*", AO_LISP_LEXPR, builtin_times, - "/", AO_LISP_LEXPR, builtin_divide, - "%", AO_LISP_LEXPR, builtin_mod, - "=", AO_LISP_LEXPR, builtin_equal, - "<", AO_LISP_LEXPR, builtin_less, - ">", AO_LISP_LEXPR, builtin_greater, - "<=", AO_LISP_LEXPR, builtin_less_equal, - ">=", AO_LISP_LEXPR, builtin_greater_equal, + "lambda", AO_LISP_FUNC_NLAMBDA, builtin_lambda, + "lexpr", AO_LISP_FUNC_NLAMBDA, builtin_lexpr, + "nlambda", AO_LISP_FUNC_NLAMBDA, builtin_nlambda, + "macro", AO_LISP_FUNC_NLAMBDA, builtin_macro, + "car", AO_LISP_FUNC_LAMBDA, builtin_car, + "cdr", AO_LISP_FUNC_LAMBDA, builtin_cdr, + "cons", AO_LISP_FUNC_LAMBDA, builtin_cons, + "last", AO_LISP_FUNC_LAMBDA, builtin_last, + "quote", AO_LISP_FUNC_NLAMBDA, builtin_quote, + "set", AO_LISP_FUNC_LAMBDA, builtin_set, + "setq", AO_LISP_FUNC_MACRO, builtin_setq, + "cond", AO_LISP_FUNC_NLAMBDA, builtin_cond, + "print", AO_LISP_FUNC_LEXPR, builtin_print, + "patom", AO_LISP_FUNC_LEXPR, builtin_patom, + "+", AO_LISP_FUNC_LEXPR, builtin_plus, + "-", AO_LISP_FUNC_LEXPR, builtin_minus, + "*", AO_LISP_FUNC_LEXPR, builtin_times, + "/", AO_LISP_FUNC_LEXPR, builtin_divide, + "%", AO_LISP_FUNC_LEXPR, builtin_mod, + "=", AO_LISP_FUNC_LEXPR, builtin_equal, + "<", AO_LISP_FUNC_LEXPR, builtin_less, + ">", AO_LISP_FUNC_LEXPR, builtin_greater, + "<=", AO_LISP_FUNC_LEXPR, builtin_less_equal, + ">=", AO_LISP_FUNC_LEXPR, builtin_greater_equal, }; -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *c) -{ - (void) c; - return AO_LISP_NIL; -} - #define N_FUNC (sizeof funcs / sizeof funcs[0]) /* Syntactic atoms */ @@ -90,19 +88,18 @@ int main(int argc, char **argv) { int f, o, i; - ao_poly atom, val; + ao_poly sexpr, val; struct ao_lisp_atom *a; struct ao_lisp_builtin *b; int in_atom; printf("/*\n"); printf(" * Generated file, do not edit\n"); - ao_lisp_root_add(&ao_lisp_frame_type, &globals); - globals = ao_lisp_frame_new(0); for (f = 0; f < N_FUNC; f++) { b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); a = ao_lisp_atom_intern(funcs[f].name); - globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); + ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_builtin_poly(b)); } /* atoms for syntax */ @@ -110,23 +107,25 @@ main(int argc, char **argv) (void) ao_lisp_atom_intern(atoms[i]); /* boolean constants */ - a = ao_lisp_atom_intern("nil"); - globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL); + ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), + AO_LISP_NIL); a = ao_lisp_atom_intern("t"); - globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); + ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_atom_poly(a)); for (;;) { - atom = ao_lisp_read(); - if (!atom) + sexpr = ao_lisp_read(); + if (!sexpr) break; - val = ao_lisp_read(); - if (!val) - break; - if (ao_lisp_poly_type(atom) != AO_LISP_ATOM) { - fprintf(stderr, "input must be atom val pairs\n"); + printf ("sexpr: "); + ao_lisp_poly_print(sexpr); + printf("\n"); + val = ao_lisp_eval(sexpr); + if (ao_lisp_exception) exit(1); - } - globals = ao_lisp_frame_add(globals, atom, val); + printf("\t"); + ao_lisp_poly_print(val); + printf("\n"); } /* Reduce to referenced values */ @@ -136,7 +135,7 @@ main(int argc, char **argv) printf("#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); printf("extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); printf("#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); - printf("#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(globals)); + printf("#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index c11ec25d..476843d8 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -262,6 +262,7 @@ static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_ATOM] = &ao_lisp_atom_type, [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, + [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, }; diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index 3c081ee8..bfd75ae3 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -45,7 +45,15 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { [AO_LISP_BUILTIN] = { .print = ao_lisp_builtin_print, .patom = ao_lisp_builtin_print, - } + }, + [AO_LISP_FRAME] = { + .print = ao_lisp_frame_print, + .patom = ao_lisp_frame_print, + }, + [AO_LISP_LAMBDA] = { + .print = ao_lisp_lambda_print, + .patom = ao_lisp_lambda_print, + }, }; static const struct ao_lisp_funcs * diff --git a/src/test/Makefile b/src/test/Makefile index 8d617eea..7395e832 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -94,7 +94,7 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o \ ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o \ - ao_lisp_error.o + ao_lisp_lambda.o ao_lisp_error.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -- cgit v1.2.3 From 0ee44c8e4bf5dabe6a97bf76b366c8b767c387f8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 9 Nov 2016 11:13:58 -0800 Subject: altos/lisp: macros appear to work now Needed an extra stack frame to stash the pre-macro state. This simplified macro processing quite a bit; a macro now just evaluates the function and then sends that result to be evaluated again. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 37 ++++++++++------- src/lisp/ao_lisp_atom.c | 2 +- src/lisp/ao_lisp_error.c | 5 +-- src/lisp/ao_lisp_eval.c | 105 +++++++++++++++++++++++++---------------------- 4 files changed, 81 insertions(+), 68 deletions(-) (limited to 'src/lisp/ao_lisp_error.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 6a35d8ce..82ba5a20 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -78,6 +78,7 @@ extern uint16_t ao_lisp_top; #define AO_LISP_OOM 0x01 #define AO_LISP_DIVIDE_BY_ZERO 0x02 #define AO_LISP_INVALID 0x04 +#define AO_LISP_UNDEFINED 0x08 extern uint8_t ao_lisp_exception; @@ -156,28 +157,25 @@ ao_lisp_frame_poly(struct ao_lisp_frame *frame) { return ao_lisp_poly(frame, AO_LISP_OTHER); } -struct ao_lisp_stack { - ao_poly prev; - uint8_t state; - uint8_t macro; - ao_poly sexprs; - ao_poly values; - ao_poly values_tail; - ao_poly frame; - ao_poly macro_frame; - ao_poly list; -}; - enum eval_state { - eval_sexpr, + eval_sexpr, /* Evaluate an sexpr */ eval_val, eval_formal, eval_exec, - eval_lambda_done, eval_cond, eval_cond_test }; +struct ao_lisp_stack { + uint8_t state; /* enum eval_state */ + ao_poly prev; /* previous stack frame */ + ao_poly sexprs; /* expressions to evaluate */ + ao_poly values; /* values computed */ + ao_poly values_tail; /* end of the values list for easy appending */ + ao_poly frame; /* current lookup frame */ + ao_poly list; /* most recent function call */ +}; + static inline struct ao_lisp_stack * ao_lisp_poly_stack(ao_poly p) { @@ -559,6 +557,16 @@ int ao_lisp_stack_depth; #define DBG_POLY(a) ao_lisp_poly_print(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) #define DBG_STACK() ao_lisp_stack_print() +static inline void +ao_lisp_frames_dump(void) +{ + struct ao_lisp_stack *s; + DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { + DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); + } +} +#define DBG_FRAMES() ao_lisp_frames_dump() #else #define DBG_DO(a) #define DBG_INDENT() @@ -570,6 +578,7 @@ int ao_lisp_stack_depth; #define DBG_POLY(a) #define DBG_RESET() #define DBG_STACK() +#define DBG_FRAMES() #endif #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index d7cb1996..5c6d5a67 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -134,7 +134,7 @@ ao_lisp_atom_get(ao_poly atom) #endif if (ref) return *ref; - return AO_LISP_NIL; + return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); } ao_poly diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index cedc107c..8b9fe2d5 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -80,17 +80,16 @@ ao_lisp_stack_print(void) { struct ao_lisp_stack *s; printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); - ao_lisp_error_frame(0, "Frame: ", ao_lisp_frame_current); printf("Stack:\n"); for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { printf("\t[\n"); printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); printf("\t\tstate: %s\n", state_names[s->state]); - printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); +// printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); ao_lisp_error_cons ("sexprs: ", ao_lisp_poly_cons(s->sexprs)); ao_lisp_error_cons ("values: ", ao_lisp_poly_cons(s->values)); ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); - ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); +// ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); printf("\t]\n"); } } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index f4196219..f3372f2a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,7 +12,7 @@ * General Public License for more details. */ -#define DBG_EVAL 1 +#define DBG_EVAL 0 #include "ao_lisp.h" #include @@ -32,7 +32,6 @@ stack_mark(void *addr) ao_lisp_poly_mark(stack->values, 0); /* no need to mark values_tail */ ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->macro_frame, 0); stack = ao_lisp_poly_stack(stack->prev); if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) break; @@ -53,7 +52,6 @@ stack_move(void *addr) (void) ao_lisp_poly_move(&stack->values, 0); (void) ao_lisp_poly_move(&stack->values_tail, 0); (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->macro_frame, 0); prev = ao_lisp_poly_stack(stack->prev); ret = ao_lisp_move(&ao_lisp_stack_type, &prev); if (prev != ao_lisp_poly_stack(stack->prev)) @@ -85,28 +83,15 @@ static void ao_lisp_stack_reset(struct ao_lisp_stack *stack) { stack->state = eval_sexpr; - stack->macro = 0; stack->sexprs = AO_LISP_NIL; stack->values = AO_LISP_NIL; stack->values_tail = AO_LISP_NIL; } -static void -ao_lisp_frames_dump(void) -{ - struct ao_lisp_stack *s; - DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); - DBGI(".. macro frame: "); DBG_POLY(s->frame); DBG("\n"); - } -} static int ao_lisp_stack_push(void) { - DBGI("stack push\n"); - DBG_IN(); struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); if (!stack) return 0; @@ -115,7 +100,9 @@ ao_lisp_stack_push(void) stack->list = AO_LISP_NIL; ao_lisp_stack = stack; ao_lisp_stack_reset(stack); - ao_lisp_frames_dump(); + DBGI("stack push\n"); + DBG_IN(); + DBG_FRAMES(); return 1; } @@ -124,11 +111,14 @@ ao_lisp_stack_pop(void) { if (!ao_lisp_stack) return; - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); 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; DBG_OUT(); DBGI("stack pop\n"); - ao_lisp_frames_dump(); + DBG_FRAMES(); } static void @@ -246,19 +236,20 @@ static int ao_lisp_eval_val(void) { DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); +#if 0 if (ao_lisp_stack->macro) { - DBGI("..macro %d\n", ao_lisp_stack->macro); - DBGI("..current frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI("..saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - DBGI("..macro frame "); DBG_POLY(ao_lisp_stack->macro_frame); DBG("\n"); - DBGI("..sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI("..values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + DBGI(".. end macro %d\n", ao_lisp_stack->macro); + DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + ao_lisp_frames_dump(); + + ao_lisp_stack_pop(); +#if 0 /* * Re-use the current stack to evaluate * the value from the macro */ ao_lisp_stack->state = eval_sexpr; -// assert(ao_lisp_stack->frame == ao_lisp_stack->macro_frame); ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->macro_frame); ao_lisp_stack->frame = ao_lisp_stack->macro_frame; ao_lisp_stack->macro = 0; @@ -266,7 +257,10 @@ ao_lisp_eval_val(void) ao_lisp_stack->sexprs = AO_LISP_NIL; ao_lisp_stack->values = AO_LISP_NIL; ao_lisp_stack->values_tail = AO_LISP_NIL; - } else { +#endif + } else +#endif + { /* * Value computed, pop the stack * to figure out what to do with the value @@ -280,22 +274,25 @@ ao_lisp_eval_val(void) /* * A formal has been computed. * - * If this is the first formal, then - * check to see if we've got a lamda/lexpr or - * macro/nlambda. + * If this is the first formal, then check to see if we've got a + * lamda/lexpr or macro/nlambda. + * + * For lambda/lexpr, go compute another formal. This will terminate + * when the sexpr state sees nil. * - * For lambda/lexpr, go compute another formal. - * This will terminate when the sexpr state - * sees nil. + * For macro/nlambda, we're done, so move the sexprs into the values + * and go execute it. * - * For macro/nlambda, we're done, so move the - * sexprs into the values and go execute it. + * Macros have an additional step of saving a stack frame holding the + * macro value execution context, which then gets the result of the + * macro to run */ static int ao_lisp_eval_formal(void) { - ao_poly formal; + ao_poly formal; + struct ao_lisp_stack *prev; DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); @@ -307,17 +304,34 @@ ao_lisp_eval_formal(void) DBGI(".. lambda or lexpr\n"); break; case AO_LISP_FUNC_MACRO: - ao_lisp_stack->macro = 1; - DBGI(".. macro %d\n", ao_lisp_stack->macro); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - ao_lisp_stack->macro_frame = ao_lisp_stack->frame; + /* Evaluate the result once more */ + prev = ao_lisp_stack; + ao_lisp_stack->state = eval_sexpr; + if (!ao_lisp_stack_push()) + return 0; + + /* After the function returns, take that + * value and re-evaluate it + */ + ao_lisp_stack->state = eval_sexpr; + ao_lisp_stack->sexprs = prev->sexprs; + prev->sexprs = AO_LISP_NIL; + + DBGI(".. start macro\n"); + DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + DBG_FRAMES(); + /* fall through ... */ case AO_LISP_FUNC_NLAMBDA: DBGI(".. nlambda or macro\n"); + + /* use the raw sexprs as values */ ao_lisp_stack->values = ao_lisp_stack->sexprs; ao_lisp_stack->values_tail = AO_LISP_NIL; ao_lisp_stack->state = eval_exec; + + /* ready to execute now */ return 1; case -1: return 0; @@ -397,14 +411,6 @@ ao_lisp_eval_exec(void) return 1; } -static int -ao_lisp_eval_lambda_done(void) -{ - DBGI("lambda_done: "); DBG_POLY(ao_lisp_v); DBG("\n"); - DBG_STACK(); - return 1; -} - /* * Start evaluating the next cond clause * @@ -497,7 +503,6 @@ ao_lisp_eval(ao_poly _v) return AO_LISP_NIL; while (ao_lisp_stack) { -// DBG_STACK(); if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { ao_lisp_stack_clear(); return AO_LISP_NIL; -- cgit v1.2.3 From c7d7cdc2318a97534c4c1f9c6fd2b51644be729d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 10 Nov 2016 11:30:55 -0800 Subject: altos/lisp: add progn, while, read and eval Progn as a builtin will help with tail-recursion. while provides for loops until tail-recursion works :-) read and eval are kinda useful. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 11 +++++- src/lisp/ao_lisp_builtin.c | 41 +++++++++++++++++++++ src/lisp/ao_lisp_const.lisp | 2 +- src/lisp/ao_lisp_error.c | 1 + src/lisp/ao_lisp_eval.c | 84 ++++++++++++++++++++++++++++++++++++++++++- src/lisp/ao_lisp_make_const.c | 4 +++ 6 files changed, 140 insertions(+), 3 deletions(-) (limited to 'src/lisp/ao_lisp_error.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index de55b307..d265ea7b 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -40,6 +40,8 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_lambda _atom("lambda") #define _ao_lisp_atom_led _atom("led") #define _ao_lisp_atom_delay _atom("delay") +#define _ao_lisp_atom_eval _atom("eval") +#define _ao_lisp_atom_read _atom("read") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -158,7 +160,10 @@ enum eval_state { eval_formal, eval_exec, eval_cond, - eval_cond_test + eval_cond_test, + eval_progn, + eval_while, + eval_while_test, }; struct ao_lisp_stack { @@ -198,6 +203,8 @@ struct ao_lisp_builtin { }; enum ao_lisp_builtin_id { + builtin_eval, + builtin_read, builtin_lambda, builtin_lexpr, builtin_nlambda, @@ -210,6 +217,8 @@ enum ao_lisp_builtin_id { builtin_set, builtin_setq, builtin_cond, + builtin_progn, + builtin_while, builtin_print, builtin_patom, builtin_plus, diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 5bd180e2..57d9ee10 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -48,6 +48,8 @@ char *ao_lisp_args_name(uint8_t args) { } #else static const ao_poly builtin_names[] = { + [builtin_eval] = _ao_lisp_atom_eval, + [builtin_read] = _ao_lisp_atom_read, [builtin_lambda] = _ao_lisp_atom_lambda, [builtin_lexpr] = _ao_lisp_atom_lexpr, [builtin_nlambda] = _ao_lisp_atom_nlambda, @@ -60,6 +62,8 @@ static const ao_poly builtin_names[] = { [builtin_set] = _ao_lisp_atom_set, [builtin_setq] = _ao_lisp_atom_setq, [builtin_cond] = _ao_lisp_atom_cond, + [builtin_progn] = _ao_lisp_atom_progn, + [builtin_while] = _ao_lisp_atom_while, [builtin_print] = _ao_lisp_atom_print, [builtin_patom] = _ao_lisp_atom_patom, [builtin_plus] = _ao_lisp_atom_2b, @@ -235,6 +239,22 @@ ao_lisp_cond(struct ao_lisp_cons *cons) return AO_LISP_NIL; } +ao_poly +ao_lisp_progn(struct ao_lisp_cons *cons) +{ + ao_lisp_stack->state = eval_progn; + ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); + return AO_LISP_NIL; +} + +ao_poly +ao_lisp_while(struct ao_lisp_cons *cons) +{ + ao_lisp_stack->state = eval_while; + ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); + return AO_LISP_NIL; +} + ao_poly ao_lisp_print(struct ao_lisp_cons *cons) { @@ -476,7 +496,26 @@ ao_lisp_delay(struct ao_lisp_cons *cons) return delay; } +ao_poly +ao_lisp_do_eval(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_eval, cons, 1, 1)) + return AO_LISP_NIL; + ao_lisp_stack->state = eval_sexpr; + return cons->car; +} + +ao_poly +ao_lisp_do_read(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_read, cons, 0, 0)) + return AO_LISP_NIL; + return ao_lisp_read(); +} + const ao_lisp_func_t ao_lisp_builtins[] = { + [builtin_eval] = ao_lisp_do_eval, + [builtin_read] = ao_lisp_do_read, [builtin_lambda] = ao_lisp_lambda, [builtin_lexpr] = ao_lisp_lexpr, [builtin_nlambda] = ao_lisp_nlambda, @@ -489,6 +528,8 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, [builtin_cond] = ao_lisp_cond, + [builtin_progn] = ao_lisp_progn, + [builtin_while] = ao_lisp_while, [builtin_print] = ao_lisp_print, [builtin_patom] = ao_lisp_patom, [builtin_plus] = ao_lisp_plus, diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 08a511d9..c6f50e34 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -7,7 +7,7 @@ ; evaluate a list of sexprs -(setq progn (lexpr (l) (last l))) +;(setq progn (lexpr (l) (last l))) ; simple math operators diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 8b9fe2d5..cfa78d22 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -73,6 +73,7 @@ static const char *state_names[] = { "exec", "cond", "cond_test", + "progn", }; void diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index f3372f2a..c5addcb0 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,7 +12,7 @@ * General Public License for more details. */ -#define DBG_EVAL 0 +#define DBG_EVAL 1 #include "ao_lisp.h" #include @@ -478,6 +478,85 @@ ao_lisp_eval_cond_test(void) return 1; } +/* + * Evaluate a list of sexprs, returning the value from the last one. + * + * ao_lisp_progn records the list in stack->sexprs, so we just need to + * walk that list. Set ao_lisp_v to the car of the list and jump to + * eval_sexpr. When that's done, it will land in eval_val. For all but + * the last, leave a stack frame with eval_progn set so that we come + * back here. For the last, don't add a stack frame so that we can + * just continue on. + */ +static int +ao_lisp_eval_progn(void) +{ + DBGI("progn: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + + if (!ao_lisp_stack->sexprs) { + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; + ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + if (ao_lisp_stack->sexprs) { + ao_lisp_stack->state = eval_progn; + if (!ao_lisp_stack_push()) + return 0; + } + ao_lisp_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Conditionally execute a list of sexprs while the first is true + */ +static int +ao_lisp_eval_while(void) +{ + DBGI("while: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + + if (!ao_lisp_stack->sexprs) { + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; + ao_lisp_stack->state = eval_while_test; + if (!ao_lisp_stack_push()) + return 0; + ao_lisp_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Check the while condition, terminate the loop if nil. Otherwise keep going + */ +static int +ao_lisp_eval_while_test(void) +{ + DBGI("while_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + + if (ao_lisp_v) { + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + if (ao_lisp_v) + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + ao_lisp_stack->state = eval_while; + if (!ao_lisp_stack_push()) + return 0; + } + else + ao_lisp_stack->state = eval_val; + return 1; +} + static int (*const evals[])(void) = { [eval_sexpr] = ao_lisp_eval_sexpr, [eval_val] = ao_lisp_eval_val, @@ -485,6 +564,9 @@ static int (*const evals[])(void) = { [eval_exec] = ao_lisp_eval_exec, [eval_cond] = ao_lisp_eval_cond, [eval_cond_test] = ao_lisp_eval_cond_test, + [eval_progn] = ao_lisp_eval_progn, + [eval_while] = ao_lisp_eval_while, + [eval_while_test] = ao_lisp_eval_while_test, }; ao_poly diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 6f852f9d..bb4afbfb 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -33,6 +33,8 @@ struct builtin_func { }; struct builtin_func funcs[] = { + "eval", AO_LISP_FUNC_LAMBDA, builtin_eval, + "read", AO_LISP_FUNC_LAMBDA, builtin_read, "lambda", AO_LISP_FUNC_NLAMBDA, builtin_lambda, "lexpr", AO_LISP_FUNC_NLAMBDA, builtin_lexpr, "nlambda", AO_LISP_FUNC_NLAMBDA, builtin_nlambda, @@ -45,6 +47,8 @@ struct builtin_func funcs[] = { "set", AO_LISP_FUNC_LAMBDA, builtin_set, "setq", AO_LISP_FUNC_MACRO, builtin_setq, "cond", AO_LISP_FUNC_NLAMBDA, builtin_cond, + "progn", AO_LISP_FUNC_NLAMBDA, builtin_progn, + "while", AO_LISP_FUNC_NLAMBDA, builtin_while, "print", AO_LISP_FUNC_LEXPR, builtin_print, "patom", AO_LISP_FUNC_LEXPR, builtin_patom, "+", AO_LISP_FUNC_LEXPR, builtin_plus, -- cgit v1.2.3 From 881161fe1c5fb0e2b1220c30572eb2c45bedbafe Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 15 Nov 2016 20:18:59 -0800 Subject: altos/lisp: re-use small frames This saves a pile more use of the allocator by noting when frames have not been referenced from another frame and freeing them when they go out of scope. Frames with references are left to the allocator to deal with. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 37 +++++++++++++++++-- src/lisp/ao_lisp_atom.c | 4 +-- src/lisp/ao_lisp_error.c | 6 ++-- src/lisp/ao_lisp_eval.c | 6 +++- src/lisp/ao_lisp_frame.c | 91 +++++++++++++++++++++++++++++++---------------- src/lisp/ao_lisp_lambda.c | 4 +-- src/lisp/ao_lisp_mem.c | 8 +++++ 7 files changed, 116 insertions(+), 40 deletions(-) (limited to 'src/lisp/ao_lisp_error.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 2db4914f..bcb0a17f 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -156,13 +156,33 @@ struct ao_lisp_val { struct ao_lisp_frame { uint8_t type; - uint8_t num; - ao_poly next; + uint8_t _num; + ao_poly prev; struct ao_lisp_val vals[]; }; +#define AO_LISP_FRAME_NUM_MASK 0x7f + +/* Set when the frame escapes the lambda */ +#define AO_LISP_FRAME_MARK 0x80 + +static inline int ao_lisp_frame_num(struct ao_lisp_frame *f) { + if (f->_num == 0xff) + ao_lisp_abort(); + return f->_num & AO_LISP_FRAME_NUM_MASK; +} + +static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { + if (f->_num == 0xff) + ao_lisp_abort(); + return f->_num & AO_LISP_FRAME_MARK; +} + static inline struct ao_lisp_frame * ao_lisp_poly_frame(ao_poly poly) { + struct ao_lisp_frame *frame = ao_lisp_ref(poly); + if (frame && frame->_num == 0xff) + ao_lisp_abort(); return ao_lisp_ref(poly); } @@ -500,6 +520,9 @@ ao_lisp_atom_print(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); +ao_poly * +ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom); + ao_poly ao_lisp_atom_get(ao_poly atom); @@ -574,12 +597,22 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; +#define AO_LISP_FRAME_FREE 4 + +extern struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + +ao_poly +ao_lisp_frame_mark(struct ao_lisp_frame *frame); + ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); struct ao_lisp_frame * ao_lisp_frame_new(int num); +void +ao_lisp_frame_free(struct ao_lisp_frame *frame); + int ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 6705f140..8c9e8ed1 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -108,7 +108,7 @@ ao_lisp_atom_init(void) ao_lisp_frame_global = ao_lisp_frame_new(0); } -static ao_poly * +ao_poly * ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) { ao_poly *ref; @@ -117,7 +117,7 @@ ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) ref = ao_lisp_frame_ref(frame, atom); if (ref) return ref; - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); } if (ao_lisp_frame_global) { ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index cfa78d22..2b15c418 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -49,7 +49,7 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { if (f != 0) { tabs(indent); printf(" "); @@ -59,8 +59,8 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) ao_lisp_poly_print(frame->vals[f].val); printf("\n"); } - if (frame->next) - ao_lisp_error_frame(indent + 1, "next: ", ao_lisp_poly_frame(frame->next)); + if (frame->prev) + ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); } tabs(indent); printf(" }\n"); diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 3af56796..6f56a120 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -122,7 +122,8 @@ ao_lisp_stack_push(void) static void ao_lisp_stack_pop(void) { - ao_poly prev; + ao_poly prev; + struct ao_lisp_frame *prev_frame; if (!ao_lisp_stack) return; @@ -131,10 +132,13 @@ ao_lisp_stack_pop(void) ao_lisp_stack_free_list = ao_lisp_stack; ao_lisp_stack = ao_lisp_poly_stack(prev); + prev_frame = ao_lisp_frame_current; if (ao_lisp_stack) ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); else ao_lisp_frame_current = NULL; + if (ao_lisp_frame_current != prev_frame) + ao_lisp_frame_free(prev_frame); DBG_OUT(); DBGI("stack pop\n"); DBG_FRAMES(); diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index e23a6413..052d27d7 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -24,7 +24,7 @@ static int frame_size(void *addr) { struct ao_lisp_frame *frame = addr; - return frame_num_size(frame->num); + return frame_num_size(ao_lisp_frame_num(frame)); } static void @@ -37,7 +37,7 @@ frame_mark(void *addr) MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_mark(v->val, 0); @@ -46,7 +46,7 @@ frame_mark(void *addr) MDBG_OFFSET(ao_lisp_ref(v->atom)), MDBG_OFFSET(ao_lisp_ref(v->val)), f); } - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); if (!frame) break; @@ -62,13 +62,13 @@ frame_move(void *addr) int f; for (;;) { - struct ao_lisp_frame *next; + struct ao_lisp_frame *prev; int ret; MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_move(&v->atom, 0); @@ -78,19 +78,19 @@ frame_move(void *addr) MDBG_OFFSET(ao_lisp_ref(v->atom)), MDBG_OFFSET(ao_lisp_ref(v->val)), f); } - next = ao_lisp_poly_frame(frame->next); - if (!next) + prev = ao_lisp_poly_frame(frame->prev); + if (!prev) break; - ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &next); - if (next != ao_lisp_poly_frame(frame->next)) { - MDBG_MOVE("frame next moved from %d to %d\n", - MDBG_OFFSET(ao_lisp_poly_frame(frame->next)), - MDBG_OFFSET(next)); - frame->next = ao_lisp_frame_poly(next); + ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &prev); + if (prev != ao_lisp_poly_frame(frame->prev)) { + MDBG_MOVE("frame prev moved from %d to %d\n", + MDBG_OFFSET(ao_lisp_poly_frame(frame->prev)), + MDBG_OFFSET(prev)); + frame->prev = ao_lisp_frame_poly(prev); } if (ret) break; - frame = next; + frame = prev; } } @@ -109,15 +109,15 @@ ao_lisp_frame_print(ao_poly p) printf ("{"); if (frame) { - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { if (f != 0) printf(", "); ao_lisp_poly_print(frame->vals[f].atom); printf(" = "); ao_lisp_poly_print(frame->vals[f].val); } - if (frame->next) - ao_lisp_poly_print(frame->next); + if (frame->prev) + ao_lisp_poly_print(frame->prev); } printf("}"); } @@ -126,7 +126,7 @@ ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; - for (f = 0; f < frame->num; f++) + for (f = 0; f < ao_lisp_frame_num(frame); f++) if (frame->vals[f].atom == atom) return &frame->vals[f].val; return NULL; @@ -143,7 +143,7 @@ ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) return 1; } } - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); } return 0; } @@ -155,25 +155,55 @@ ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) ao_poly *ref = ao_lisp_frame_ref(frame, atom); if (ref) return *ref; - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); } return AO_LISP_NIL; } +struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + struct ao_lisp_frame * ao_lisp_frame_new(int num) { - struct ao_lisp_frame *frame = ao_lisp_alloc(frame_num_size(num)); + struct ao_lisp_frame *frame; - if (!frame) - return NULL; + if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) + ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); + else { + frame = ao_lisp_alloc(frame_num_size(num)); + if (!frame) + return NULL; + } frame->type = AO_LISP_FRAME; - frame->num = num; - frame->next = AO_LISP_NIL; + frame->_num = num; + frame->prev = AO_LISP_NIL; memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); return frame; } +ao_poly +ao_lisp_frame_mark(struct ao_lisp_frame *frame) +{ + if (!frame) + return AO_LISP_NIL; + if (frame->_num == 0xff) + ao_lisp_abort(); + frame->_num |= AO_LISP_FRAME_MARK; + return ao_lisp_frame_poly(frame); +} + +void +ao_lisp_frame_free(struct ao_lisp_frame *frame) +{ + if (!ao_lisp_frame_marked(frame)) { + int num = ao_lisp_frame_num(frame); + if (num < AO_LISP_FRAME_FREE) { + frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); + ao_lisp_frame_free_list[num] = frame; + } + } +} + static struct ao_lisp_frame * ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) { @@ -181,7 +211,7 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) struct ao_lisp_frame *new; int copy; - if (new_num == frame->num) + if (new_num == ao_lisp_frame_num(frame)) return frame; new = ao_lisp_frame_new(new_num); if (!new) @@ -192,10 +222,11 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) */ frame = *frame_ref; copy = new_num; - if (copy > frame->num) - copy = frame->num; + if (copy > ao_lisp_frame_num(frame)) + copy = ao_lisp_frame_num(frame); memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); - new->next = frame->next; + new->prev = frame->prev; + ao_lisp_frame_free(frame); return new; } @@ -210,7 +241,7 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); if (frame) { - f = frame->num; + f = ao_lisp_frame_num(frame); frame = ao_lisp_frame_realloc(frame_ref, f + 1); } else { f = 0; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 0dd8c698..8b761714 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -94,7 +94,7 @@ ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) lambda->type = AO_LISP_LAMBDA; lambda->args = args; lambda->code = ao_lisp_cons_poly(code); - lambda->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current); DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); DBG_STACK(); return ao_lisp_lambda_poly(lambda); @@ -179,7 +179,7 @@ ao_lisp_lambda_eval(void) next_frame->vals[0].val = cons->cdr; break; } - next_frame->next = lambda->frame; + next_frame->prev = lambda->frame; DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); ao_lisp_frame_current = next_frame; ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index e7ece960..7e7464c4 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -214,8 +214,16 @@ static const struct ao_lisp_root ao_lisp_root[] = { static const void ** const ao_lisp_cache[] = { (const void **) &ao_lisp_cons_free_list, (const void **) &ao_lisp_stack_free_list, + (const void **) &ao_lisp_frame_free_list[0], + (const void **) &ao_lisp_frame_free_list[1], + (const void **) &ao_lisp_frame_free_list[2], + (const void **) &ao_lisp_frame_free_list[3], }; +#if AO_LISP_FRAME_FREE != 4 +#error Unexpected AO_LISP_FRAME_FREE value +#endif + #define AO_LISP_CACHE (sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) #define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) -- cgit v1.2.3 From 84732aebd10c293101727ba567bfc733dc30efca Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 17 Nov 2016 16:06:05 -0800 Subject: altos/lisp: Dump globals on error Useful for debugging Signed-off-by: Keith Packard --- src/lisp/ao_lisp_error.c | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src/lisp/ao_lisp_error.c') diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 2b15c418..7ad7b2b5 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -106,5 +106,8 @@ ao_lisp_error(int error, char *format, ...) va_end(args); printf("\n"); ao_lisp_stack_print(); + printf("Globals:\n\t"); + ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); + printf("\n"); return AO_LISP_NIL; } -- cgit v1.2.3 From 11c79167cdd56015bbd1645db2d4394dcb4f0fbb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 17 Nov 2016 16:52:30 -0800 Subject: altos/lisp: have 'while' return the last body value Instead of always returning 'nil', let while return the last body value. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_error.c | 39 +++++++++++++++++++++++---------------- src/lisp/ao_lisp_eval.c | 5 +++++ 2 files changed, 28 insertions(+), 16 deletions(-) (limited to 'src/lisp/ao_lisp_error.c') diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 7ad7b2b5..937739e9 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -16,23 +16,30 @@ #include static void -ao_lisp_error_cons(char *name, struct ao_lisp_cons *cons) +ao_lisp_error_poly(char *name, ao_poly poly) { int first = 1; printf("\t\t%s(", name); - if (cons) { - while (cons) { - if (!first) - printf("\t\t "); - else - first = 0; - ao_lisp_poly_print(cons->car); - printf("\n"); - cons = ao_lisp_poly_cons(cons->cdr); - } - printf("\t\t )\n"); - } else - printf(")\n"); + if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); + + if (cons) { + while (cons) { + if (!first) + printf("\t\t "); + else + first = 0; + ao_lisp_poly_print(cons->car); + printf("\n"); + cons = ao_lisp_poly_cons(cons->cdr); + } + printf("\t\t )\n"); + } else + printf(")\n"); + } else { + ao_lisp_poly_print(poly); + printf("\n"); + } } static void tabs(int indent) @@ -87,8 +94,8 @@ ao_lisp_stack_print(void) printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); printf("\t\tstate: %s\n", state_names[s->state]); // printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); - ao_lisp_error_cons ("sexprs: ", ao_lisp_poly_cons(s->sexprs)); - ao_lisp_error_cons ("values: ", ao_lisp_poly_cons(s->values)); + ao_lisp_error_poly ("sexprs: ", s->sexprs); + ao_lisp_error_poly ("values: ", s->values); ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); // ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); printf("\t]\n"); diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 5fa9e0ad..ef521605 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -525,6 +525,7 @@ ao_lisp_eval_while(void) DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + ao_lisp_stack->values = ao_lisp_v; if (!ao_lisp_stack->sexprs) { ao_lisp_v = AO_LISP_NIL; ao_lisp_stack->state = eval_val; @@ -548,6 +549,7 @@ ao_lisp_eval_while_test(void) DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); if (ao_lisp_v) { + ao_lisp_stack->values = ao_lisp_v; ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; ao_lisp_stack->state = eval_while; if (!ao_lisp_stack_push()) @@ -556,7 +558,10 @@ ao_lisp_eval_while_test(void) ao_lisp_stack->sexprs = ao_lisp_v; } else + { ao_lisp_stack->state = eval_val; + ao_lisp_v = ao_lisp_stack->values; + } return 1; } -- cgit v1.2.3 From e600fc409c577eec02af612a36431c477a9c875e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 19:04:05 -0800 Subject: altos/lisp: Add continuations This provides call/cc and makes 'stacks' visible to the application. Signed-off-by: Keith Packard --- src/lisp/Makefile | 1 + src/lisp/ao_lisp.h | 77 +++++++++--- src/lisp/ao_lisp_builtin.c | 6 +- src/lisp/ao_lisp_error.c | 82 +++++-------- src/lisp/ao_lisp_eval.c | 151 ++++------------------- src/lisp/ao_lisp_frame.c | 44 ++++--- src/lisp/ao_lisp_lambda.c | 3 +- src/lisp/ao_lisp_make_const.c | 3 +- src/lisp/ao_lisp_mem.c | 28 +++++ src/lisp/ao_lisp_poly.c | 4 + src/lisp/ao_lisp_stack.c | 279 ++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 461 insertions(+), 217 deletions(-) create mode 100644 src/lisp/ao_lisp_stack.c (limited to 'src/lisp/ao_lisp_error.c') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 15297999..dd5a0cb4 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -21,6 +21,7 @@ SRCS=\ ao_lisp_eval.c \ ao_lisp_rep.c \ ao_lisp_save.c \ + ao_lisp_stack.c \ ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index bcefbabf..a8e1715a 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -75,6 +75,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_eof _atom("eof") #define _ao_lisp_atom_save _atom("save") #define _ao_lisp_atom_restore _atom("restore") +#define _ao_lisp_atom_call2fcc _atom("call/cc") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -99,7 +100,11 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA]; #define AO_LISP_BUILTIN 5 #define AO_LISP_FRAME 6 #define AO_LISP_LAMBDA 7 -#define AO_LISP_NUM_TYPE 8 +#define AO_LISP_STACK 8 +#define AO_LISP_NUM_TYPE 9 + +/* Leave two bits for types to use as they please */ +#define AO_LISP_OTHER_TYPE_MASK 0x3f #define AO_LISP_NIL 0 @@ -153,22 +158,17 @@ struct ao_lisp_val { struct ao_lisp_frame { uint8_t type; - uint8_t _num; + uint8_t num; ao_poly prev; struct ao_lisp_val vals[]; }; -#define AO_LISP_FRAME_NUM_MASK 0x7f - -/* Set when the frame escapes the lambda */ +/* Set on type when the frame escapes the lambda */ #define AO_LISP_FRAME_MARK 0x80 - -static inline int ao_lisp_frame_num(struct ao_lisp_frame *f) { - return f->_num & AO_LISP_FRAME_NUM_MASK; -} +#define AO_LISP_FRAME_PRINT 0x40 static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { - return f->_num & AO_LISP_FRAME_MARK; + return f->type & AO_LISP_FRAME_MARK; } static inline struct ao_lisp_frame * @@ -195,6 +195,7 @@ enum eval_state { }; struct ao_lisp_stack { + uint8_t type; /* AO_LISP_STACK */ uint8_t state; /* enum eval_state */ ao_poly prev; /* previous stack frame */ ao_poly sexprs; /* expressions to evaluate */ @@ -204,6 +205,17 @@ struct ao_lisp_stack { ao_poly list; /* most recent function call */ }; +#define AO_LISP_STACK_MARK 0x80 /* set on type when a reference has been taken */ +#define AO_LISP_STACK_PRINT 0x40 /* stack is being printed */ + +static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) { + return s->type & AO_LISP_STACK_MARK; +} + +static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) { + s->type |= AO_LISP_STACK_MARK; +} + static inline struct ao_lisp_stack * ao_lisp_poly_stack(ao_poly p) { @@ -216,8 +228,6 @@ ao_lisp_stack_poly(struct ao_lisp_stack *stack) return ao_lisp_poly(stack, AO_LISP_OTHER); } -extern struct ao_lisp_stack *ao_lisp_stack; -extern struct ao_lisp_stack *ao_lisp_stack_free_list; extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_LAMBDA 0 @@ -276,6 +286,7 @@ enum ao_lisp_builtin_id { builtin_led, builtin_save, builtin_restore, + builtin_call_cc, _builtin_last }; @@ -315,7 +326,7 @@ ao_lisp_poly_other(ao_poly poly) { static inline uint8_t ao_lisp_other_type(void *other) { - return *((uint8_t *) other); + return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; } static inline ao_poly @@ -455,6 +466,12 @@ ao_lisp_string_stash(int id, char *string); char * ao_lisp_string_fetch(int id); +void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack); + +struct ao_lisp_stack * +ao_lisp_stack_fetch(int id); + void ao_lisp_poly_stash(int id, ao_poly poly); @@ -617,6 +634,8 @@ ao_lisp_frame_print(ao_poly p); /* lambda */ extern const struct ao_lisp_type ao_lisp_lambda_type; +extern const char *ao_lisp_state_names[]; + struct ao_lisp_lambda * ao_lisp_lambda_new(ao_poly cons); @@ -646,12 +665,40 @@ ao_lisp_save(struct ao_lisp_cons *cons); ao_poly ao_lisp_restore(struct ao_lisp_cons *cons); -/* error */ +/* stack */ extern const struct ao_lisp_type ao_lisp_stack_type; +extern struct ao_lisp_stack *ao_lisp_stack; +extern struct ao_lisp_stack *ao_lisp_stack_free_list; + +void +ao_lisp_stack_reset(struct ao_lisp_stack *stack); + +int +ao_lisp_stack_push(void); + +void +ao_lisp_stack_pop(void); + +void +ao_lisp_stack_clear(void); + +void +ao_lisp_stack_print(ao_poly stack); + +ao_poly +ao_lisp_stack_eval(void); + +ao_poly +ao_lisp_call_cc(struct ao_lisp_cons *cons); + +/* error */ + +void +ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); void -ao_lisp_stack_print(void); +ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); ao_poly ao_lisp_error(int error, char *format, ...); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6cbcb92c..4c845307 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -86,6 +86,7 @@ static const ao_poly builtin_names[] = { [builtin_led] = _ao_lisp_atom_led, [builtin_save] = _ao_lisp_atom_save, [builtin_restore] = _ao_lisp_atom_restore, + [builtin_call_cc] = _ao_lisp_atom_call2fcc, }; @@ -117,9 +118,7 @@ void ao_lisp_builtin_print(ao_poly b) { struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); - printf("[builtin %s %s]", - ao_lisp_args_name(builtin->args), - ao_lisp_builtin_name(builtin->func)); + printf("%s", ao_lisp_builtin_name(builtin->func)); } ao_poly @@ -599,5 +598,6 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_delay] = ao_lisp_delay, [builtin_save] = ao_lisp_save, [builtin_restore] = ao_lisp_restore, + [builtin_call_cc] = ao_lisp_call_cc, }; diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 937739e9..54a9be10 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -15,23 +15,24 @@ #include "ao_lisp.h" #include -static void -ao_lisp_error_poly(char *name, ao_poly poly) +void +ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) { int first = 1; printf("\t\t%s(", name); if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); - - if (cons) { - while (cons) { + if (poly) { + while (poly) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); if (!first) printf("\t\t "); else first = 0; ao_lisp_poly_print(cons->car); printf("\n"); - cons = ao_lisp_poly_cons(cons->cdr); + if (poly == last) + break; + poly = cons->cdr; } printf("\t\t )\n"); } else @@ -48,7 +49,7 @@ static void tabs(int indent) printf("\t"); } -static void +void ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) { int f; @@ -56,51 +57,30 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { - for (f = 0; f < ao_lisp_frame_num(frame); f++) { - if (f != 0) { - tabs(indent); - printf(" "); + if (frame->type & AO_LISP_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_LISP_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + printf("\n"); } - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); - printf("\n"); + if (frame->prev) + ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); + frame->type &= ~AO_LISP_FRAME_PRINT; } - if (frame->prev) - ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); - } - tabs(indent); - printf(" }\n"); + tabs(indent); + printf(" }\n"); + } else + printf ("}\n"); } -static const char *state_names[] = { - "sexpr", - "val", - "formal", - "exec", - "cond", - "cond_test", - "progn", -}; - -void -ao_lisp_stack_print(void) -{ - struct ao_lisp_stack *s; - printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); - printf("Stack:\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); - printf("\t\tstate: %s\n", state_names[s->state]); -// printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); - ao_lisp_error_poly ("sexprs: ", s->sexprs); - ao_lisp_error_poly ("values: ", s->values); - ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); -// ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); - printf("\t]\n"); - } -} ao_poly ao_lisp_error(int error, char *format, ...) @@ -112,7 +92,9 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); - ao_lisp_stack_print(); + printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + printf("Stack:\n"); + ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); printf("Globals:\n\t"); ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); printf("\n"); diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index ef521605..2460a32a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -16,68 +16,9 @@ #include "ao_lisp.h" #include -const struct ao_lisp_type ao_lisp_stack_type; - -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->sexprs, 0); - ao_lisp_poly_mark(stack->values, 0); - /* no need to mark values_tail */ - ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->list, 0); - stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_lisp_stack *stack = addr; - - while (stack) { - struct ao_lisp_stack *prev; - int ret; - (void) ao_lisp_poly_move(&stack->sexprs, 0); - (void) ao_lisp_poly_move(&stack->values, 0); - (void) ao_lisp_poly_move(&stack->values_tail, 0); - (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->list, 0); - prev = ao_lisp_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); - if (prev != ao_lisp_poly_stack(stack->prev)) - stack->prev = ao_lisp_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_lisp_type ao_lisp_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - struct ao_lisp_stack *ao_lisp_stack; ao_poly ao_lisp_v; -struct ao_lisp_stack *ao_lisp_stack_free_list; - ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { @@ -86,72 +27,6 @@ ao_lisp_set_cond(struct ao_lisp_cons *c) return AO_LISP_NIL; } -static void -ao_lisp_stack_reset(struct ao_lisp_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_LISP_NIL; - stack->values = AO_LISP_NIL; - stack->values_tail = AO_LISP_NIL; -} - - -static int -ao_lisp_stack_push(void) -{ - struct ao_lisp_stack *stack; - if (ao_lisp_stack_free_list) { - stack = ao_lisp_stack_free_list; - ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); - } else { - stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; - } - stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack->list = AO_LISP_NIL; - ao_lisp_stack = stack; - ao_lisp_stack_reset(stack); - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -static void -ao_lisp_stack_pop(void) -{ - ao_poly prev; - struct ao_lisp_frame *prev_frame; - - if (!ao_lisp_stack) - return; - prev = ao_lisp_stack->prev; - ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); - ao_lisp_stack_free_list = ao_lisp_stack; - - ao_lisp_stack = ao_lisp_poly_stack(prev); - prev_frame = ao_lisp_frame_current; - if (ao_lisp_stack) - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - else - ao_lisp_frame_current = NULL; - if (ao_lisp_frame_current != prev_frame) - ao_lisp_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -static void -ao_lisp_stack_clear(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - static int func_type(ao_poly func) { @@ -162,6 +37,8 @@ func_type(ao_poly func) return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; case AO_LISP_LAMBDA: return ao_lisp_poly_lambda(func)->args; + case AO_LISP_STACK: + return AO_LISP_FUNC_LAMBDA; default: ao_lisp_error(AO_LISP_INVALID, "not a func"); return -1; @@ -392,10 +269,12 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin->args & AO_LISP_FUNC_FREE_ARGS) + if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack)) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; @@ -404,12 +283,18 @@ ao_lisp_eval_exec(void) ao_lisp_stack->state = eval_progn; v = ao_lisp_lambda_eval(); ao_lisp_stack->sexprs = v; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; + case AO_LISP_STACK: + DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); + ao_lisp_v = ao_lisp_stack_eval(); + DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + break; } - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; return 1; } @@ -599,6 +484,16 @@ static int (*const evals[])(void) = { [eval_macro] = ao_lisp_eval_macro, }; +const char *ao_lisp_state_names[] = { + "sexpr", + "val", + "formal", + "exec", + "cond", + "cond_test", + "progn", +}; + /* * Called at restore time to reset all execution state */ diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 9d17f6fa..17fa141a 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -24,7 +24,7 @@ static int frame_size(void *addr) { struct ao_lisp_frame *frame = addr; - return frame_num_size(ao_lisp_frame_num(frame)); + return frame_num_size(frame->num); } static void @@ -37,7 +37,7 @@ frame_mark(void *addr) MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < ao_lisp_frame_num(frame); f++) { + for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_mark(v->val, 0); @@ -68,7 +68,7 @@ frame_move(void *addr) MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < ao_lisp_frame_num(frame); f++) { + for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_move(&v->atom, 0); @@ -109,15 +109,21 @@ ao_lisp_frame_print(ao_poly p) printf ("{"); if (frame) { - for (f = 0; f < ao_lisp_frame_num(frame); f++) { - if (f != 0) - printf(", "); - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + if (frame->type & AO_LISP_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_LISP_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + } + if (frame->prev) + ao_lisp_poly_print(frame->prev); + frame->type &= ~AO_LISP_FRAME_PRINT; } - if (frame->prev) - ao_lisp_poly_print(frame->prev); } printf("}"); } @@ -126,7 +132,7 @@ ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; - for (f = 0; f < ao_lisp_frame_num(frame); f++) + for (f = 0; f < frame->num; f++) if (frame->vals[f].atom == atom) return &frame->vals[f].val; return NULL; @@ -175,7 +181,7 @@ ao_lisp_frame_new(int num) return NULL; } frame->type = AO_LISP_FRAME; - frame->_num = num; + frame->num = num; frame->prev = AO_LISP_NIL; memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); return frame; @@ -186,7 +192,7 @@ ao_lisp_frame_mark(struct ao_lisp_frame *frame) { if (!frame) return AO_LISP_NIL; - frame->_num |= AO_LISP_FRAME_MARK; + frame->type |= AO_LISP_FRAME_MARK; return ao_lisp_frame_poly(frame); } @@ -194,7 +200,7 @@ void ao_lisp_frame_free(struct ao_lisp_frame *frame) { if (!ao_lisp_frame_marked(frame)) { - int num = ao_lisp_frame_num(frame); + int num = frame->num; if (num < AO_LISP_FRAME_FREE) { frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); ao_lisp_frame_free_list[num] = frame; @@ -209,7 +215,7 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) struct ao_lisp_frame *new; int copy; - if (new_num == ao_lisp_frame_num(frame)) + if (new_num == frame->num) return frame; new = ao_lisp_frame_new(new_num); if (!new) @@ -220,8 +226,8 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) */ frame = *frame_ref; copy = new_num; - if (copy > ao_lisp_frame_num(frame)) - copy = ao_lisp_frame_num(frame); + if (copy > frame->num) + copy = frame->num; memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); new->prev = frame->prev; ao_lisp_frame_free(frame); @@ -239,7 +245,7 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); if (frame) { - f = ao_lisp_frame_num(frame); + f = frame->num; frame = ao_lisp_frame_realloc(frame_ref, f + 1); } else { f = 0; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index e2053a6f..656936cb 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -175,7 +175,8 @@ ao_lisp_lambda_eval(void) args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } - ao_lisp_cons_free(cons); + if (!ao_lisp_stack_marked(ao_lisp_stack)) + ao_lisp_cons_free(cons); cons = NULL; break; case AO_LISP_FUNC_LEXPR: diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 495e48cd..de9c5725 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -71,6 +71,7 @@ struct builtin_func funcs[] = { { .name = "led", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_led }, { .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save }, { .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore }, + { .name = "call/cc", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_call_cc }, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) @@ -358,7 +359,7 @@ main(int argc, char **argv) /* Reduce to referenced values */ ao_lisp_collect(AO_LISP_COLLECT_FULL); - for (f = 0; f < ao_lisp_frame_num(ao_lisp_frame_global); f++) { + for (f = 0; f < ao_lisp_frame_global->num; f++) { val = ao_has_macro(ao_lisp_frame_global->vals[f].val); if (val != AO_LISP_NIL) { printf("error: function %s contains unresolved macro: ", diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 12a5ba55..0dfad1d7 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -144,6 +144,7 @@ struct ao_lisp_root { static struct ao_lisp_cons *save_cons[2]; static char *save_string[2]; +static struct ao_lisp_stack *save_stack[3]; static ao_poly save_poly[2]; static const struct ao_lisp_root ao_lisp_root[] = { @@ -155,6 +156,18 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_cons_type, .addr = (void **) &save_cons[1], }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[0] + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[1] + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[2] + }, { .type = &ao_lisp_string_type, .addr = (void **) &save_string[0] @@ -434,6 +447,7 @@ static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, + [AO_LISP_STACK] = &ao_lisp_stack_type, }; static int @@ -818,6 +832,20 @@ ao_lisp_cons_fetch(int id) return cons; } +void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) +{ + save_stack[id] = stack; +} + +struct ao_lisp_stack * +ao_lisp_stack_fetch(int id) +{ + struct ao_lisp_stack *stack = save_stack[id]; + save_stack[id] = NULL; + return stack; +} + void ao_lisp_string_stash(int id, char *string) { diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 236176e7..800ee06d 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -54,6 +54,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .print = ao_lisp_lambda_print, .patom = ao_lisp_lambda_print, }, + [AO_LISP_STACK] = { + .print = ao_lisp_stack_print, + .patom = ao_lisp_stack_print, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c new file mode 100644 index 00000000..9c773e83 --- /dev/null +++ b/src/lisp/ao_lisp_stack.c @@ -0,0 +1,279 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#define DBG_EVAL 0 +#include "ao_lisp.h" + +const struct ao_lisp_type ao_lisp_stack_type; + +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->sexprs, 0); + ao_lisp_poly_mark(stack->values, 0); + /* no need to mark values_tail */ + ao_lisp_poly_mark(stack->frame, 0); + ao_lisp_poly_mark(stack->list, 0); + stack = ao_lisp_poly_stack(stack->prev); + if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_lisp_stack *stack = addr; + + while (stack) { + struct ao_lisp_stack *prev; + int ret; + (void) ao_lisp_poly_move(&stack->sexprs, 0); + (void) ao_lisp_poly_move(&stack->values, 0); + (void) ao_lisp_poly_move(&stack->values_tail, 0); + (void) ao_lisp_poly_move(&stack->frame, 0); + (void) ao_lisp_poly_move(&stack->list, 0); + prev = ao_lisp_poly_stack(stack->prev); + if (!prev) + break; + ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); + if (prev != ao_lisp_poly_stack(stack->prev)) + stack->prev = ao_lisp_stack_poly(prev); + if (ret) + break; + stack = prev; + } +} + +const struct ao_lisp_type ao_lisp_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move, + .name = "stack" +}; + +struct ao_lisp_stack *ao_lisp_stack_free_list; + +void +ao_lisp_stack_reset(struct ao_lisp_stack *stack) +{ + stack->state = eval_sexpr; + stack->sexprs = AO_LISP_NIL; + stack->values = AO_LISP_NIL; + stack->values_tail = AO_LISP_NIL; +} + +static struct ao_lisp_stack * +ao_lisp_stack_new(void) +{ + struct ao_lisp_stack *stack; + + if (ao_lisp_stack_free_list) { + stack = ao_lisp_stack_free_list; + ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); + } else { + stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!stack) + return 0; + stack->type = AO_LISP_STACK; + } + ao_lisp_stack_reset(stack); + return stack; +} + +int +ao_lisp_stack_push(void) +{ + struct ao_lisp_stack *stack = ao_lisp_stack_new(); + + if (!stack) + return 0; + + stack->prev = ao_lisp_stack_poly(ao_lisp_stack); + stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + stack->list = AO_LISP_NIL; + + ao_lisp_stack = stack; + + DBGI("stack push\n"); + DBG_FRAMES(); + DBG_IN(); + return 1; +} + +void +ao_lisp_stack_pop(void) +{ + ao_poly prev; + struct ao_lisp_frame *prev_frame; + + if (!ao_lisp_stack) + return; + prev = ao_lisp_stack->prev; + if (!ao_lisp_stack_marked(ao_lisp_stack)) { + ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); + ao_lisp_stack_free_list = ao_lisp_stack; + } + + ao_lisp_stack = ao_lisp_poly_stack(prev); + prev_frame = ao_lisp_frame_current; + if (ao_lisp_stack) + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + else + ao_lisp_frame_current = NULL; + if (ao_lisp_frame_current != prev_frame) + ao_lisp_frame_free(prev_frame); + DBG_OUT(); + DBGI("stack pop\n"); + DBG_FRAMES(); +} + +void +ao_lisp_stack_clear(void) +{ + ao_lisp_stack = NULL; + ao_lisp_frame_current = NULL; + ao_lisp_v = AO_LISP_NIL; +} + +void +ao_lisp_stack_print(ao_poly poly) +{ + struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); + + if (s->type & AO_LISP_STACK_PRINT) { + printf("[recurse...]"); + return; + } + while (s) { + s->type |= AO_LISP_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); + ao_lisp_error_poly ("values: ", s->values, s->values_tail); + ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); + ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_LISP_STACK_PRINT; + s = ao_lisp_poly_stack(s->prev); + } +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_lisp_stack * +ao_lisp_stack_copy(struct ao_lisp_stack *old) +{ + struct ao_lisp_stack *new = NULL; + struct ao_lisp_stack *n, *prev = NULL; + + while (old) { + ao_lisp_stack_stash(0, old); + ao_lisp_stack_stash(1, new); + ao_lisp_stack_stash(2, prev); + n = ao_lisp_stack_new(); + prev = ao_lisp_stack_fetch(2); + new = ao_lisp_stack_fetch(1); + old = ao_lisp_stack_fetch(0); + if (!n) + return NULL; + + ao_lisp_stack_mark(old); + ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame)); + *n = *old; + + if (prev) + prev->prev = ao_lisp_stack_poly(n); + else + new = n; + prev = n; + + old = ao_lisp_poly_stack(old->prev); + } + return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_lisp_stack_eval(void) +{ + struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v)); + if (!new) + return AO_LISP_NIL; + + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + + if (!cons || !cons->cdr) + return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value"); + + new->state = eval_val; + + ao_lisp_stack = new; + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + + return ao_lisp_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_lisp_call_cc(struct ao_lisp_cons *cons) +{ + struct ao_lisp_stack *new; + ao_poly v; + + /* Make sure the single parameter is a lambda */ + if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0)) + return AO_LISP_NIL; + + /* go get the lambda */ + ao_lisp_v = ao_lisp_arg(cons, 0); + + /* Note that the whole call chain now has + * a reference to it which may escape + */ + new = ao_lisp_stack_copy(ao_lisp_stack); + if (!new) + return AO_LISP_NIL; + + /* re-fetch cons after the allocation */ + cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr); + + /* Reset the arg list to the current stack, + * and call the lambda + */ + + cons->car = ao_lisp_stack_poly(new); + cons->cdr = AO_LISP_NIL; + v = ao_lisp_lambda_eval(); + ao_lisp_stack->sexprs = v; + ao_lisp_stack->state = eval_progn; + return AO_LISP_NIL; +} -- cgit v1.2.3