diff options
Diffstat (limited to 'src/lisp')
| -rw-r--r-- | src/lisp/.gitignore | 2 | ||||
| -rw-r--r-- | src/lisp/Makefile | 22 | ||||
| -rw-r--r-- | src/lisp/Makefile-inc | 22 | ||||
| -rw-r--r-- | src/lisp/Makefile-lisp | 4 | ||||
| -rw-r--r-- | src/lisp/ao_lisp.h | 793 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_atom.c | 165 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_builtin.c | 619 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_cons.c | 143 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_const.lisp | 184 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_error.c | 102 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_eval.c | 531 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_frame.c | 293 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_int.c | 22 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_lambda.c | 196 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_lex.c | 16 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_make_const.c | 423 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_mem.c | 880 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_os.h | 53 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_poly.c | 102 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_read.c | 498 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_read.h | 49 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_rep.c | 34 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_save.c | 76 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_stack.c | 278 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_string.c | 158 | 
25 files changed, 5665 insertions, 0 deletions
| diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore new file mode 100644 index 00000000..76a555ea --- /dev/null +++ b/src/lisp/.gitignore @@ -0,0 +1,2 @@ +ao_lisp_make_const +ao_lisp_const.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile new file mode 100644 index 00000000..25796ec5 --- /dev/null +++ b/src/lisp/Makefile @@ -0,0 +1,22 @@ +all: ao_lisp_const.h + +clean: +	rm -f ao_lisp_const.h $(OBJS) ao_lisp_make_const + +ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const +	./ao_lisp_make_const -o $@ ao_lisp_const.lisp + +include Makefile-inc +SRCS=$(LISP_SRCS) + +HDRS=$(LISP_HDRS) + +OBJS=$(SRCS:.c=.o) + +CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie + + +ao_lisp_make_const:  $(OBJS) +	$(CC) $(CFLAGS) -o $@ $(OBJS) + +$(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc new file mode 100644 index 00000000..126deeb0 --- /dev/null +++ b/src/lisp/Makefile-inc @@ -0,0 +1,22 @@ +LISP_SRCS=\ +	ao_lisp_make_const.c\ +	ao_lisp_mem.c \ +	ao_lisp_cons.c \ +	ao_lisp_string.c \ +	ao_lisp_atom.c \ +	ao_lisp_int.c \ +	ao_lisp_poly.c \ +	ao_lisp_builtin.c \ +	ao_lisp_read.c \ +	ao_lisp_frame.c \ +	ao_lisp_lambda.c \ +	ao_lisp_eval.c \ +	ao_lisp_rep.c \ +	ao_lisp_save.c \ +	ao_lisp_stack.c \ +	ao_lisp_error.c  + +LISP_HDRS=\ +	ao_lisp.h \ +	ao_lisp_os.h \ +	ao_lisp_read.h diff --git a/src/lisp/Makefile-lisp b/src/lisp/Makefile-lisp new file mode 100644 index 00000000..998c7673 --- /dev/null +++ b/src/lisp/Makefile-lisp @@ -0,0 +1,4 @@ +include ../lisp/Makefile-inc + +ao_lisp_const.h: $(LISP_SRCS) $(LISP_HDRS) +	+cd ../lisp && make $@ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h new file mode 100644 index 00000000..980514cc --- /dev/null +++ b/src/lisp/ao_lisp.h @@ -0,0 +1,793 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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. + */ + +#ifndef _AO_LISP_H_ +#define _AO_LISP_H_ + +#define DBG_MEM		0 +#define DBG_EVAL	0 + +#include <stdint.h> +#include <string.h> +#include <ao_lisp_os.h> + +typedef uint16_t	ao_poly; +typedef int16_t		ao_signed_poly; + +#ifdef AO_LISP_SAVE + +struct ao_lisp_os_save { +	ao_poly		atoms; +	ao_poly		globals; +	uint16_t	const_checksum; +	uint16_t	const_checksum_inv; +}; + +#define AO_LISP_POOL_EXTRA	(sizeof(struct ao_lisp_os_save)) +#define AO_LISP_POOL	((int) (AO_LISP_POOL_TOTAL - AO_LISP_POOL_EXTRA)) + +int +ao_lisp_os_save(void); + +int +ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset); + +int +ao_lisp_os_restore(void); + +#endif + +#ifdef AO_LISP_MAKE_CONST +#define AO_LISP_POOL_CONST	16384 +extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); +#define ao_lisp_pool ao_lisp_const +#define AO_LISP_POOL AO_LISP_POOL_CONST + +#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) + +#define _ao_lisp_atom_quote	_atom("quote") +#define _ao_lisp_atom_set 	_atom("set") +#define _ao_lisp_atom_setq 	_atom("setq") +#define _ao_lisp_atom_t 	_atom("t") +#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_length	_atom("length") +#define _ao_lisp_atom_cond	_atom("cond") +#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_pack	_atom("pack") +#define _ao_lisp_atom_unpack	_atom("unpack") +#define _ao_lisp_atom_flush	_atom("flush") +#define _ao_lisp_atom_eval	_atom("eval") +#define _ao_lisp_atom_read	_atom("read") +#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") +#define _ao_lisp_atom_collect	_atom("collect") +#define _ao_lisp_atom_symbolp   _atom("symbol?") +#define _ao_lisp_atom_builtin   _atom("builtin?") +#define _ao_lisp_atom_symbolp   _atom("symbol?") +#define _ao_lisp_atom_symbolp   _atom("symbol?") +#else +#include "ao_lisp_const.h" +#ifndef AO_LISP_POOL +#define AO_LISP_POOL	3072 +#endif +extern uint8_t		ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); +#endif + +/* Primitive types */ +#define AO_LISP_CONS		0 +#define AO_LISP_INT		1 +#define AO_LISP_STRING		2 +#define AO_LISP_OTHER		3 + +#define AO_LISP_TYPE_MASK	0x0003 +#define AO_LISP_TYPE_SHIFT	2 +#define AO_LISP_REF_MASK	0x7ffc +#define AO_LISP_CONST		0x8000 + +/* These have a type value at the start of the struct */ +#define AO_LISP_ATOM		4 +#define AO_LISP_BUILTIN		5 +#define AO_LISP_FRAME		6 +#define AO_LISP_LAMBDA		7 +#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 + +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 +#define AO_LISP_EOF		0x10 + +extern uint8_t		ao_lisp_exception; + +static inline int +ao_lisp_is_const(ao_poly poly) { +	return poly & AO_LISP_CONST; +} + +#define AO_LISP_IS_CONST(a)	(ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) +#define AO_LISP_IS_POOL(a)	(ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) +#define AO_LISP_IS_INT(p)	(ao_lisp_base_type(p) == AO_LISP_INT); + +void * +ao_lisp_ref(ao_poly poly); + +ao_poly +ao_lisp_poly(const void *addr, ao_poly type); + +struct ao_lisp_type { +	int	(*size)(void *addr); +	void	(*mark)(void *addr); +	void	(*move)(void *addr); +	char	name[]; +}; + +struct ao_lisp_cons { +	ao_poly		car; +	ao_poly		cdr; +}; + +struct ao_lisp_atom { +	uint8_t		type; +	uint8_t		pad[1]; +	ao_poly		next; +	char		name[]; +}; + +struct ao_lisp_val { +	ao_poly		atom; +	ao_poly		val; +}; + +struct ao_lisp_frame { +	uint8_t			type; +	uint8_t			num; +	ao_poly			prev; +	struct ao_lisp_val	vals[]; +}; + +/* Set on type when the frame escapes the lambda */ +#define AO_LISP_FRAME_MARK	0x80 +#define AO_LISP_FRAME_PRINT	0x40 + +static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { +	return f->type & AO_LISP_FRAME_MARK; +} + +static inline struct ao_lisp_frame * +ao_lisp_poly_frame(ao_poly poly) { +	return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_frame_poly(struct ao_lisp_frame *frame) { +	return ao_lisp_poly(frame, AO_LISP_OTHER); +} + +enum eval_state { +	eval_sexpr,		/* Evaluate an sexpr */ +	eval_val,		/* Value computed */ +	eval_formal,		/* Formal computed */ +	eval_exec,		/* Start a lambda evaluation */ +	eval_cond,		/* Start next cond clause */ +	eval_cond_test,		/* Check cond condition */ +	eval_progn,		/* Start next progn entry */ +	eval_while,		/* Start while condition */ +	eval_while_test,	/* Check while condition */ +	eval_macro,		/* Finished with macro generation */ +}; + +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 */ +	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 */ +}; + +#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) +{ +	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 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 + +#define AO_LISP_FUNC_FREE_ARGS	0x80 +#define AO_LISP_FUNC_MASK	0x7f + +#define AO_LISP_FUNC_F_LAMBDA	(AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) +#define AO_LISP_FUNC_F_NLAMBDA	(AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) +#define AO_LISP_FUNC_F_MACRO	(AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) +#define AO_LISP_FUNC_F_LEXPR	(AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LEXPR) + +struct ao_lisp_builtin { +	uint8_t		type; +	uint8_t		args; +	uint16_t	func; +}; + +enum ao_lisp_builtin_id { +	builtin_eval, +	builtin_read, +	builtin_lambda, +	builtin_lexpr, +	builtin_nlambda, +	builtin_macro, +	builtin_car, +	builtin_cdr, +	builtin_cons, +	builtin_last, +	builtin_length, +	builtin_quote, +	builtin_set, +	builtin_setq, +	builtin_cond, +	builtin_progn, +	builtin_while, +	builtin_print, +	builtin_patom, +	builtin_plus, +	builtin_minus, +	builtin_times, +	builtin_divide, +	builtin_mod, +	builtin_equal, +	builtin_less, +	builtin_greater, +	builtin_less_equal, +	builtin_greater_equal, +	builtin_pack, +	builtin_unpack, +	builtin_flush, +	builtin_delay, +	builtin_led, +	builtin_save, +	builtin_restore, +	builtin_call_cc, +	builtin_collect, +	_builtin_last +}; + +typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); + +extern const ao_lisp_func_t	ao_lisp_builtins[]; + +static inline ao_lisp_func_t +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); +} + +static inline uint8_t +ao_lisp_other_type(void *other) { +#if DBG_MEM +	if ((*((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK) >= AO_LISP_NUM_TYPE) +		ao_lisp_abort(); +#endif +	return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; +} + +static inline ao_poly +ao_lisp_other_poly(const void *other) +{ +	return ao_lisp_poly(other, AO_LISP_OTHER); +} + +static inline int +ao_lisp_size_round(int size) +{ +	return (size + 3) & ~3; +} + +static inline int +ao_lisp_size(const struct ao_lisp_type *type, void *addr) +{ +	return ao_lisp_size_round(type->size(addr)); +} + +#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) + +static inline int ao_lisp_poly_base_type(ao_poly poly) { +	return poly & AO_LISP_TYPE_MASK; +} + +static inline int ao_lisp_poly_type(ao_poly poly) { +	int	type = poly & AO_LISP_TYPE_MASK; +	if (type == AO_LISP_OTHER) +		return ao_lisp_other_type(ao_lisp_poly_other(poly)); +	return type; +} + +static inline struct ao_lisp_cons * +ao_lisp_poly_cons(ao_poly poly) +{ +	return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_cons_poly(struct ao_lisp_cons *cons) +{ +	return ao_lisp_poly(cons, AO_LISP_CONS); +} + +static inline int +ao_lisp_poly_int(ao_poly poly) +{ +	return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); +} + +static inline ao_poly +ao_lisp_int_poly(int i) +{ +	return ((ao_poly) i << 2) | AO_LISP_INT; +} + +static inline char * +ao_lisp_poly_string(ao_poly poly) +{ +	return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_string_poly(char *s) +{ +	return ao_lisp_poly(s, AO_LISP_STRING); +} + +static inline struct ao_lisp_atom * +ao_lisp_poly_atom(ao_poly poly) +{ +	return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_atom_poly(struct ao_lisp_atom *a) +{ +	return ao_lisp_poly(a, AO_LISP_OTHER); +} + +static inline struct ao_lisp_builtin * +ao_lisp_poly_builtin(ao_poly poly) +{ +	return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_builtin_poly(struct ao_lisp_builtin *b) +{ +	return ao_lisp_poly(b, AO_LISP_OTHER); +} + +/* memory functions */ + +extern int ao_lisp_collects[2]; +extern int ao_lisp_freed[2]; +extern int ao_lisp_loops[2]; + +/* returns 1 if the object was already marked */ +int +ao_lisp_mark(const struct ao_lisp_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr); + +void * +ao_lisp_move_map(void *addr); + +/* returns 1 if the object was already moved */ +int +ao_lisp_move(const struct ao_lisp_type *type, void **ref); + +/* returns 1 if the object was already moved */ +int +ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref); + +void * +ao_lisp_alloc(int size); + +#define AO_LISP_COLLECT_FULL		1 +#define AO_LISP_COLLECT_INCREMENTAL	0 + +int +ao_lisp_collect(uint8_t style); + +void +ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); + +struct ao_lisp_cons * +ao_lisp_cons_fetch(int id); + +void +ao_lisp_poly_stash(int id, ao_poly poly); + +ao_poly +ao_lisp_poly_fetch(int id); + +void +ao_lisp_string_stash(int id, char *string); + +char * +ao_lisp_string_fetch(int id); + +static inline void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) { +	ao_lisp_poly_stash(id, ao_lisp_stack_poly(stack)); +} + +static inline struct ao_lisp_stack * +ao_lisp_stack_fetch(int id) { +	return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); +} + +/* cons */ +extern const struct ao_lisp_type ao_lisp_cons_type; + +struct ao_lisp_cons * +ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); + +extern struct ao_lisp_cons *ao_lisp_cons_free_list; + +void +ao_lisp_cons_free(struct ao_lisp_cons *cons); + +void +ao_lisp_cons_print(ao_poly); + +void +ao_lisp_cons_patom(ao_poly); + +int +ao_lisp_cons_length(struct ao_lisp_cons *cons); + +/* string */ +extern const struct ao_lisp_type ao_lisp_string_type; + +char * +ao_lisp_string_copy(char *a); + +char * +ao_lisp_string_cat(char *a, char *b); + +ao_poly +ao_lisp_string_pack(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_string_unpack(char *a); + +void +ao_lisp_string_print(ao_poly s); + +void +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_global; +extern struct ao_lisp_frame	*ao_lisp_frame_current; + +void +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); + +ao_poly +ao_lisp_atom_set(ao_poly atom, ao_poly val); + +/* int */ +void +ao_lisp_int_print(ao_poly i); + +/* prim */ +void +ao_lisp_poly_print(ao_poly p); + +void +ao_lisp_poly_patom(ao_poly p); + +int +ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); + +/* returns 1 if the object has already been moved */ +int +ao_lisp_poly_move(ao_poly *p, uint8_t note_cons); + +/* eval */ + +void +ao_lisp_eval_clear_globals(void); + +int +ao_lisp_eval_restart(void); + +ao_poly +ao_lisp_eval(ao_poly p); + +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *cons); + +/* builtin */ +void +ao_lisp_builtin_print(ao_poly b); + +extern const struct ao_lisp_type ao_lisp_builtin_type; + +/* Check argument count */ +ao_poly +ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_lisp_arg(struct ao_lisp_cons *cons, int argc); + +char * +ao_lisp_args_name(uint8_t args); + +/* read */ +extern struct ao_lisp_cons	*ao_lisp_read_cons; +extern struct ao_lisp_cons	*ao_lisp_read_cons_tail; +extern struct ao_lisp_cons	*ao_lisp_read_stack; + +ao_poly +ao_lisp_read(void); + +/* rep */ +ao_poly +ao_lisp_read_eval_print(void); + +/* frame */ +extern const struct ao_lisp_type ao_lisp_frame_type; + +#define AO_LISP_FRAME_FREE	6 + +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); + +void +ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val); + +int +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; + +extern const char *ao_lisp_state_names[]; + +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(void); + +/* save */ + +ao_poly +ao_lisp_save(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_restore(struct ao_lisp_cons *cons); + +/* 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_error_frame(int indent, char *name, struct ao_lisp_frame *frame); + +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(ao_lisp_stack_poly(ao_lisp_stack)) +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() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#define DBG_FRAMES() +#endif + +#define DBG_MEM_START	1 + +#if DBG_MEM + +#include <assert.h> +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a)	((int) ((uint8_t *) (a) - ao_lisp_pool)) + +extern int dbg_mem; + +#define MDBG_DO(a)	a +#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf ("  "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) +#define MDBG_MOVE_IN()	(dbg_move_depth++) +#define MDBG_MOVE_OUT()	(assert(--dbg_move_depth >= 0)) + +#else + +#define MDBG_DO(a) +#define MDBG_MOVE(...) +#define MDBG_MORE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() + +#endif + +#endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c new file mode 100644 index 00000000..8c9e8ed1 --- /dev/null +++ b/src/lisp/ao_lisp_atom.c @@ -0,0 +1,165 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_lisp.h" + +static int name_size(char *name) +{ +	return sizeof(struct ao_lisp_atom) + strlen(name) + 1; +} + +static int atom_size(void *addr) +{ +	struct ao_lisp_atom	*atom = addr; +	if (!atom) +		return 0; +	return name_size(atom->name); +} + +static void atom_mark(void *addr) +{ +	struct ao_lisp_atom	*atom = addr; + +	for (;;) { +		atom = ao_lisp_poly_atom(atom->next); +		if (!atom) +			break; +		if (ao_lisp_mark_memory(&ao_lisp_atom_type, atom)) +			break; +	} +} + +static void atom_move(void *addr) +{ +	struct ao_lisp_atom	*atom = addr; +	int			ret; + +	for (;;) { +		struct ao_lisp_atom *next = ao_lisp_poly_atom(atom->next); + +		if (!next) +			break; +		ret = ao_lisp_move_memory(&ao_lisp_atom_type, (void **) &next); +		if (next != ao_lisp_poly_atom(atom->next)) +			atom->next = ao_lisp_atom_poly(next); +		if (ret) +			break; +		atom = next; +	} +} + +const struct ao_lisp_type ao_lisp_atom_type = { +	.mark = atom_mark, +	.size = atom_size, +	.move = atom_move, +	.name = "atom" +}; + +struct ao_lisp_atom	*ao_lisp_atoms; + +struct ao_lisp_atom * +ao_lisp_atom_intern(char *name) +{ +	struct ao_lisp_atom	*atom; + +	for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { +		if (!strcmp(atom->name, name)) +			return atom; +	} +#ifdef ao_builtin_atoms +	for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { +		if (!strcmp(atom->name, name)) +			return atom; +	} +#endif +	ao_lisp_string_stash(0, name); +	atom = ao_lisp_alloc(name_size(name)); +	name = ao_lisp_string_fetch(0); +	if (atom) { +		atom->type = AO_LISP_ATOM; +		atom->next = ao_lisp_atom_poly(ao_lisp_atoms); +		ao_lisp_atoms = atom; +		strcpy(atom->name, name); +	} +	return atom; +} + +struct ao_lisp_frame	*ao_lisp_frame_global; +struct ao_lisp_frame	*ao_lisp_frame_current; + +static void +ao_lisp_atom_init(void) +{ +	if (!ao_lisp_frame_global) +		ao_lisp_frame_global = ao_lisp_frame_new(0); +} + +ao_poly * +ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) +{ +	ao_poly	*ref; +	ao_lisp_atom_init(); +	while (frame) { +		ref = ao_lisp_frame_ref(frame, atom); +		if (ref) +			return ref; +		frame = ao_lisp_poly_frame(frame->prev); +	} +	if (ao_lisp_frame_global) { +		ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); +		if (ref) +			return ref; +	} +	return NULL; +} + +ao_poly +ao_lisp_atom_get(ao_poly atom) +{ +	ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + +	if (!ref && ao_lisp_frame_global) +		ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); +#ifdef ao_builtin_frame +	if (!ref) +		ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); +#endif +	if (ref) +		return *ref; +	return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); +} + +ao_poly +ao_lisp_atom_set(ao_poly atom, ao_poly val) +{ +	ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + +	if (!ref && ao_lisp_frame_global) +		ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); +	if (ref) +		*ref = val; +	else +		ao_lisp_frame_add(&ao_lisp_frame_global, atom, val); +	return val; +} + +void +ao_lisp_atom_print(ao_poly a) +{ +	struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); +	printf("%s", atom->name); +} diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c new file mode 100644 index 00000000..902f60e2 --- /dev/null +++ b/src/lisp/ao_lisp_builtin.c @@ -0,0 +1,619 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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" + +static int +builtin_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_lisp_builtin); +} + +static void +builtin_mark(void *addr) +{ +	(void) addr; +} + +static void +builtin_move(void *addr) +{ +	(void) addr; +} + +const struct ao_lisp_type ao_lisp_builtin_type = { +	.size = builtin_size, +	.mark = builtin_mark, +	.move = builtin_move +}; + +#ifdef AO_LISP_MAKE_CONST +char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { +	(void) b; +	return "???"; +} +char *ao_lisp_args_name(uint8_t args) { +	(void) args; +	return "???"; +} +#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, +	[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_length] = _ao_lisp_atom_length, +	[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_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, +	[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, +	[builtin_pack] = _ao_lisp_atom_pack, +	[builtin_unpack] = _ao_lisp_atom_unpack, +	[builtin_flush] = _ao_lisp_atom_flush, +	[builtin_delay] = _ao_lisp_atom_delay, +	[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, +	[builtin_collect] = _ao_lisp_atom_collect, +#if 0 +	[builtin_symbolp] = _ao_lisp_atom_symbolp, +	[builtin_listp] = _ao_lisp_atom_listp, +	[builtin_stringp] = _ao_lisp_atom_stringp, +	[builtin_numberp] = _ao_lisp_atom_numberp, +#endif +}; + +static char * +ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { +	if (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) +{ +	args &= AO_LISP_FUNC_MASK; +	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) +{ +	struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); +	printf("%s", ao_lisp_builtin_name(builtin->func)); +} + +ao_poly +ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) +{ +	int	argc = 0; + +	while (cons && argc <= max) { +		argc++; +		cons = ao_lisp_poly_cons(cons->cdr); +	} +	if (argc < min || argc > max) +		return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); +	return _ao_lisp_atom_t; +} + +ao_poly +ao_lisp_arg(struct ao_lisp_cons *cons, int argc) +{ +	if (!cons) +		return AO_LISP_NIL; +	while (argc--) { +		if (!cons) +			return AO_LISP_NIL; +		cons = ao_lisp_poly_cons(cons->cdr); +	} +	return cons->car; +} + +ao_poly +ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +{ +	ao_poly car = ao_lisp_arg(cons, argc); + +	if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) +		return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc); +	return _ao_lisp_atom_t; +} + +ao_poly +ao_lisp_car(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) +		return AO_LISP_NIL; +	if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0)) +		return AO_LISP_NIL; +	return ao_lisp_poly_cons(cons->car)->car; +} + +ao_poly +ao_lisp_cdr(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) +		return AO_LISP_NIL; +	if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0)) +		return AO_LISP_NIL; +	return ao_lisp_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_lisp_cons(struct ao_lisp_cons *cons) +{ +	ao_poly	car, cdr; +	if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) +		return AO_LISP_NIL; +	if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1)) +		return AO_LISP_NIL; +	car = ao_lisp_arg(cons, 0); +	cdr = ao_lisp_arg(cons, 1); +	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_length(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1)) +		return AO_LISP_NIL; +	if (!ao_lisp_check_argt(_ao_lisp_atom_length, cons, 0, AO_LISP_CONS, 1)) +		return AO_LISP_NIL; +	return ao_lisp_int_poly(ao_lisp_cons_length(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)))); +} + +ao_poly +ao_lisp_quote(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) +		return AO_LISP_NIL; +	return ao_lisp_arg(cons, 0); +} + +ao_poly +ao_lisp_set(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) +		return AO_LISP_NIL; +	if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0)) +		return AO_LISP_NIL; + +	return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); +} + +ao_poly +ao_lisp_setq(struct ao_lisp_cons *cons) +{ +	struct ao_lisp_cons	*expand = 0; +	if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) +		return AO_LISP_NIL; +	expand = ao_lisp_cons_cons(_ao_lisp_atom_set, +				   ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, +								       ao_lisp_cons_cons(cons->car, NULL))), +						     ao_lisp_poly_cons(cons->cdr))); +	return ao_lisp_cons_poly(expand); +} + +ao_poly +ao_lisp_cond(struct ao_lisp_cons *cons) +{ +	ao_lisp_set_cond(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) +{ +	ao_poly	val = AO_LISP_NIL; +	while (cons) { +		val = cons->car; +		ao_lisp_poly_print(val); +		cons = ao_lisp_poly_cons(cons->cdr); +		if (cons) +			printf(" "); +	} +	printf("\n"); +	return val; +} + +ao_poly +ao_lisp_patom(struct ao_lisp_cons *cons) +{ +	ao_poly	val = AO_LISP_NIL; +	while (cons) { +		val = cons->car; +		ao_lisp_poly_patom(val); +		cons = ao_lisp_poly_cons(cons->cdr); +	} +	return val; +} + +ao_poly +ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +{ +	ao_poly	ret = AO_LISP_NIL; + +	while (cons) { +		ao_poly		car = cons->car; +		uint8_t		rt = ao_lisp_poly_type(ret); +		uint8_t		ct = ao_lisp_poly_type(car); + +		cons = ao_lisp_poly_cons(cons->cdr); + +		if (rt == AO_LISP_NIL) +			ret = car; + +		else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { +			int	r = ao_lisp_poly_int(ret); +			int	c = ao_lisp_poly_int(car); + +			switch(op) { +			case builtin_plus: +				r += c; +				break; +			case builtin_minus: +				r -= c; +				break; +			case builtin_times: +				r *= c; +				break; +			case builtin_divide: +				if (c == 0) +					return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); +				r /= c; +				break; +			case builtin_mod: +				if (c == 0) +					return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); +				r %= c; +				break; +			default: +				break; +			} +			ret = ao_lisp_int_poly(r); +		} + +		else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) +			ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), +								     ao_lisp_poly_string(car))); +		else +			return ao_lisp_error(AO_LISP_INVALID, "invalid args"); +	} +	return ret; +} + +ao_poly +ao_lisp_plus(struct ao_lisp_cons *cons) +{ +	return ao_lisp_math(cons, builtin_plus); +} + +ao_poly +ao_lisp_minus(struct ao_lisp_cons *cons) +{ +	return ao_lisp_math(cons, builtin_minus); +} + +ao_poly +ao_lisp_times(struct ao_lisp_cons *cons) +{ +	return ao_lisp_math(cons, builtin_times); +} + +ao_poly +ao_lisp_divide(struct ao_lisp_cons *cons) +{ +	return ao_lisp_math(cons, builtin_divide); +} + +ao_poly +ao_lisp_mod(struct ao_lisp_cons *cons) +{ +	return ao_lisp_math(cons, builtin_mod); +} + +ao_poly +ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +{ +	ao_poly	left; + +	if (!cons) +		return _ao_lisp_atom_t; + +	left = cons->car; +	cons = ao_lisp_poly_cons(cons->cdr); +	while (cons) { +		ao_poly	right = cons->car; + +		if (op == builtin_equal) { +			if (left != right) +				return AO_LISP_NIL; +		} else { +			uint8_t	lt = ao_lisp_poly_type(left); +			uint8_t	rt = ao_lisp_poly_type(right); +			if (lt == AO_LISP_INT && rt == AO_LISP_INT) { +				int l = ao_lisp_poly_int(left); +				int r = ao_lisp_poly_int(right); + +				switch (op) { +				case builtin_less: +					if (!(l < r)) +						return AO_LISP_NIL; +					break; +				case builtin_greater: +					if (!(l > r)) +						return AO_LISP_NIL; +					break; +				case builtin_less_equal: +					if (!(l <= r)) +						return AO_LISP_NIL; +					break; +				case builtin_greater_equal: +					if (!(l >= r)) +						return AO_LISP_NIL; +					break; +				default: +					break; +				} +			} else if (lt == AO_LISP_STRING && rt == AO_LISP_STRING) { +				int c = strcmp(ao_lisp_poly_string(left), +					       ao_lisp_poly_string(right)); +				switch (op) { +				case builtin_less: +					if (!(c < 0)) +						return AO_LISP_NIL; +					break; +				case builtin_greater: +					if (!(c > 0)) +						return AO_LISP_NIL; +					break; +				case builtin_less_equal: +					if (!(c <= 0)) +						return AO_LISP_NIL; +					break; +				case builtin_greater_equal: +					if (!(c >= 0)) +						return AO_LISP_NIL; +					break; +				default: +					break; +				} +			} +		} +		left = right; +		cons = ao_lisp_poly_cons(cons->cdr); +	} +	return _ao_lisp_atom_t; +} + +ao_poly +ao_lisp_equal(struct ao_lisp_cons *cons) +{ +	return ao_lisp_compare(cons, builtin_equal); +} + +ao_poly +ao_lisp_less(struct ao_lisp_cons *cons) +{ +	return ao_lisp_compare(cons, builtin_less); +} + +ao_poly +ao_lisp_greater(struct ao_lisp_cons *cons) +{ +	return ao_lisp_compare(cons, builtin_greater); +} + +ao_poly +ao_lisp_less_equal(struct ao_lisp_cons *cons) +{ +	return ao_lisp_compare(cons, builtin_less_equal); +} + +ao_poly +ao_lisp_greater_equal(struct ao_lisp_cons *cons) +{ +	return ao_lisp_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_lisp_pack(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) +		return AO_LISP_NIL; +	if (!ao_lisp_check_argt(_ao_lisp_atom_pack, cons, 0, AO_LISP_CONS, 1)) +		return AO_LISP_NIL; +	return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))); +} + +ao_poly +ao_lisp_unpack(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) +		return AO_LISP_NIL; +	if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, cons, 0, AO_LISP_STRING, 0)) +		return AO_LISP_NIL; +	return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); +} + +ao_poly +ao_lisp_flush(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) +		return AO_LISP_NIL; +	ao_lisp_os_flush(); +	return _ao_lisp_atom_t; +} + +ao_poly +ao_lisp_led(struct ao_lisp_cons *cons) +{ +	ao_poly led; +	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) +		return AO_LISP_NIL; +	if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) +		return AO_LISP_NIL; +	led = ao_lisp_arg(cons, 0); +	ao_lisp_os_led(ao_lisp_poly_int(led)); +	return led; +} + +ao_poly +ao_lisp_delay(struct ao_lisp_cons *cons) +{ +	ao_poly delay; +	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) +		return AO_LISP_NIL; +	if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) +		return AO_LISP_NIL; +	delay = ao_lisp_arg(cons, 0); +	ao_lisp_os_delay(ao_lisp_poly_int(delay)); +	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(); +} + +ao_poly +ao_lisp_do_collect(struct ao_lisp_cons *cons) +{ +	int	free; +	(void) cons; +	free = ao_lisp_collect(AO_LISP_COLLECT_FULL); +	return ao_lisp_int_poly(free); +} + +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, +	[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_length] = ao_lisp_length, +	[builtin_quote] = ao_lisp_quote, +	[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, +	[builtin_minus] = ao_lisp_minus, +	[builtin_times] = ao_lisp_times, +	[builtin_divide] = ao_lisp_divide, +	[builtin_mod] = ao_lisp_mod, +	[builtin_equal] = ao_lisp_equal, +	[builtin_less] = ao_lisp_less, +	[builtin_greater] = ao_lisp_greater, +	[builtin_less_equal] = ao_lisp_less_equal, +	[builtin_greater_equal] = ao_lisp_greater_equal, +	[builtin_pack] = ao_lisp_pack, +	[builtin_unpack] = ao_lisp_unpack, +	[builtin_flush] = ao_lisp_flush, +	[builtin_led] = ao_lisp_led, +	[builtin_delay] = ao_lisp_delay, +	[builtin_save] = ao_lisp_save, +	[builtin_restore] = ao_lisp_restore, +	[builtin_call_cc] = ao_lisp_call_cc, +	[builtin_collect] = ao_lisp_do_collect, +}; + diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c new file mode 100644 index 00000000..d2b60c9a --- /dev/null +++ b/src/lisp/ao_lisp_cons.c @@ -0,0 +1,143 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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" + +static void cons_mark(void *addr) +{ +	struct ao_lisp_cons	*cons = addr; + +	for (;;) { +		ao_lisp_poly_mark(cons->car, 1); +		cons = ao_lisp_poly_cons(cons->cdr); +		if (!cons) +			break; +		if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) +			break; +	} +} + +static int cons_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_lisp_cons); +} + +static void cons_move(void *addr) +{ +	struct ao_lisp_cons	*cons = addr; + +	if (!cons) +		return; + +	for (;;) { +		struct ao_lisp_cons	*cdr; +		int			ret; + +		MDBG_MOVE("cons_move start %d (%d, %d)\n", +			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); +		(void) ao_lisp_poly_move(&cons->car, 1); +		cdr = ao_lisp_poly_cons(cons->cdr); +		if (!cdr) +			break; +		ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &cdr); +		if (cdr != ao_lisp_poly_cons(cons->cdr)) +			cons->cdr = ao_lisp_cons_poly(cdr); +		MDBG_MOVE("cons_move end %d (%d, %d)\n", +			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); +		if (ret) +			break; +		cons = cdr; +	} +} + +const struct ao_lisp_type ao_lisp_cons_type = { +	.mark = cons_mark, +	.size = cons_size, +	.move = cons_move, +	.name = "cons", +}; + +struct ao_lisp_cons *ao_lisp_cons_free_list; + +struct ao_lisp_cons * +ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) +{ +	struct ao_lisp_cons	*cons; + +	if (ao_lisp_cons_free_list) { +		cons = ao_lisp_cons_free_list; +		ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); +	} else { +		ao_lisp_poly_stash(0, car); +		ao_lisp_cons_stash(0, cdr); +		cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); +		car = ao_lisp_poly_fetch(0); +		cdr = ao_lisp_cons_fetch(0); +		if (!cons) +			return NULL; +	} +	cons->car = car; +	cons->cdr = ao_lisp_cons_poly(cdr); +	return cons; +} + +void +ao_lisp_cons_free(struct ao_lisp_cons *cons) +{ +	while (cons) { +		ao_poly cdr = cons->cdr; +		cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); +		ao_lisp_cons_free_list = cons; +		cons = ao_lisp_poly_cons(cdr); +	} +} + +void +ao_lisp_cons_print(ao_poly c) +{ +	struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); +	int	first = 1; +	printf("("); +	while (cons) { +		if (!first) +			printf(" "); +		ao_lisp_poly_print(cons->car); +		cons = ao_lisp_poly_cons(cons->cdr); +		first = 0; +	} +	printf(")"); +} + +void +ao_lisp_cons_patom(ao_poly c) +{ +	struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); + +	while (cons) { +		ao_lisp_poly_patom(cons->car); +		cons = ao_lisp_poly_cons(cons->cdr); +	} +} + +int +ao_lisp_cons_length(struct ao_lisp_cons *cons) +{ +	int	len = 0; +	while (cons) { +		len++; +		cons = ao_lisp_poly_cons(cons->cdr); +	} +	return len; +} diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp new file mode 100644 index 00000000..3c8fd21b --- /dev/null +++ b/src/lisp/ao_lisp_const.lisp @@ -0,0 +1,184 @@ +; +; Copyright © 2016 Keith Packard <keithp@keithp.com> +; +; 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. +; +; Lisp code placed in ROM + +					; return a list containing all of the arguments + +(set (quote list) (lexpr (l) l)) + +					; +					; Define a variable without returning the value +					; Useful when defining functions to avoid +					; having lots of output generated +					; + +(setq def (macro (name val rest) +		 (list +		  'progn +		  (list +		   'set +		   (list 'quote name) +		   val) +		  (list 'quote name) +		  ) +		 ) +      ) + +					; +					; A slightly more convenient form +					; for defining lambdas. +					; +					; (defun <name> (<params>) s-exprs) +					; + +(def defun (macro (name args exprs) +		  (list +		   def +		   name +		   (cons 'lambda (cons args exprs)) +		   ) +		  ) +     ) + +					; basic list accessors + + +(defun cadr (l) (car (cdr l))) + +(defun caddr (l) (car (cdr (cdr l)))) + +(defun nth (list n) +  (cond ((= n 0) (car list)) +	((nth (cdr list) (1- n))) +	) +  ) + +					; simple math operators + +(defun 1+ (x) (+ x 1)) +(defun 1- (x) (- x 1)) + +					; 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 (vars exprs) +		((lambda (make-names make-exprs make-nils) + +					; +					; make the list of names in the let +					; + +		   (setq 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 + +		   (setq make-exprs (lambda (vars exprs) +				      (cond (vars (cons +						   (list set +							 (list quote +							       (car (car vars)) +							       ) +							 (cadr (car vars)) +							 ) +						   (make-exprs (cdr vars) exprs) +						   ) +						  ) +					    (exprs) +					    ) +				      ) +			 ) + +					; the parameters to the lambda is a list +					; of nils of the right length + +		   (setq make-nils (lambda (vars) +				     (cond (vars (cons nil (make-nils (cdr vars)))) +					   ) +				     ) +			 ) +					; prepend the set operations +					; to the expressions + +		   (setq exprs (make-exprs vars exprs)) + +					; build the lambda. + +		   (cons (cons 'lambda (cons (make-names vars) exprs)) +			 (make-nils vars) +			 ) +		   ) +		 () +		 () +		 () +		 ) +		) +     ) + +					; boolean operators + +(def or (lexpr (l) +	       (let ((ret nil)) +		 (while l +		   (cond ((setq ret (car l)) +			  (setq l nil)) +			 ((setq l (cdr l))))) +		 ret +		 ) +	       ) +     ) + +					; execute to resolve macros + +(or nil t) + +(def and (lexpr (l) +	       (let ((ret t)) +		 (while l +		   (cond ((setq ret (car l)) +			  (setq l (cdr l))) +			 ((setq ret (setq l nil))) +			 ) +		   ) +		 ret +		 ) +	       ) +     ) + +					; execute to resolve macros + +(and t nil) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c new file mode 100644 index 00000000..54a9be10 --- /dev/null +++ b/src/lisp/ao_lisp_error.c @@ -0,0 +1,102 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 <stdarg.h> + +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) { +		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"); +				if (poly == last) +					break; +				poly = cons->cdr; +			} +			printf("\t\t         )\n"); +		} else +			printf(")\n"); +	} else { +		ao_lisp_poly_print(poly); +		printf("\n"); +	} +} + +static void tabs(int indent) +{ +	while (indent--) +		printf("\t"); +} + +void +ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) +{ +	int			f; + +	tabs(indent); +	printf ("%s{", name); +	if (frame) { +		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"); +			} +			if (frame->prev) +				ao_lisp_error_frame(indent + 1, "prev:   ", ao_lisp_poly_frame(frame->prev)); +			frame->type &= ~AO_LISP_FRAME_PRINT; +		} +		tabs(indent); +		printf("        }\n"); +	} else +		printf ("}\n"); +} + + +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"); +	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"); +	return AO_LISP_NIL; +} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c new file mode 100644 index 00000000..3be7c9c4 --- /dev/null +++ b/src/lisp/ao_lisp_eval.c @@ -0,0 +1,531 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 <assert.h> + +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->sexprs = ao_lisp_cons_poly(c); +	return AO_LISP_NIL; +} + +static int +func_type(ao_poly func) +{ +	if (func == AO_LISP_NIL) +		return ao_lisp_error(AO_LISP_INVALID, "func is nil"); +	switch (ao_lisp_poly_type(func)) { +	case AO_LISP_BUILTIN: +		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; +	} +} + +/* + * 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_eval_sexpr(void) +{ +	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; +	} +	DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n"); +	return 1; +} + +/* + * 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) +{ +	DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); +	/* +	 * 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; +} + +/* + * 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. + * + * 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; +	struct ao_lisp_stack	*prev; + +	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: +			/* Evaluate the result once more */ +			ao_lisp_stack->state = eval_macro; +			if (!ao_lisp_stack_push()) +				return 0; + +			/* After the function returns, take that +			 * value and re-evaluate it +			 */ +			prev = ao_lisp_poly_stack(ao_lisp_stack->prev); +			ao_lisp_stack->sexprs = prev->sexprs; + +			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; +		} +	} + +	/* 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; +	struct ao_lisp_builtin	*builtin; + +	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; +		builtin = ao_lisp_poly_builtin(ao_lisp_v); +		v = ao_lisp_func(builtin) ( +			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"); +			}); +		builtin = ao_lisp_poly_builtin(ao_lisp_v); +		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; +	case AO_LISP_LAMBDA: +		DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); +		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; +	} +	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; +	} +	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); +		ao_poly c = car->cdr; + +		if (c) { +			ao_lisp_stack->state = eval_progn; +			ao_lisp_stack->sexprs = c; +		} else +			ao_lisp_stack->state = eval_val; +	} 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; +} + +/* + * 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 there are more sexprs to do, then come back here, otherwise +		 * return the value of the last one by just landing in eval_sexpr +		 */ +		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"); + +	ao_lisp_stack->values = ao_lisp_v; +	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; +	} +	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_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()) +			return 0; +		ao_lisp_stack->state = eval_progn; +		ao_lisp_stack->sexprs = ao_lisp_v; +	} +	else +	{ +		ao_lisp_stack->state = eval_val; +		ao_lisp_v = ao_lisp_stack->values; +	} +	return 1; +} + +/* + * Replace the original sexpr with the macro expansion, then + * execute that + */ +static int +ao_lisp_eval_macro(void) +{ +	DBGI("macro: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + +	if (ao_lisp_v == AO_LISP_NIL) +		ao_lisp_abort(); +	if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_CONS) { +		*ao_lisp_poly_cons(ao_lisp_stack->sexprs) = *ao_lisp_poly_cons(ao_lisp_v); +		ao_lisp_v = ao_lisp_stack->sexprs; +		DBGI("sexprs rewritten to: "); DBG_POLY(ao_lisp_v); DBG("\n"); +	} +	ao_lisp_stack->sexprs = AO_LISP_NIL; +	ao_lisp_stack->state = eval_sexpr; +	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, +	[eval_progn] = ao_lisp_eval_progn, +	[eval_while] = ao_lisp_eval_while, +	[eval_while_test] = ao_lisp_eval_while_test, +	[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 + */ + +void +ao_lisp_eval_clear_globals(void) +{ +	ao_lisp_stack = NULL; +	ao_lisp_frame_current = NULL; +	ao_lisp_v = AO_LISP_NIL; +} + +int +ao_lisp_eval_restart(void) +{ +	return ao_lisp_stack_push(); +} + +ao_poly +ao_lisp_eval(ao_poly _v) +{ +	ao_lisp_v = _v; + +	if (!ao_lisp_stack_push()) +		return AO_LISP_NIL; + +	while (ao_lisp_stack) { +		if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { +			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 new file mode 100644 index 00000000..05f6d253 --- /dev/null +++ b/src/lisp/ao_lisp_frame.c @@ -0,0 +1,293 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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" + +static inline int +frame_num_size(int num) +{ +	return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val); +} + +static int +frame_size(void *addr) +{ +	struct ao_lisp_frame	*frame = addr; +	return frame_num_size(frame->num); +} + +static void +frame_mark(void *addr) +{ +	struct ao_lisp_frame	*frame = addr; +	int			f; + +	for (;;) { +		MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); +		if (!AO_LISP_IS_POOL(frame)) +			break; +		for (f = 0; f < frame->num; f++) { +			struct ao_lisp_val	*v = &frame->vals[f]; + +			ao_lisp_poly_mark(v->val, 0); +			MDBG_MOVE("frame mark atom %s %d val %d at %d\n", +				  ao_lisp_poly_atom(v->atom)->name, +				  MDBG_OFFSET(ao_lisp_ref(v->atom)), +				  MDBG_OFFSET(ao_lisp_ref(v->val)), f); +		} +		frame = ao_lisp_poly_frame(frame->prev); +		MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); +		if (!frame) +			break; +		if (ao_lisp_mark_memory(&ao_lisp_frame_type, frame)) +			break; +	} +} + +static void +frame_move(void *addr) +{ +	struct ao_lisp_frame	*frame = addr; +	int			f; + +	for (;;) { +		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++) { +			struct ao_lisp_val	*v = &frame->vals[f]; + +			ao_lisp_poly_move(&v->atom, 0); +			ao_lisp_poly_move(&v->val, 0); +			MDBG_MOVE("frame move atom %s %d val %d at %d\n", +				  ao_lisp_poly_atom(v->atom)->name, +				  MDBG_OFFSET(ao_lisp_ref(v->atom)), +				  MDBG_OFFSET(ao_lisp_ref(v->val)), f); +		} +		prev = ao_lisp_poly_frame(frame->prev); +		if (!prev) +			break; +		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 = prev; +	} +} + +const struct ao_lisp_type ao_lisp_frame_type = { +	.mark = frame_mark, +	.size = frame_size, +	.move = frame_move, +	.name = "frame", +}; + +void +ao_lisp_frame_print(ao_poly p) +{ +	struct ao_lisp_frame	*frame = ao_lisp_poly_frame(p); +	int			f; + +	printf ("{"); +	if (frame) { +		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; +		} +	} +	printf("}"); +} + +static int +ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) +{ +	int l = 0; +	int r = top - 1; +	while (l <= r) { +		int m = (l + r) >> 1; +		if (frame->vals[m].atom < atom) +			l = m + 1; +		else +			r = m - 1; +	} +	return l; +} + +ao_poly * +ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) +{ +	int l = ao_lisp_frame_find(frame, frame->num, atom); + +	if (l >= frame->num) +		return NULL; + +	if (frame->vals[l].atom != atom) +		return NULL; +	return &frame->vals[l].val; +} + +int +ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) +{ +	while (frame) { +		if (!AO_LISP_IS_CONST(frame)) { +			ao_poly *ref = ao_lisp_frame_ref(frame, atom); +			if (ref) { +				*ref = val; +				return 1; +			} +		} +		frame = ao_lisp_poly_frame(frame->prev); +	} +	return 0; +} + +ao_poly +ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) +{ +	while (frame) { +		ao_poly *ref = ao_lisp_frame_ref(frame, atom); +		if (ref) +			return *ref; +		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; + +	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->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; +	frame->type |= 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 = 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; +		} +	} +} + +static struct ao_lisp_frame * +ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) +{ +	struct ao_lisp_frame	*frame = *frame_ref; +	struct ao_lisp_frame	*new; +	int			copy; + +	if (new_num == frame->num) +		return frame; +	new = ao_lisp_frame_new(new_num); +	if (!new) +		return NULL; +	/* +	 * Re-fetch the frame as it may have moved +	 * during the allocation +	 */ +	frame = *frame_ref; +	copy = new_num; +	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); +	return new; +} + +void +ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) +{ +	int l = ao_lisp_frame_find(frame, num, atom); + +	memmove(&frame->vals[l+1], +		&frame->vals[l], +		(num - l) * sizeof (struct ao_lisp_val)); +	frame->vals[l].atom = atom; +	frame->vals[l].val = val; +} + +int +ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) +{ +	struct ao_lisp_frame *frame = *frame_ref; +	ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; + +	if (!ref) { +		int f; +		ao_lisp_poly_stash(0, atom); +		ao_lisp_poly_stash(1, val); +		if (frame) { +			f = frame->num; +			frame = ao_lisp_frame_realloc(frame_ref, f + 1); +		} else { +			f = 0; +			frame = ao_lisp_frame_new(1); +		} +		if (!frame) +			return 0; +		*frame_ref = frame; +		atom = ao_lisp_poly_fetch(0); +		val = ao_lisp_poly_fetch(1); +		ao_lisp_frame_bind(frame, frame->num - 1, atom, val); +	} else +		*ref = val; +	return 1; +} diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c new file mode 100644 index 00000000..77f65e95 --- /dev/null +++ b/src/lisp/ao_lisp_int.c @@ -0,0 +1,22 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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" + +void +ao_lisp_int_print(ao_poly p) +{ +	int i = ao_lisp_poly_int(p); +	printf("%d", i); +} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c new file mode 100644 index 00000000..526863c5 --- /dev/null +++ b/src/lisp/ao_lisp_lambda.c @@ -0,0 +1,196 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_lisp.h" + +int +lambda_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_lisp_lambda); +} + +void +lambda_mark(void *addr) +{ +	struct ao_lisp_lambda	*lambda = addr; + +	ao_lisp_poly_mark(lambda->code, 0); +	ao_lisp_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ +	struct ao_lisp_lambda	*lambda = addr; + +	ao_lisp_poly_move(&lambda->code, 0); +	ao_lisp_poly_move(&lambda->frame, 0); +} + +const struct ao_lisp_type ao_lisp_lambda_type = { +	.size = lambda_size, +	.mark = lambda_mark, +	.move = lambda_move, +	.name = "lambda", +}; + +void +ao_lisp_lambda_print(ao_poly poly) +{ +	struct ao_lisp_lambda	*lambda = ao_lisp_poly_lambda(poly); +	struct ao_lisp_cons	*cons = ao_lisp_poly_cons(lambda->code); + +	printf("("); +	printf("%s", ao_lisp_args_name(lambda->args)); +	while (cons) { +		printf(" "); +		ao_lisp_poly_print(cons->car); +		cons = ao_lisp_poly_cons(cons->cdr); +	} +	printf(")"); +} + +ao_poly +ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) +{ +	ao_lisp_cons_stash(0, code); +	struct ao_lisp_lambda	*lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); +	code = ao_lisp_cons_fetch(0); +	struct ao_lisp_cons	*arg; +	int			f; + +	if (!lambda) +		return AO_LISP_NIL; + +	if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) +		return AO_LISP_NIL; +	f = 0; +	arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); +	while (arg) { +		if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM) +			return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f); +		arg = ao_lisp_poly_cons(arg->cdr); +		f++; +	} + +	lambda->type = AO_LISP_LAMBDA; +	lambda->args = args; +	lambda->code = ao_lisp_cons_poly(code); +	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); +} + +ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons) +{ +	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); +} + +ao_poly +ao_lisp_lexpr(struct ao_lisp_cons *cons) +{ +	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); +} + +ao_poly +ao_lisp_nlambda(struct ao_lisp_cons *cons) +{ +	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); +} + +ao_poly +ao_lisp_macro(struct ao_lisp_cons *cons) +{ +	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); +} + +ao_poly +ao_lisp_lambda_eval(void) +{ +	struct ao_lisp_lambda	*lambda = ao_lisp_poly_lambda(ao_lisp_v); +	struct ao_lisp_cons	*cons = ao_lisp_poly_cons(ao_lisp_stack->values); +	struct ao_lisp_cons	*code = ao_lisp_poly_cons(lambda->code); +	struct ao_lisp_cons	*args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); +	struct ao_lisp_frame	*next_frame; +	int			args_wanted; +	int			args_provided; +	int			f; +	struct ao_lisp_cons	*vals; + +	DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); + +	args_wanted = ao_lisp_cons_length(args); + +	/* Create a frame to hold the variables +	 */ +	args_provided = ao_lisp_cons_length(cons) - 1; +	if (lambda->args == AO_LISP_FUNC_LAMBDA) { +		if (args_wanted != args_provided) +			return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided); +	} else { +		if (args_provided < args_wanted - 1) +			return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); +	} + +	next_frame = ao_lisp_frame_new(args_wanted); + +	/* Re-fetch all of the values in case something moved */ +	lambda = ao_lisp_poly_lambda(ao_lisp_v); +	cons = ao_lisp_poly_cons(ao_lisp_stack->values); +	code = ao_lisp_poly_cons(lambda->code); +	args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); +	vals = ao_lisp_poly_cons(cons->cdr); + +	next_frame->prev = lambda->frame; +	ao_lisp_frame_current = next_frame; +	ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + +	switch (lambda->args) { +	case AO_LISP_FUNC_LAMBDA: +		for (f = 0; f < args_wanted; f++) { +			DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); +			ao_lisp_frame_bind(next_frame, f, args->car, vals->car); +			args = ao_lisp_poly_cons(args->cdr); +			vals = ao_lisp_poly_cons(vals->cdr); +		} +		if (!ao_lisp_stack_marked(ao_lisp_stack)) +			ao_lisp_cons_free(cons); +		cons = NULL; +		break; +	case AO_LISP_FUNC_LEXPR: +	case AO_LISP_FUNC_NLAMBDA: +	case AO_LISP_FUNC_MACRO: +		for (f = 0; f < args_wanted - 1; f++) { +			DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); +			ao_lisp_frame_bind(next_frame, f, args->car, vals->car); +			args = ao_lisp_poly_cons(args->cdr); +			vals = ao_lisp_poly_cons(vals->cdr); +		} +		DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); +		ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals)); +		break; +	default: +		break; +	} +	DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); +	DBG_STACK(); +	DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); +	return code->cdr; +} diff --git a/src/lisp/ao_lisp_lex.c b/src/lisp/ao_lisp_lex.c new file mode 100644 index 00000000..fe7c47f4 --- /dev/null +++ b/src/lisp/ao_lisp_lex.c @@ -0,0 +1,16 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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" + diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c new file mode 100644 index 00000000..49f989e6 --- /dev/null +++ b/src/lisp/ao_lisp_make_const.c @@ -0,0 +1,423 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 <stdlib.h> +#include <ctype.h> +#include <unistd.h> +#include <getopt.h> + +static struct ao_lisp_builtin * +ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { +	struct ao_lisp_builtin *b = ao_lisp_alloc(sizeof (struct ao_lisp_builtin)); + +	b->type = AO_LISP_BUILTIN; +	b->func = func; +	b->args = args; +	return b; +} + +struct builtin_func { +	char	*name; +	int	args; +	int	func; +}; + +struct builtin_func funcs[] = { +	{ .name = "eval",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_eval }, +	{ .name = "read",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_read }, +	{ .name = "lambda",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_lambda }, +	{ .name = "lexpr",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_lexpr }, +	{ .name = "nlambda",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_nlambda }, +	{ .name = "macro",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_macro }, +	{ .name = "car",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_car }, +	{ .name = "cdr",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_cdr }, +	{ .name = "cons",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_cons }, +	{ .name = "last",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_last }, +	{ .name = "length",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_length }, +	{ .name = "quote",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_quote }, +	{ .name = "set",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_set }, +	{ .name = "setq",	.args = AO_LISP_FUNC_MACRO,	.func = builtin_setq }, +	{ .name = "cond",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_cond }, +	{ .name = "progn",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_progn }, +	{ .name = "while",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_while }, +	{ .name = "print",	.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_print }, +	{ .name = "patom",	.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_patom }, +	{ .name = "+",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_plus }, +	{ .name = "-",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_minus }, +	{ .name = "*",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_times }, +	{ .name = "/",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_divide }, +	{ .name = "%",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_mod }, +	{ .name = "=",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_equal }, +	{ .name = "<",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_less }, +	{ .name = ">",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_greater }, +	{ .name = "<=",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_less_equal }, +	{ .name = ">=",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_greater_equal }, +	{ .name = "pack",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_pack }, +	{ .name = "unpack",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_unpack }, +	{ .name = "flush",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_flush }, +	{ .name = "delay",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_delay }, +	{ .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 }, +	{ .name = "collect",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_collect }, +}; + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +struct ao_lisp_frame	*globals; + +static int +is_atom(int offset) +{ +	struct ao_lisp_atom *a; + +	for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) +		if (((uint8_t *) a->name - ao_lisp_const) == offset) +			return strlen(a->name); +	return 0; +} + +#define AO_FEC_CRC_INIT	0xffff + +static inline uint16_t +ao_fec_crc_byte(uint8_t byte, uint16_t crc) +{ +	uint8_t	bit; + +	for (bit = 0; bit < 8; bit++) { +		if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) +			crc = (crc << 1) ^ 0x8005; +		else +			crc = (crc << 1); +		byte <<= 1; +	} +	return crc; +} + +uint16_t +ao_fec_crc(const uint8_t *bytes, uint8_t len) +{ +	uint16_t	crc = AO_FEC_CRC_INIT; + +	while (len--) +		crc = ao_fec_crc_byte(*bytes++, crc); +	return crc; +} + +struct ao_lisp_macro_stack { +	struct ao_lisp_macro_stack *next; +	ao_poly	p; +}; + +struct ao_lisp_macro_stack *macro_stack; + +int +ao_lisp_macro_push(ao_poly p) +{ +	struct ao_lisp_macro_stack *m = macro_stack; + +	while (m) { +		if (m->p == p) +			return 1; +		m = m->next; +	} +	m = malloc (sizeof (struct ao_lisp_macro_stack)); +	m->p = p; +	m->next = macro_stack; +	macro_stack = m; +	return 0; +} + +void +ao_lisp_macro_pop(void) +{ +	struct ao_lisp_macro_stack *m = macro_stack; + +	macro_stack = m->next; +	free(m); +} + +#define DBG_MACRO 0 +#if DBG_MACRO +int macro_scan_depth; + +void indent(void) +{ +	int i; +	for (i = 0; i < macro_scan_depth; i++) +		printf("  "); +} +#define MACRO_DEBUG(a)	a +#else +#define MACRO_DEBUG(a) +#endif + +ao_poly +ao_has_macro(ao_poly p); + +ao_poly +ao_macro_test_get(ao_poly atom) +{ +	ao_poly	*ref = ao_lisp_atom_ref(ao_lisp_frame_global, atom); +	if (ref) +		return *ref; +	return AO_LISP_NIL; +} + +ao_poly +ao_is_macro(ao_poly p) +{ +	struct ao_lisp_builtin	*builtin; +	struct ao_lisp_lambda	*lambda; +	ao_poly ret; + +	MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); +	switch (ao_lisp_poly_type(p)) { +	case AO_LISP_ATOM: +		if (ao_lisp_macro_push(p)) +			ret = AO_LISP_NIL; +		else { +			if (ao_is_macro(ao_macro_test_get(p))) +				ret = p; +			else +				ret = AO_LISP_NIL; +			ao_lisp_macro_pop(); +		} +		break; +	case AO_LISP_CONS: +		ret = ao_has_macro(p); +		break; +	case AO_LISP_BUILTIN: +		builtin = ao_lisp_poly_builtin(p); +		if ((builtin->args & AO_LISP_FUNC_MASK) == AO_LISP_FUNC_MACRO) +			ret = p; +		else +			ret = 0; +		break; + +	case AO_LISP_LAMBDA: +		lambda = ao_lisp_poly_lambda(p); +		if (lambda->args == AO_LISP_FUNC_MACRO) +			ret = p; +		else +			ret = ao_has_macro(lambda->code); +		break; +	default: +		ret = AO_LISP_NIL; +		break; +	} +	MACRO_DEBUG(--macro_scan_depth;	indent(); printf ("... "); ao_lisp_poly_print(ret); printf("\n")); +	return ret; +} + +ao_poly +ao_has_macro(ao_poly p) +{ +	struct ao_lisp_cons	*cons; +	struct ao_lisp_lambda	*lambda; +	ao_poly			m; + +	if (p == AO_LISP_NIL) +		return AO_LISP_NIL; + +	MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); +	switch (ao_lisp_poly_type(p)) { +	case AO_LISP_LAMBDA: +		lambda = ao_lisp_poly_lambda(p); +		p = ao_has_macro(lambda->code); +		break; +	case AO_LISP_CONS: +		cons = ao_lisp_poly_cons(p); +		if ((p = ao_is_macro(cons->car))) +			break; + +		cons = ao_lisp_poly_cons(cons->cdr); +		p = AO_LISP_NIL; +		while (cons) { +			m = ao_has_macro(cons->car); +			if (m) { +				p = m; +				break; +			} +			cons = ao_lisp_poly_cons(cons->cdr); +		} +		break; + +	default: +		p = AO_LISP_NIL; +		break; +	} +	MACRO_DEBUG(--macro_scan_depth;	indent(); printf("... "); ao_lisp_poly_print(p); printf("\n")); +	return p; +} + +int +ao_lisp_read_eval_abort(void) +{ +	ao_poly	in, out = AO_LISP_NIL; +	for(;;) { +		in = ao_lisp_read(); +		if (in == _ao_lisp_atom_eof) +			break; +		out = ao_lisp_eval(in); +		if (ao_lisp_exception) +			return 0; +		ao_lisp_poly_print(out); +		putchar ('\n'); +	} +	return 1; +} + +static FILE	*in; +static FILE	*out; + +int +ao_lisp_getc(void) +{ +	return getc(in); +} + +static const struct option options[] = { +	{ .name = "out", .has_arg = 1, .val = 'o' }, +	{ 0, 0, 0, 0 } +}; + +static void usage(char *program) +{ +	fprintf(stderr, "usage: %s [--out=<output>] [input]\n", program); +	exit(1); +} + +int +main(int argc, char **argv) +{ +	int	f, o; +	ao_poly	val; +	struct ao_lisp_atom	*a; +	struct ao_lisp_builtin	*b; +	int	in_atom = 0; +	char	*out_name = NULL; +	int	c; + +	in = stdin; +	out = stdout; + +	while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { +		switch (c) { +		case 'o': +			out_name = optarg; +			break; +		default: +			usage(argv[0]); +			break; +		} +	} + +	for (f = 0; f < (int) N_FUNC; f++) { +		b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); +		a = ao_lisp_atom_intern(funcs[f].name); +		ao_lisp_atom_set(ao_lisp_atom_poly(a), +				 ao_lisp_builtin_poly(b)); +	} + +	/* boolean constants */ +	ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), +			 AO_LISP_NIL); +	a = ao_lisp_atom_intern("t"); +	ao_lisp_atom_set(ao_lisp_atom_poly(a), +			 ao_lisp_atom_poly(a)); + +	/* end of file value */ +	a = ao_lisp_atom_intern("eof"); +	ao_lisp_atom_set(ao_lisp_atom_poly(a), +			 ao_lisp_atom_poly(a)); + +	if (argv[optind]){ +		in = fopen(argv[optind], "r"); +		if (!in) { +			perror(argv[optind]); +			exit(1); +		} +	} +	if (!ao_lisp_read_eval_abort()) { +		fprintf(stderr, "eval failed\n"); +		exit(1); +	} + +	/* Reduce to referenced values */ +	ao_lisp_collect(AO_LISP_COLLECT_FULL); + +	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: ", +			       ao_lisp_poly_atom(ao_lisp_frame_global->vals[f].atom)->name); +			ao_lisp_poly_print(val); +			printf("\n"); +			exit(1); +		} +	} + +	if (out_name) { +		out = fopen(out_name, "w"); +		if (!out) { +			perror(out_name); +			exit(1); +		} +	} + +	fprintf(out, "/* Generated file, do not edit */\n\n"); + +	fprintf(out, "#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); +	fprintf(out, "extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); +	fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); +	fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); +	fprintf(out, "#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); + + +	for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { +		char	*n = a->name, c; +		fprintf(out, "#define _ao_lisp_atom_"); +		while ((c = *n++)) { +			if (isalnum(c)) +				fprintf(out, "%c", c); +			else +				fprintf(out, "%02x", c); +		} +		fprintf(out, "  0x%04x\n", ao_lisp_atom_poly(a)); +	} +	fprintf(out, "#ifdef AO_LISP_CONST_BITS\n"); +	fprintf(out, "const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute((aligned(4))) = {"); +	for (o = 0; o < ao_lisp_top; o++) { +		uint8_t	c; +		if ((o & 0xf) == 0) +			fprintf(out, "\n\t"); +		else +			fprintf(out, " "); +		c = ao_lisp_const[o]; +		if (!in_atom) +			in_atom = is_atom(o); +		if (in_atom) { +			fprintf(out, " '%c',", c); +			in_atom--; +		} else { +			fprintf(out, "0x%02x,", c); +		} +	} +	fprintf(out, "\n};\n"); +	fprintf(out, "#endif /* AO_LISP_CONST_BITS */\n"); +	exit(0); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c new file mode 100644 index 00000000..d067ea07 --- /dev/null +++ b/src/lisp/ao_lisp_mem.c @@ -0,0 +1,880 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 AO_LISP_CONST_BITS + +#include "ao_lisp.h" +#include <stdio.h> + +#ifdef AO_LISP_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include <stdlib.h> +uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); +#define ao_lisp_pool ao_lisp_const +#undef AO_LISP_POOL +#define AO_LISP_POOL AO_LISP_POOL_CONST + +#else + +uint8_t	ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); + +#endif + +#ifndef DBG_MEM_STATS +#define DBG_MEM_STATS	DBG_MEM +#endif + +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_validate = 0; + +struct ao_lisp_record { +	struct ao_lisp_record		*next; +	const struct ao_lisp_type	*type; +	void				*addr; +	int				size; +}; + +static struct ao_lisp_record	*record_head, **record_tail; + +static void +ao_lisp_record_free(struct ao_lisp_record *record) +{ +	while (record) { +		struct ao_lisp_record *next = record->next; +		free(record); +		record = next; +	} +} + +static void +ao_lisp_record_reset(void) +{ +	ao_lisp_record_free(record_head); +	record_head = NULL; +	record_tail = &record_head; +} + +static void +ao_lisp_record(const struct ao_lisp_type	*type, +	       void				*addr, +	       int				size) +{ +	struct ao_lisp_record	*r = malloc(sizeof (struct ao_lisp_record)); + +	r->next = NULL; +	r->type = type; +	r->addr = addr; +	r->size = size; +	*record_tail = r; +	record_tail = &r->next; +} + +static struct ao_lisp_record * +ao_lisp_record_save(void) +{ +	struct ao_lisp_record *r = record_head; + +	record_head = NULL; +	record_tail = &record_head; +	return r; +} + +static void +ao_lisp_record_compare(char *where, +		       struct ao_lisp_record *a, +		       struct ao_lisp_record *b) +{ +	while (a && b) { +		if (a->type != b->type || a->size != b->size) { +			printf("%s record difers %d %s %d -> %d %s %d\n", +			       where, +			       MDBG_OFFSET(a->addr), +			       a->type->name, +			       a->size, +			       MDBG_OFFSET(b->addr), +			       b->type->name, +			       b->size); +			ao_lisp_abort(); +		} +		a = a->next; +		b = b->next; +	} +	if (a) { +		printf("%s record differs %d %s %d -> NULL\n", +		       where, +		       MDBG_OFFSET(a->addr), +		       a->type->name, +		       a->size); +		ao_lisp_abort(); +	} +	if (b) { +		printf("%s record differs NULL -> %d %s %d\n", +		       where, +		       MDBG_OFFSET(b->addr), +		       b->type->name, +		       b->size); +		ao_lisp_abort(); +	} +} + +#else +#define ao_lisp_record_reset() +#endif + +uint8_t	ao_lisp_exception; + +struct ao_lisp_root { +	const struct ao_lisp_type	*type; +	void				**addr; +}; + +static struct ao_lisp_cons 	*save_cons[2]; +static char			*save_string[2]; +static ao_poly			save_poly[3]; + +static const struct ao_lisp_root	ao_lisp_root[] = { +	{ +		.type = &ao_lisp_cons_type, +		.addr = (void **) &save_cons[0], +	}, +	{ +		.type = &ao_lisp_cons_type, +		.addr = (void **) &save_cons[1], +	}, +	{ +		.type = &ao_lisp_string_type, +		.addr = (void **) &save_string[0], +	}, +	{ +		.type = &ao_lisp_string_type, +		.addr = (void **) &save_string[1], +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &save_poly[0] +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &save_poly[1] +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &save_poly[2] +	}, +	{ +		.type = &ao_lisp_atom_type, +		.addr = (void **) &ao_lisp_atoms +	}, +	{ +		.type = &ao_lisp_frame_type, +		.addr = (void **) &ao_lisp_frame_global, +	}, +	{ +		.type = &ao_lisp_frame_type, +		.addr = (void **) &ao_lisp_frame_current, +	}, +	{ +		.type = &ao_lisp_stack_type, +		.addr = (void **) &ao_lisp_stack, +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &ao_lisp_v, +	}, +	{ +		.type = &ao_lisp_cons_type, +		.addr = (void **) &ao_lisp_read_cons, +	}, +	{ +		.type = &ao_lisp_cons_type, +		.addr = (void **) &ao_lisp_read_cons_tail, +	}, +	{ +		.type = &ao_lisp_cons_type, +		.addr = (void **) &ao_lisp_read_stack, +	}, +}; + +#define AO_LISP_ROOT	(sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) + +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], +	(const void **) &ao_lisp_frame_free_list[4], +	(const void **) &ao_lisp_frame_free_list[5], +}; + +#if AO_LISP_FRAME_FREE != 6 +#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) + +static uint8_t	ao_lisp_busy[AO_LISP_BUSY_SIZE]; +static uint8_t	ao_lisp_cons_note[AO_LISP_BUSY_SIZE]; +static uint8_t	ao_lisp_cons_last[AO_LISP_BUSY_SIZE]; +static uint8_t	ao_lisp_cons_noted; + +uint16_t	ao_lisp_top; + +struct ao_lisp_chunk { +	uint16_t		old_offset; +	union { +		uint16_t	size; +		uint16_t	new_offset; +	}; +}; + +#define AO_LISP_NCHUNK	64 + +static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM +	if (!AO_LISP_IS_POOL(addr)) +		ao_lisp_abort(); +#endif +	return ((uint8_t *) addr) - ao_lisp_pool; +} + +static inline void mark(uint8_t *tag, int offset) { +	int	byte = offset >> 5; +	int	bit = (offset >> 2) & 7; +	tag[byte] |= (1 << bit); +} + +static inline void clear(uint8_t *tag, int offset) { +	int	byte = offset >> 5; +	int	bit = (offset >> 2) & 7; +	tag[byte] &= ~(1 << bit); +} + +static inline int busy(uint8_t *tag, int offset) { +	int	byte = offset >> 5; +	int	bit = (offset >> 2) & 7; +	return (tag[byte] >> bit) & 1; +} + +static inline int min(int a, int b) { return a < b ? a : b; } +static inline int max(int a, int b) { return a > b ? a : b; } + +static inline int limit(int offset) { +	return min(AO_LISP_POOL, max(offset, 0)); +} + +static void +note_cons(uint16_t offset) +{ +	MDBG_MOVE("note cons %d\n", offset); +	ao_lisp_cons_noted = 1; +	mark(ao_lisp_cons_note, offset); +} + +static uint16_t	chunk_low, chunk_high; +static uint16_t	chunk_first, chunk_last; + +static int +find_chunk(uint16_t offset) +{ +	int l, r; +	/* Binary search for the location */ +	l = chunk_first; +	r = chunk_last - 1; +	while (l <= r) { +		int m = (l + r) >> 1; +		if (ao_lisp_chunk[m].old_offset < offset) +			l = m + 1; +		else +			r = m - 1; +	} +	return l; +} + +static void +note_chunk(uint16_t offset, uint16_t size) +{ +	int l; + +	if (offset < chunk_low || chunk_high <= offset) +		return; + +	l = find_chunk(offset); + +	/* +	 * The correct location is always in 'l', with r = l-1 being +	 * the entry before the right one +	 */ + +#if DBG_MEM +	/* Off the right side */ +	if (l >= AO_LISP_NCHUNK) +		ao_lisp_abort(); + +	/* Off the left side */ +	if (l == 0 && chunk_last && offset > ao_lisp_chunk[0].old_offset) +		ao_lisp_abort(); +#endif + +	/* Shuffle existing entries right */ +	int end = min(AO_LISP_NCHUNK, chunk_last + 1); + +	memmove(&ao_lisp_chunk[l+1], +		&ao_lisp_chunk[l], +		(end - (l+1)) * sizeof (struct ao_lisp_chunk)); + +	/* Add new entry */ +	ao_lisp_chunk[l].old_offset = offset; +	ao_lisp_chunk[l].size = size; + +	/* Increment the number of elements up to the size of the array */ +	if (chunk_last < AO_LISP_NCHUNK) +		chunk_last++; + +	/* Set the top address if the array is full */ +	if (chunk_last == AO_LISP_NCHUNK) +		chunk_high = ao_lisp_chunk[AO_LISP_NCHUNK-1].old_offset + +			ao_lisp_chunk[AO_LISP_NCHUNK-1].size; +} + +static void +reset_chunks(void) +{ +	chunk_high = ao_lisp_top; +	chunk_last = 0; +	chunk_first = 0; +} + +/* + * Walk all referenced objects calling functions on each one + */ + +static void +walk(int (*visit_addr)(const struct ao_lisp_type *type, void **addr), +     int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) +{ +	int i; + +	ao_lisp_record_reset(); +	memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); +	memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); +	ao_lisp_cons_noted = 0; +	for (i = 0; i < (int) AO_LISP_ROOT; i++) { +		if (ao_lisp_root[i].type) { +			void **a = ao_lisp_root[i].addr, *v; +			if (a && (v = *a)) { +				MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); +				visit_addr(ao_lisp_root[i].type, a); +			} +		} else { +			ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; +			if (a && (p = *a)) { +				MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); +				visit_poly(a, 0); +			} +		} +	} +	while (ao_lisp_cons_noted) { +		memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); +		memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); +		ao_lisp_cons_noted = 0; +		for (i = 0; i < AO_LISP_POOL; i += 4) { +			if (busy(ao_lisp_cons_last, i)) { +				void *v = ao_lisp_pool + i; +				MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); +				visit_addr(&ao_lisp_cons_type, &v); +			} +		} +	} +} + +#if MDBG_DUMP +static void +dump_busy(void) +{ +	int	i; +	MDBG_MOVE("busy:"); +	for (i = 0; i < ao_lisp_top; i += 4) { +		if ((i & 0xff) == 0) { +			MDBG_MORE("\n"); +			MDBG_MOVE("%s", ""); +		} +		else if ((i & 0x1f) == 0) +			MDBG_MORE(" "); +		if (busy(ao_lisp_busy, i)) +			MDBG_MORE("*"); +		else +			MDBG_MORE("-"); +	} +	MDBG_MORE ("\n"); +} +#define DUMP_BUSY()	dump_busy() +#else +#define DUMP_BUSY() +#endif + +static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { +	[AO_LISP_CONS] = &ao_lisp_cons_type, +	[AO_LISP_INT] = NULL, +	[AO_LISP_STRING] = &ao_lisp_string_type, +	[AO_LISP_OTHER] = (void *) 0x1, +	[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, +	[AO_LISP_STACK] = &ao_lisp_stack_type, +}; + +static int +ao_lisp_mark_ref(const struct ao_lisp_type *type, void **ref) +{ +	return ao_lisp_mark(type, *ref); +} + +static int +ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) +{ +	return ao_lisp_poly_mark(*p, do_note_cons); +} + +#if DBG_MEM_STATS +int ao_lisp_collects[2]; +int ao_lisp_freed[2]; +int ao_lisp_loops[2]; +#endif + +int ao_lisp_last_top; + +int +ao_lisp_collect(uint8_t style) +{ +	int	i; +	int	top; +#if DBG_MEM_STATS +	int	loops = 0; +#endif +#if DBG_MEM +	struct ao_lisp_record	*mark_record = NULL, *move_record = NULL; + +	MDBG_MOVE("collect %d\n", ao_lisp_collects[style]); +#endif + +	/* The first time through, we're doing a full collect */ +	if (ao_lisp_last_top == 0) +		style = AO_LISP_COLLECT_FULL; + +	/* Clear references to all caches */ +	for (i = 0; i < (int) AO_LISP_CACHE; i++) +		*ao_lisp_cache[i] = NULL; +	if (style == AO_LISP_COLLECT_FULL) { +		chunk_low = top = 0; +	} else { +		chunk_low = top = ao_lisp_last_top; +	} +	for (;;) { +#if DBG_MEM_STATS +		loops++; +#endif +		MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); +		/* Find the sizes of the first chunk of objects to move */ +		reset_chunks(); +		walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); +#if DBG_MEM + +		ao_lisp_record_free(mark_record); +		mark_record = ao_lisp_record_save(); +		if (mark_record && move_record) +			ao_lisp_record_compare("mark", move_record, mark_record); +#endif + +		DUMP_BUSY(); + +		/* Find the first moving object */ +		for (i = 0; i < chunk_last; i++) { +			uint16_t	size = ao_lisp_chunk[i].size; + +#if DBG_MEM +			if (!size) +				ao_lisp_abort(); +#endif + +			if (ao_lisp_chunk[i].old_offset > top) +				break; + +			MDBG_MOVE("chunk %d %d not moving\n", +				  ao_lisp_chunk[i].old_offset, +				  ao_lisp_chunk[i].size); +#if DBG_MEM +			if (ao_lisp_chunk[i].old_offset != top) +				ao_lisp_abort(); +#endif +			top += size; +		} + +		/* +		 * Limit amount of chunk array used in mapping moves +		 * to the active region +		 */ +		chunk_first = i; +		chunk_low = ao_lisp_chunk[i].old_offset; + +		/* Copy all of the objects */ +		for (; i < chunk_last; i++) { +			uint16_t	size = ao_lisp_chunk[i].size; + +#if DBG_MEM +			if (!size) +				ao_lisp_abort(); +#endif + +			MDBG_MOVE("chunk %d %d -> %d\n", +				  ao_lisp_chunk[i].old_offset, +				  size, +				  top); +			ao_lisp_chunk[i].new_offset = top; + +			memmove(&ao_lisp_pool[top], +				&ao_lisp_pool[ao_lisp_chunk[i].old_offset], +				size); + +			top += size; +		} + +		if (chunk_first < chunk_last) { +			/* Relocate all references to the objects */ +			walk(ao_lisp_move, ao_lisp_poly_move); + +#if DBG_MEM +			ao_lisp_record_free(move_record); +			move_record = ao_lisp_record_save(); +			if (mark_record && move_record) +				ao_lisp_record_compare("move", mark_record, move_record); +#endif +		} + +		/* If we ran into the end of the heap, then +		 * there's no need to keep walking +		 */ +		if (chunk_last != AO_LISP_NCHUNK) +			break; + +		/* Next loop starts right above this loop */ +		chunk_low = chunk_high; +	} + +#if DBG_MEM_STATS +	/* Collect stats */ +	++ao_lisp_collects[style]; +	ao_lisp_freed[style] += ao_lisp_top - top; +	ao_lisp_loops[style] += loops; +#endif + +	ao_lisp_top = top; +	if (style == AO_LISP_COLLECT_FULL) +		ao_lisp_last_top = top; + +	MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); +		walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); + +	return AO_LISP_POOL - ao_lisp_top; +} + +/* + * Mark interfaces for objects + */ + +/* + * Note a reference to memory and collect information about a few + * object sizes at a time + */ + +int +ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) +{ +	int offset; +	if (!AO_LISP_IS_POOL(addr)) +		return 1; + +	offset = pool_offset(addr); +	MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); +	if (busy(ao_lisp_busy, offset)) { +		MDBG_MOVE("already marked\n"); +		return 1; +	} +	mark(ao_lisp_busy, offset); +	note_chunk(offset, ao_lisp_size(type, addr)); +	return 0; +} + +/* + * Mark an object and all that it refereces + */ +int +ao_lisp_mark(const struct ao_lisp_type *type, void *addr) +{ +	int ret; +	MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); +	MDBG_MOVE_IN(); +	ret = ao_lisp_mark_memory(type, addr); +	if (!ret) { +		MDBG_MOVE("mark recurse\n"); +		type->mark(addr); +	} +	MDBG_MOVE_OUT(); +	return ret; +} + +/* + * Mark an object, unless it is a cons cell and + * do_note_cons is set. In that case, just + * set a bit in the cons note array; those + * will be marked in a separate pass to avoid + * deep recursion in the collector + */ +int +ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) +{ +	uint8_t type; +	void	*addr; + +	type = ao_lisp_poly_base_type(p); + +	if (type == AO_LISP_INT) +		return 1; + +	addr = ao_lisp_ref(p); +	if (!AO_LISP_IS_POOL(addr)) +		return 1; + +	if (type == AO_LISP_CONS && do_note_cons) { +		note_cons(pool_offset(addr)); +		return 1; +	} else { +		if (type == AO_LISP_OTHER) +			type = ao_lisp_other_type(addr); + +		const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; +#if DBG_MEM +		if (!lisp_type) +			ao_lisp_abort(); +#endif + +		return ao_lisp_mark(lisp_type, addr); +	} +} + +/* + * Find the current location of an object + * based on the original location. For unmoved + * objects, this is simple. For moved objects, + * go search for it + */ + +static uint16_t +move_map(uint16_t offset) +{ +	int		l; + +	if (offset < chunk_low || chunk_high <= offset) +		return offset; + +	l = find_chunk(offset); + +#if DBG_MEM +	if (ao_lisp_chunk[l].old_offset != offset) +		ao_lisp_abort(); +#endif +	return ao_lisp_chunk[l].new_offset; +} + +int +ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) +{ +	void		*addr = *ref; +	uint16_t	offset, orig_offset; + +	if (!AO_LISP_IS_POOL(addr)) +		return 1; + +	(void) type; + +	MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); +	orig_offset = pool_offset(addr); +	offset = move_map(orig_offset); +	if (offset != orig_offset) { +		MDBG_MOVE("update ref %d %d -> %d\n", +			  AO_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, +			  orig_offset, offset); +		*ref = ao_lisp_pool + offset; +	} +	if (busy(ao_lisp_busy, offset)) { +		MDBG_MOVE("already moved\n"); +		return 1; +	} +	mark(ao_lisp_busy, offset); +	MDBG_DO(ao_lisp_record(type, addr, ao_lisp_size(type, addr))); +	return 0; +} + +int +ao_lisp_move(const struct ao_lisp_type *type, void **ref) +{ +	int ret; +	MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); +	MDBG_MOVE_IN(); +	ret = ao_lisp_move_memory(type, ref); +	if (!ret) { +		MDBG_MOVE("move recurse\n"); +		type->move(*ref); +	} +	MDBG_MOVE_OUT(); +	return ret; +} + +int +ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) +{ +	uint8_t		type; +	ao_poly		p = *ref; +	int		ret; +	void		*addr; +	uint16_t	offset, orig_offset; +	uint8_t		base_type; + +	base_type = type = ao_lisp_poly_base_type(p); + +	if (type == AO_LISP_INT) +		return 1; + +	addr = ao_lisp_ref(p); +	if (!AO_LISP_IS_POOL(addr)) +		return 1; + +	orig_offset = pool_offset(addr); +	offset = move_map(orig_offset); + +	if (type == AO_LISP_CONS && do_note_cons) { +		note_cons(orig_offset); +		ret = 1; +	} else { +		if (type == AO_LISP_OTHER) +			type = ao_lisp_other_type(ao_lisp_pool + offset); + +		const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; +#if DBG_MEM +		if (!lisp_type) +			ao_lisp_abort(); +#endif + +		ret = ao_lisp_move(lisp_type, &addr); +	} + +	/* Re-write the poly value */ +	if (offset != orig_offset) { +		ao_poly np = ao_lisp_poly(ao_lisp_pool + offset, base_type); +		MDBG_MOVE("poly %d moved %d -> %d\n", +			  type, orig_offset, offset); +		*ref = np; +	} +	return ret; +} + +#if DBG_MEM +void +ao_lisp_validate(void) +{ +	chunk_low = 0; +	memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); +	walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); +} + +int dbg_allocs; + +#endif + +void * +ao_lisp_alloc(int size) +{ +	void	*addr; + +	MDBG_DO(++dbg_allocs); +	MDBG_DO(if (dbg_validate) ao_lisp_validate()); +	size = ao_lisp_size_round(size); +	if (AO_LISP_POOL - ao_lisp_top < size && +	    ao_lisp_collect(AO_LISP_COLLECT_INCREMENTAL) < size && +	    ao_lisp_collect(AO_LISP_COLLECT_FULL) < size) +	{ +		ao_lisp_error(AO_LISP_OOM, "out of memory"); +		return NULL; +	} +	addr = ao_lisp_pool + ao_lisp_top; +	ao_lisp_top += size; +	return addr; +} + +void +ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) +{ +	save_cons[id] = cons; +} + +struct ao_lisp_cons * +ao_lisp_cons_fetch(int id) +{ +	struct ao_lisp_cons *cons = save_cons[id]; +	save_cons[id] = NULL; +	return cons; +} + +void +ao_lisp_poly_stash(int id, ao_poly poly) +{ +	save_poly[id] = poly; +} + +ao_poly +ao_lisp_poly_fetch(int id) +{ +	ao_poly poly = save_poly[id]; +	save_poly[id] = AO_LISP_NIL; +	return poly; +} + +void +ao_lisp_string_stash(int id, char *string) +{ +	save_string[id] = string; +} + +char * +ao_lisp_string_fetch(int id) +{ +	char *string = save_string[id]; +	save_string[id] = NULL; +	return string; +} + diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h new file mode 100644 index 00000000..5fa3686b --- /dev/null +++ b/src/lisp/ao_lisp_os.h @@ -0,0 +1,53 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_LISP_OS_H_ +#define _AO_LISP_OS_H_ + +#include <stdio.h> +#include <stdlib.h> +#include <time.h> + +extern int ao_lisp_getc(void); + +static inline void +ao_lisp_os_flush(void) { +	fflush(stdout); +} + +static inline void +ao_lisp_abort(void) +{ +	abort(); +} + +static inline void +ao_lisp_os_led(int led) +{ +	printf("leds set to 0x%x\n", led); +} + +static inline void +ao_lisp_os_delay(int delay) +{ +	struct timespec ts = { +		.tv_sec = delay / 1000, +		.tv_nsec = (delay % 1000) * 1000000, +	}; +	nanosleep(&ts, NULL); +} +#endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c new file mode 100644 index 00000000..fb3b06fe --- /dev/null +++ b/src/lisp/ao_lisp_poly.c @@ -0,0 +1,102 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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" + +struct ao_lisp_funcs { +	void (*print)(ao_poly); +	void (*patom)(ao_poly); +}; + +static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { +	[AO_LISP_CONS] = { +		.print = ao_lisp_cons_print, +		.patom = ao_lisp_cons_patom, +	}, +	[AO_LISP_STRING] = { +		.print = ao_lisp_string_print, +		.patom = ao_lisp_string_patom, +	}, +	[AO_LISP_INT] = { +		.print = ao_lisp_int_print, +		.patom = ao_lisp_int_print, +	}, +	[AO_LISP_ATOM] = { +		.print = ao_lisp_atom_print, +		.patom = ao_lisp_atom_print, +	}, +	[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, +	}, +	[AO_LISP_STACK] = { +		.print = ao_lisp_stack_print, +		.patom = ao_lisp_stack_print, +	}, +}; + +static const struct ao_lisp_funcs * +funcs(ao_poly p) +{ +	uint8_t	type = ao_lisp_poly_type(p); + +	if (type < AO_LISP_NUM_TYPE) +		return &ao_lisp_funcs[type]; +	return NULL; +} + +void +ao_lisp_poly_print(ao_poly p) +{ +	const struct ao_lisp_funcs *f = funcs(p); + +	if (f && f->print) +		f->print(p); +} + +void +ao_lisp_poly_patom(ao_poly p) +{ +	const struct ao_lisp_funcs *f = funcs(p); + +	if (f && f->patom) +		f->patom(p); +} + +void * +ao_lisp_ref(ao_poly poly) { +	if (poly == AO_LISP_NIL) +		return NULL; +	if (poly & AO_LISP_CONST) +		return (void *) (ao_lisp_const + (poly & AO_LISP_REF_MASK) - 4); +	return (void *) (ao_lisp_pool + (poly & AO_LISP_REF_MASK) - 4); +} + +ao_poly +ao_lisp_poly(const void *addr, ao_poly type) { +	const uint8_t	*a = addr; +	if (a == NULL) +		return AO_LISP_NIL; +	if (AO_LISP_IS_CONST(a)) +		return AO_LISP_CONST | (a - ao_lisp_const + 4) | type; +	return (a - ao_lisp_pool + 4) | type; +} diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c new file mode 100644 index 00000000..84ef2a61 --- /dev/null +++ b/src/lisp/ao_lisp_read.c @@ -0,0 +1,498 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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_lisp_read.h" + +static const uint16_t	lex_classes[128] = { +	IGNORE,		/* ^@ */ +	IGNORE,		/* ^A */ +	IGNORE,		/* ^B */ +	IGNORE,		/* ^C */ +	IGNORE,		/* ^D */ +	IGNORE,		/* ^E */ +	IGNORE,		/* ^F */ +	IGNORE,		/* ^G */ +	IGNORE,		/* ^H */ +	WHITE,		/* ^I */ +	WHITE,		/* ^J */ +	WHITE,		/* ^K */ +	WHITE,		/* ^L */ +	WHITE,		/* ^M */ +	IGNORE,		/* ^N */ +	IGNORE,		/* ^O */ +	IGNORE,		/* ^P */ +	IGNORE,		/* ^Q */ +	IGNORE,		/* ^R */ +	IGNORE,		/* ^S */ +	IGNORE,		/* ^T */ +	IGNORE,		/* ^U */ +	IGNORE,		/* ^V */ +	IGNORE,		/* ^W */ +	IGNORE,		/* ^X */ +	IGNORE,		/* ^Y */ +	IGNORE,		/* ^Z */ +	IGNORE,		/* ^[ */ +	IGNORE,		/* ^\ */ +	IGNORE,		/* ^] */ +	IGNORE,		/* ^^ */ +	IGNORE,		/* ^_ */ +	PRINTABLE|WHITE,	/*    */ + 	PRINTABLE,		/* ! */ + 	PRINTABLE|STRINGC,	/* " */ + 	PRINTABLE|COMMENT,	/* # */ + 	PRINTABLE,		/* $ */ + 	PRINTABLE,		/* % */ + 	PRINTABLE,		/* & */ + 	PRINTABLE|QUOTEC,	/* ' */ + 	PRINTABLE|BRA,		/* ( */ + 	PRINTABLE|KET,		/* ) */ + 	PRINTABLE,		/* * */ + 	PRINTABLE|SIGN,		/* + */ + 	PRINTABLE,		/* , */ + 	PRINTABLE|SIGN,		/* - */ + 	PRINTABLE,		/* . */ + 	PRINTABLE,		/* / */ + 	PRINTABLE|DIGIT,	/* 0 */ + 	PRINTABLE|DIGIT,	/* 1 */ + 	PRINTABLE|DIGIT,	/* 2 */ + 	PRINTABLE|DIGIT,	/* 3 */ + 	PRINTABLE|DIGIT,	/* 4 */ + 	PRINTABLE|DIGIT,	/* 5 */ + 	PRINTABLE|DIGIT,	/* 6 */ + 	PRINTABLE|DIGIT,	/* 7 */ + 	PRINTABLE|DIGIT,	/* 8 */ + 	PRINTABLE|DIGIT,	/* 9 */ + 	PRINTABLE,		/* : */ + 	PRINTABLE|COMMENT,	/* ; */ + 	PRINTABLE,		/* < */ + 	PRINTABLE,		/* = */ + 	PRINTABLE,		/* > */ + 	PRINTABLE,		/* ? */ +  	PRINTABLE,		/*  @ */ +	PRINTABLE,		/*  A */ +	PRINTABLE,		/*  B */ +	PRINTABLE,		/*  C */ +	PRINTABLE,		/*  D */ +	PRINTABLE,		/*  E */ +	PRINTABLE,		/*  F */ +	PRINTABLE,		/*  G */ +	PRINTABLE,		/*  H */ +	PRINTABLE,		/*  I */ +	PRINTABLE,		/*  J */ +	PRINTABLE,		/*  K */ +	PRINTABLE,		/*  L */ +	PRINTABLE,		/*  M */ +	PRINTABLE,		/*  N */ +	PRINTABLE,		/*  O */ +	PRINTABLE,		/*  P */ +	PRINTABLE,		/*  Q */ +	PRINTABLE,		/*  R */ +	PRINTABLE,		/*  S */ +	PRINTABLE,		/*  T */ +	PRINTABLE,		/*  U */ +	PRINTABLE,		/*  V */ +	PRINTABLE,		/*  W */ +	PRINTABLE,		/*  X */ +	PRINTABLE,		/*  Y */ +	PRINTABLE,		/*  Z */ +	PRINTABLE,		/*  [ */ +	PRINTABLE|BACKSLASH,	/*  \ */ +	PRINTABLE,		/*  ] */ +	PRINTABLE,		/*  ^ */ +	PRINTABLE,		/*  _ */ +  	PRINTABLE,		/*  ` */ +	PRINTABLE,		/*  a */ +	PRINTABLE,		/*  b */ +	PRINTABLE,		/*  c */ +	PRINTABLE,		/*  d */ +	PRINTABLE,		/*  e */ +	PRINTABLE,		/*  f */ +	PRINTABLE,		/*  g */ +	PRINTABLE,		/*  h */ +	PRINTABLE,		/*  i */ +	PRINTABLE,		/*  j */ +	PRINTABLE,		/*  k */ +	PRINTABLE,		/*  l */ +	PRINTABLE,		/*  m */ +	PRINTABLE,		/*  n */ +	PRINTABLE,		/*  o */ +	PRINTABLE,		/*  p */ +	PRINTABLE,		/*  q */ +	PRINTABLE,		/*  r */ +	PRINTABLE,		/*  s */ +	PRINTABLE,		/*  t */ +	PRINTABLE,		/*  u */ +	PRINTABLE,		/*  v */ +	PRINTABLE,		/*  w */ +	PRINTABLE,		/*  x */ +	PRINTABLE,		/*  y */ +	PRINTABLE,		/*  z */ +	PRINTABLE,		/*  { */ +	PRINTABLE|VBAR,		/*  | */ +	PRINTABLE,		/*  } */ +	PRINTABLE|TWIDDLE,	/*  ~ */ +	IGNORE,			/*  ^? */ +}; + +static int lex_unget_c; + +static inline int +lex_get() +{ +	int	c; +	if (lex_unget_c) { +		c = lex_unget_c; +		lex_unget_c = 0; +	} else { +		c = ao_lisp_getc(); +	} +	return c; +} + +static inline void +lex_unget(int c) +{ +	if (c != EOF) +		lex_unget_c = c; +} + +static int +lex_quoted (void) +{ +	int	c; +	int	v; +	int	count; + +	c = lex_get(); +	if (c == EOF) +		return EOF; +	c &= 0x7f; + 	switch (c) { +	case 'n': +		return '\n'; +	case 'f': +		return '\f'; +	case 'b': +		return '\b'; +	case 'r': +		return '\r'; +	case 'v': +		return '\v'; +	case 't': +		return '\t'; +	case '0': +	case '1': +	case '2': +	case '3': +	case '4': +	case '5': +	case '6': +	case '7': +		v = c - '0'; +		count = 1; +		while (count <= 3) { +			c = lex_get(); +			if (c == EOF) +				return EOF; +			c &= 0x7f; +			if (c < '0' || '7' < c) { +				lex_unget(c); +				break; +			} +			v = (v << 3) + c - '0'; +			++count; +		} +		return v; +	default: +		return c; +	} +} + +static uint16_t	lex_class; + +static int +lexc(void) +{ +	int	c; +	do { +		c = lex_get(); +		if (c == EOF) { +			lex_class = ENDOFFILE; +			c = 0; +		} else { +			c &= 0x7f; +			lex_class = lex_classes[c]; +			if (lex_class & BACKSLASH) { +				c = lex_quoted(); +				if (c == EOF) +					lex_class = ENDOFFILE; +				else +					lex_class = PRINTABLE; +			} +		} +	} while (lex_class & IGNORE); +	return c; +} + +#define AO_LISP_TOKEN_MAX	32 + +static char	token_string[AO_LISP_TOKEN_MAX]; +static int	token_int; +static int	token_len; + +static inline void add_token(int c) { +	if (c && token_len < AO_LISP_TOKEN_MAX - 1) +		token_string[token_len++] = c; +} + +static inline void end_token(void) { +	token_string[token_len] = '\0'; +} + +static int +lex(void) +{ +	int	c; + +	token_len = 0; +	for (;;) { +		c = lexc(); +		if (lex_class & ENDOFFILE) +			return END; + +		if (lex_class & WHITE) +			continue; + +		if (lex_class & COMMENT) { +			while ((c = lexc()) != '\n') { +				if (lex_class & ENDOFFILE) +					return END; +			} +			continue; +		} + +		if (lex_class & (BRA|KET|QUOTEC)) { +			add_token(c); +			end_token(); +			switch (c) { +			case '(': +				return OPEN; +			case ')': +				return CLOSE; +			case '\'': +				return QUOTE; +			} +		} +		if (lex_class & TWIDDLE) { +			token_int = lexc(); +			return NUM; +		} +		if (lex_class & STRINGC) { +			for (;;) { +				c = lexc(); +				if (lex_class & (STRINGC|ENDOFFILE)) { +					end_token(); +					return STRING; +				} +				add_token(c); +			} +		} +		if (lex_class & PRINTABLE) { +			int	isnum; +			int	hasdigit; +			int	isneg; + +			isnum = 1; +			hasdigit = 0; +			token_int = 0; +			isneg = 0; +			for (;;) { +				if (!(lex_class & NUMBER)) { +					isnum = 0; +				} else { + 					if (token_len != 0 && +					    (lex_class & SIGN)) +					{ +						isnum = 0; +					} +					if (c == '-') +						isneg = 1; +					if (lex_class & DIGIT) { +						hasdigit = 1; +						if (isnum) +							token_int = token_int * 10 + c - '0'; +					} +				} +				add_token (c); +				c = lexc (); +				if (lex_class & (NOTNAME)) { +//					if (lex_class & ENDOFFILE) +//						clearerr (f); +					lex_unget(c); +					end_token (); +					if (isnum && hasdigit) { +						if (isneg) +							token_int = -token_int; +						return NUM; +					} +					return NAME; +				} +			} + +		} +	} +} + +static int parse_token; + +struct ao_lisp_cons	*ao_lisp_read_cons; +struct ao_lisp_cons	*ao_lisp_read_cons_tail; +struct ao_lisp_cons	*ao_lisp_read_stack; + +static int +push_read_stack(int cons, int in_quote) +{ +	DBGI("push read stack %p %d\n", ao_lisp_read_cons, in_quote); +	DBG_IN(); +	if (cons) { +		ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), +					       ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), +								 ao_lisp_read_stack)); +		if (!ao_lisp_read_stack) +			return 0; +	} +	ao_lisp_read_cons = NULL; +	ao_lisp_read_cons_tail = NULL; +	return 1; +} + +static int +pop_read_stack(int cons) +{ +	int	in_quote = 0; +	if (cons) { +		ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); +		ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); +		in_quote = ao_lisp_poly_int(ao_lisp_read_stack->car); +		ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); +		for (ao_lisp_read_cons_tail = ao_lisp_read_cons; +		     ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; +		     ao_lisp_read_cons_tail = ao_lisp_poly_cons(ao_lisp_read_cons_tail->cdr)) +			; +	} else { +		ao_lisp_read_cons = 0; +		ao_lisp_read_cons_tail = 0; +		ao_lisp_read_stack = 0; +	} +	DBG_OUT(); +	DBGI("pop read stack %p %d\n", ao_lisp_read_cons, in_quote); +	return in_quote; +} + +ao_poly +ao_lisp_read(void) +{ +	struct ao_lisp_atom	*atom; +	char			*string; +	int			cons; +	int			in_quote; +	ao_poly			v; + +	parse_token = lex(); +	DBGI("token %d (%s)\n", parse_token, token_string); + +	cons = 0; +	in_quote = 0; +	ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; +	for (;;) { +		while (parse_token == OPEN) { +			if (!push_read_stack(cons, in_quote)) +				return AO_LISP_NIL; +			cons++; +			in_quote = 0; +			parse_token = lex(); +			DBGI("token %d (%s)\n", parse_token, token_string); +		} + +		switch (parse_token) { +		case END: +		default: +			if (cons) +				ao_lisp_error(AO_LISP_EOF, "unexpected end of file"); +			return _ao_lisp_atom_eof; +			break; +		case NAME: +			atom = ao_lisp_atom_intern(token_string); +			if (atom) +				v = ao_lisp_atom_poly(atom); +			else +				v = AO_LISP_NIL; +			break; +		case NUM: +			v = ao_lisp_int_poly(token_int); +			break; +		case STRING: +			string = ao_lisp_string_copy(token_string); +			if (string) +				v = ao_lisp_string_poly(string); +			else +				v = AO_LISP_NIL; +			break; +		case QUOTE: +			if (!push_read_stack(cons, in_quote)) +				return AO_LISP_NIL; +			cons++; +			in_quote = 1; +			v = _ao_lisp_atom_quote; +			break; +		case CLOSE: +			if (!cons) { +				v = AO_LISP_NIL; +				break; +			} +			v = ao_lisp_cons_poly(ao_lisp_read_cons); +			--cons; +			in_quote = pop_read_stack(cons); +			break; +		} + +		/* loop over QUOTE ends */ +		for (;;) { +			if (!cons) +				return v; + +			struct ao_lisp_cons	*read = ao_lisp_cons_cons(v, NULL); +			if (!read) +				return AO_LISP_NIL; + +			if (ao_lisp_read_cons_tail) +				ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); +			else +				ao_lisp_read_cons = read; +			ao_lisp_read_cons_tail = read; + +			if (!in_quote || !ao_lisp_read_cons->cdr) +				break; + +			v = ao_lisp_cons_poly(ao_lisp_read_cons); +			--cons; +			in_quote = pop_read_stack(cons); +		} + +		parse_token = lex(); +		DBGI("token %d (%s)\n", parse_token, token_string); +	} +	return v; +} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h new file mode 100644 index 00000000..1c994d56 --- /dev/null +++ b/src/lisp/ao_lisp_read.h @@ -0,0 +1,49 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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. + */ + +#ifndef _AO_LISP_READ_H_ +#define _AO_LISP_READ_H_ + +# define END	0 +# define NAME	1 +# define OPEN  	2 +# define CLOSE	3 +# define QUOTE	4 +# define STRING	5 +# define NUM	6 + +/* + * character classes + */ + +# define PRINTABLE	0x00000001	/* \t \n ' ' - '~' */ +# define QUOTED		0x00000002	/* \ anything */ +# define BRA		0x00000004	/* ( [ { */ +# define KET		0x00000008	/* ) ] } */ +# define WHITE		0x00000010	/* ' ' \t \n */ +# define DIGIT		0x00000020	/* [0-9] */ +# define SIGN		0x00000040	/* +- */ +# define ENDOFFILE	0x00000080	/* end of file */ +# define COMMENT	0x00000100	/* ; # */ +# define IGNORE		0x00000200	/* \0 - ' ' */ +# define QUOTEC		0x00000400	/* ' */ +# define BACKSLASH	0x00000800	/* \ */ +# define VBAR		0x00001000	/* | */ +# define TWIDDLE	0x00002000	/* ~ */ +# define STRINGC	0x00004000	/* " */ + +# define NOTNAME	(STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA) +# define NUMBER		(DIGIT|SIGN) + +#endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c new file mode 100644 index 00000000..3be95d44 --- /dev/null +++ b/src/lisp/ao_lisp_rep.c @@ -0,0 +1,34 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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" + +ao_poly +ao_lisp_read_eval_print(void) +{ +	ao_poly	in, out = AO_LISP_NIL; +	for(;;) { +		in = ao_lisp_read(); +		if (in == _ao_lisp_atom_eof || in == AO_LISP_NIL) +			break; +		out = ao_lisp_eval(in); +		if (ao_lisp_exception) { +			ao_lisp_exception = 0; +		} else { +			ao_lisp_poly_print(out); +			putchar ('\n'); +		} +	} +	return out; +} diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c new file mode 100644 index 00000000..4f850fb9 --- /dev/null +++ b/src/lisp/ao_lisp_save.c @@ -0,0 +1,76 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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> + +ao_poly +ao_lisp_save(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) +		return AO_LISP_NIL; + +#ifdef AO_LISP_SAVE +	struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; + +	ao_lisp_collect(AO_LISP_COLLECT_FULL); +	os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); +	os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); +	os->const_checksum = ao_lisp_const_checksum; +	os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; + +	if (ao_lisp_os_save()) +		return _ao_lisp_atom_t; +#endif +	return AO_LISP_NIL; +} + +ao_poly +ao_lisp_restore(struct ao_lisp_cons *cons) +{ +	if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) +		return AO_LISP_NIL; + +#ifdef AO_LISP_SAVE +	struct ao_lisp_os_save save; +	struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; + +	if (!ao_lisp_os_restore_save(&save, AO_LISP_POOL)) +		return ao_lisp_error(AO_LISP_INVALID, "header restore failed"); + +	if (save.const_checksum != ao_lisp_const_checksum || +	    save.const_checksum_inv != (uint16_t) ~ao_lisp_const_checksum) +	{ +		return ao_lisp_error(AO_LISP_INVALID, "image is corrupted or stale"); +	} + +	if (ao_lisp_os_restore()) { + +		ao_lisp_atoms = ao_lisp_poly_atom(os->atoms); +		ao_lisp_frame_global = ao_lisp_poly_frame(os->globals); + +		/* Clear the eval global variabls */ +		ao_lisp_eval_clear_globals(); + +		/* Reset the allocator */ +		ao_lisp_top = AO_LISP_POOL; +		ao_lisp_collect(AO_LISP_COLLECT_FULL); + +		/* Re-create the evaluator stack */ +		if (!ao_lisp_eval_restart()) +			return AO_LISP_NIL; +		return _ao_lisp_atom_t; +	} +#endif +	return AO_LISP_NIL; +} diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c new file mode 100644 index 00000000..53adf432 --- /dev/null +++ b/src/lisp/ao_lisp_stack.c @@ -0,0 +1,278 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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" + +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); + +	while (s) { +		if (s->type & AO_LISP_STACK_PRINT) { +			printf("[recurse...]"); +			return; +		} +		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; +} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c new file mode 100644 index 00000000..cd7b27a9 --- /dev/null +++ b/src/lisp/ao_lisp_string.c @@ -0,0 +1,158 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_lisp.h" + +static void string_mark(void *addr) +{ +	(void) addr; +} + +static int string_size(void *addr) +{ +	if (!addr) +		return 0; +	return strlen(addr) + 1; +} + +static void string_move(void *addr) +{ +	(void) addr; +} + +const struct ao_lisp_type ao_lisp_string_type = { +	.mark = string_mark, +	.size = string_size, +	.move = string_move, +	.name = "string", +}; + +char * +ao_lisp_string_copy(char *a) +{ +	int	alen = strlen(a); + +	ao_lisp_string_stash(0, a); +	char	*r = ao_lisp_alloc(alen + 1); +	a = ao_lisp_string_fetch(0); +	if (!r) +		return NULL; +	strcpy(r, a); +	return r; +} + +char * +ao_lisp_string_cat(char *a, char *b) +{ +	int	alen = strlen(a); +	int	blen = strlen(b); + +	ao_lisp_string_stash(0, a); +	ao_lisp_string_stash(1, b); +	char	*r = ao_lisp_alloc(alen + blen + 1); +	a = ao_lisp_string_fetch(0); +	b = ao_lisp_string_fetch(1); +	if (!r) +		return NULL; +	strcpy(r, a); +	strcpy(r+alen, b); +	return r; +} + +ao_poly +ao_lisp_string_pack(struct ao_lisp_cons *cons) +{ +	int	len = ao_lisp_cons_length(cons); +	ao_lisp_cons_stash(0, cons); +	char	*r = ao_lisp_alloc(len + 1); +	cons = ao_lisp_cons_fetch(0); +	char	*s = r; + +	while (cons) { +		if (ao_lisp_poly_type(cons->car) != AO_LISP_INT) +			return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); +		*s++ = ao_lisp_poly_int(cons->car); +		cons = ao_lisp_poly_cons(cons->cdr); +	} +	*s++ = 0; +	return ao_lisp_string_poly(r); +} + +ao_poly +ao_lisp_string_unpack(char *a) +{ +	struct ao_lisp_cons	*cons = NULL, *tail = NULL; +	int			c; +	int			i; + +	for (i = 0; (c = a[i]); i++) { +		ao_lisp_cons_stash(0, cons); +		ao_lisp_cons_stash(1, tail); +		ao_lisp_string_stash(0, a); +		struct ao_lisp_cons	*n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); +		a = ao_lisp_string_fetch(0); +		cons = ao_lisp_cons_fetch(0); +		tail = ao_lisp_cons_fetch(1); + +		if (!n) { +			cons = NULL; +			break; +		} +		if (tail) +			tail->cdr = ao_lisp_cons_poly(n); +		else +			cons = n; +		tail = n; +	} +	return ao_lisp_cons_poly(cons); +} + +void +ao_lisp_string_print(ao_poly p) +{ +	char	*s = ao_lisp_poly_string(p); +	char	c; + +	putchar('"'); +	while ((c = *s++)) { +		switch (c) { +		case '\n': +			printf ("\\n"); +			break; +		case '\r': +			printf ("\\r"); +			break; +		case '\t': +			printf ("\\t"); +			break; +		default: +			putchar(c); +			break; +		} +	} +	putchar('"'); +} + +void +ao_lisp_string_patom(ao_poly p) +{ +	char	*s = ao_lisp_poly_string(p); +	char	c; + +	while ((c = *s++)) +		putchar(c); +} | 
