diff options
| author | Keith Packard <keithp@keithp.com> | 2016-11-09 09:14:50 -0800 | 
|---|---|---|
| committer | Keith Packard <keithp@keithp.com> | 2017-02-20 11:16:50 -0800 | 
| commit | 794718abc62f4610495fe2bd535a2b67bc46573c (patch) | |
| tree | ce2c16e370d2df6942c1e6a87c40b748eb20b193 /src | |
| parent | cb4cdb115ad83ae0d75eb58e68f561d20279f027 (diff) | |
altos/lisp: working on lexical scoping
Not working yet
Signed-off-by: Keith Packard <keithp@keithp.com>
Diffstat (limited to 'src')
| -rw-r--r-- | src/lisp/Makefile | 4 | ||||
| -rw-r--r-- | src/lisp/ao_lisp.h | 147 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_atom.c | 4 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_builtin.c | 96 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_const.lisp | 136 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_error.c | 81 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_eval.c | 730 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_frame.c | 21 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_make_const.c | 85 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_mem.c | 1 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_prim.c | 10 | ||||
| -rw-r--r-- | src/test/Makefile | 2 | 
12 files changed, 876 insertions, 441 deletions
| 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 @@ -117,6 +177,24 @@ ao_lisp_cons(struct ao_lisp_cons *cons)  }  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)  {  	if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) @@ -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 <stdarg.h> +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 <assert.h>  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) | 
