diff options
| author | Keith Packard <keithp@keithp.com> | 2017-12-05 10:29:13 -0800 | 
|---|---|---|
| committer | Keith Packard <keithp@keithp.com> | 2017-12-05 10:30:32 -0800 | 
| commit | 195cbeec19a6a44f309a9040d727d37fe4e2ec97 (patch) | |
| tree | ac417ad545a391da52b845b378b7655fc42d5cf4 /src/lisp | |
| parent | 9dbc686ad7d3289dc0f9bcf4a973f71100e02ded (diff) | |
altos/scheme: Rename to 'scheme', clean up build
Constant block is now built in a subdir to avoid messing up source
directory.
Renamed to ao_scheme to reflect language target.
Signed-off-by: Keith Packard <keithp@keithp.com>
Diffstat (limited to 'src/lisp')
30 files changed, 0 insertions, 7658 deletions
| diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore deleted file mode 100644 index 1faa9b67..00000000 --- a/src/lisp/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -ao_lisp_make_const -ao_lisp_const.h -ao_lisp_builtin.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile deleted file mode 100644 index 05f54550..00000000 --- a/src/lisp/Makefile +++ /dev/null @@ -1,24 +0,0 @@ -all: ao_lisp_builtin.h ao_lisp_const.h - -clean: -	rm -f ao_lisp_const.h ao_lisp_builtin.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 - -ao_lisp_builtin.h: ao_lisp_make_builtin ao_lisp_builtin.txt -	nickle ./ao_lisp_make_builtin ao_lisp_builtin.txt > $@ - -include Makefile-inc -SRCS=$(LISP_SRCS) ao_lisp_make_const.c - -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) -lm - -$(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc deleted file mode 100644 index a097f1be..00000000 --- a/src/lisp/Makefile-inc +++ /dev/null @@ -1,24 +0,0 @@ -LISP_SRCS=\ -	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_bool.c \ -	ao_lisp_float.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 \ -	ao_lisp_builtin.h diff --git a/src/lisp/Makefile-lisp b/src/lisp/Makefile-lisp deleted file mode 100644 index 998c7673..00000000 --- a/src/lisp/Makefile-lisp +++ /dev/null @@ -1,4 +0,0 @@ -include ../lisp/Makefile-inc - -ao_lisp_const.h: $(LISP_SRCS) $(LISP_HDRS) -	+cd ../lisp && make $@ diff --git a/src/lisp/README b/src/lisp/README deleted file mode 100644 index c1e84475..00000000 --- a/src/lisp/README +++ /dev/null @@ -1,11 +0,0 @@ -This follows the R7RS with the following known exceptions: - -* No vectors or bytevectors -* Characters are just numbers -* No dynamic-wind or exceptions -* No environments -* No ports -* No syntax-rules; we have macros instead -* define inside of lambda does not add name to lambda scope -* No record types -* No libraries diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h deleted file mode 100644 index b5e03b1e..00000000 --- a/src/lisp/ao_lisp.h +++ /dev/null @@ -1,928 +0,0 @@ -/* - * 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 -#define DBG_READ	0 -#define DBG_FREE_CONS	0 -#define NDEBUG		1 - -#include <stdint.h> -#include <string.h> -#include <ao_lisp_os.h> -#ifndef __BYTE_ORDER -#include <endian.h> -#endif - -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 _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) - -#define _ao_lisp_bool_true	_bool(1) -#define _ao_lisp_bool_false	_bool(0) - -#define _ao_lisp_atom_eof	_atom("eof") -#define _ao_lisp_atom_else	_atom("else") - -#define AO_LISP_BUILTIN_ATOMS -#include "ao_lisp_builtin.h" - -#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_FRAME_VALS	7 -#define AO_LISP_LAMBDA		8 -#define AO_LISP_STACK		9 -#define AO_LISP_BOOL		10 -#define AO_LISP_BIGINT		11 -#define AO_LISP_FLOAT		12 -#define AO_LISP_NUM_TYPE	13 - -/* 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_REDEFINED	0x10 -#define AO_LISP_EOF		0x20 -#define AO_LISP_EXIT		0x40 - -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_poly_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_vals { -	uint8_t			type; -	uint8_t			size; -	struct ao_lisp_val	vals[]; -}; - -struct ao_lisp_frame { -	uint8_t			type; -	uint8_t			num; -	ao_poly			prev; -	ao_poly			vals; -}; - -struct ao_lisp_bool { -	uint8_t			type; -	uint8_t			value; -	uint16_t		pad; -}; - -struct ao_lisp_bigint { -	uint32_t		value; -}; - -struct ao_lisp_float { -	uint8_t			type; -	uint8_t			pad1; -	uint16_t		pad2; -	float			value; -}; - -#if __BYTE_ORDER == __LITTLE_ENDIAN -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { -	return AO_LISP_BIGINT | (i << 8); -} -static inline int32_t -ao_lisp_bigint_int(uint32_t bi) { -	return (int32_t) bi >> 8; -} -#else -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { -	return (uint32_t) (i & 0xffffff) | (AO_LISP_BIGINT << 24); -} -static inlint int32_t -ao_lisp_bigint_int(uint32_t bi) { -	return (int32_t) (bi << 8) >> 8; -} -#endif - -#define AO_LISP_MIN_INT		(-(1 << (15 - AO_LISP_TYPE_SHIFT))) -#define AO_LISP_MAX_INT		((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) -#define AO_LISP_MIN_BIGINT	(-(1 << 24)) -#define AO_LISP_MAX_BIGINT	((1 << 24) - 1) - -#define AO_LISP_NOT_INTEGER	0x7fffffff - -/* 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); -} - -static inline struct ao_lisp_frame_vals * -ao_lisp_poly_frame_vals(ao_poly poly) { -	return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_frame_vals_poly(struct ao_lisp_frame_vals *vals) { -	return ao_lisp_poly(vals, 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_apply,		/* Execute apply */ -	eval_cond,		/* Start next cond clause */ -	eval_cond_test,		/* Check cond condition */ -	eval_begin,		/* Start next begin 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_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) - -struct ao_lisp_builtin { -	uint8_t		type; -	uint8_t		args; -	uint16_t	func; -}; - -#define AO_LISP_BUILTIN_ID -#include "ao_lisp_builtin.h" - -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 int -ao_lisp_is_cons(ao_poly poly) { -	return (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -static inline int -ao_lisp_is_pair(ao_poly poly) { -	return poly != AO_LISP_NIL && (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -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 int32_t -ao_lisp_poly_int(ao_poly poly) -{ -	return (int32_t) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); -} - -static inline ao_poly -ao_lisp_int_poly(int32_t i) -{ -	return ((ao_poly) i << 2) | AO_LISP_INT; -} - -static inline struct ao_lisp_bigint * -ao_lisp_poly_bigint(ao_poly poly) -{ -	return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_bigint_poly(struct ao_lisp_bigint *bi) -{ -	return ao_lisp_poly(bi, AO_LISP_OTHER); -} - -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); -} - -static inline ao_poly -ao_lisp_bool_poly(struct ao_lisp_bool *b) -{ -	return ao_lisp_poly(b, AO_LISP_OTHER); -} - -static inline struct ao_lisp_bool * -ao_lisp_poly_bool(ao_poly poly) -{ -	return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_float_poly(struct ao_lisp_float *f) -{ -	return ao_lisp_poly(f, AO_LISP_OTHER); -} - -static inline struct ao_lisp_float * -ao_lisp_poly_float(ao_poly poly) -{ -	return ao_lisp_ref(poly); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* 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); - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons); -#endif - -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)); -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame); - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id); - -/* bool */ - -extern const struct ao_lisp_type ao_lisp_bool_type; - -void -ao_lisp_bool_write(ao_poly v); - -#ifdef AO_LISP_MAKE_CONST -struct ao_lisp_bool	*ao_lisp_true, *ao_lisp_false; - -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value); -#endif - -/* cons */ -extern const struct ao_lisp_type ao_lisp_cons_type; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, ao_poly cdr); - -/* Return a cons or NULL for a proper list, else error */ -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly 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_write(ao_poly); - -void -ao_lisp_cons_display(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_write(ao_poly s); - -void -ao_lisp_string_display(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_write(ao_poly a); - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name); - -ao_poly * -ao_lisp_atom_ref(ao_poly atom); - -ao_poly -ao_lisp_atom_get(ao_poly atom); - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val); - -/* int */ -void -ao_lisp_int_write(ao_poly i); - -int32_t -ao_lisp_poly_integer(ao_poly p); - -ao_poly -ao_lisp_integer_poly(int32_t i); - -static inline int -ao_lisp_integer_typep(uint8_t t) -{ -	return (t == AO_LISP_INT) || (t == AO_LISP_BIGINT); -} - -void -ao_lisp_bigint_write(ao_poly i); - -extern const struct ao_lisp_type	ao_lisp_bigint_type; -/* prim */ -void -ao_lisp_poly_write(ao_poly p); - -void -ao_lisp_poly_display(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); - -/* float */ -extern const struct ao_lisp_type ao_lisp_float_type; - -void -ao_lisp_float_write(ao_poly p); - -ao_poly -ao_lisp_float_get(float value); - -static inline uint8_t -ao_lisp_number_typep(uint8_t t) -{ -	return ao_lisp_integer_typep(t) || (t == AO_LISP_FLOAT); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* builtin */ -void -ao_lisp_builtin_write(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; -extern const struct ao_lisp_type ao_lisp_frame_vals_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); - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); - -void -ao_lisp_frame_write(ao_poly p); - -void -ao_lisp_frame_init(void); - -/* 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_write(ao_poly lambda); - -ao_poly -ao_lisp_lambda_eval(void); - -/* 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_write(ao_poly stack); - -ao_poly -ao_lisp_stack_eval(void); - -/* error */ - -void -ao_lisp_vprintf(char *format, va_list args); - -void -ao_lisp_printf(char *format, ...); - -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, ...); - -/* builtins */ - -#define AO_LISP_BUILTIN_DECLS -#include "ao_lisp_builtin.h" - -/* debugging macros */ - -#if DBG_EVAL || DBG_READ || DBG_MEM -#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(...) 	ao_lisp_printf(__VA_ARGS__) -#define DBGI(...)	do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a)	ao_lisp_cons_write(ao_lisp_cons_poly(a)) -#define DBG_POLY(a)	ao_lisp_poly_write(a) -#define OFFSET(a)	((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#define DBG_STACK()	ao_lisp_stack_write(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 - -#if DBG_READ -#define RDBGI(...)	DBGI(__VA_ARGS__) -#define RDBG_IN()	DBG_IN() -#define RDBG_OUT()	DBG_OUT() -#else -#define RDBGI(...) -#define RDBG_IN() -#define RDBG_OUT() -#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)	((a) ? (int) ((uint8_t *) (a) - ao_lisp_pool) : -1) - -extern int dbg_mem; - -#define MDBG_DO(a)	DBG_DO(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 deleted file mode 100644 index a633c223..00000000 --- a/src/lisp/ao_lisp_atom.c +++ /dev/null @@ -1,159 +0,0 @@ -/* - * 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; -} - -ao_poly * -ao_lisp_atom_ref(ao_poly atom) -{ -	ao_poly	*ref; -	struct ao_lisp_frame *frame; - -	for (frame = ao_lisp_frame_current; frame; frame = ao_lisp_poly_frame(frame->prev)) { -		ref = ao_lisp_frame_ref(frame, atom); -		if (ref) -			return ref; -	} -	return ao_lisp_frame_ref(ao_lisp_frame_global, atom); -} - -ao_poly -ao_lisp_atom_get(ao_poly atom) -{ -	ao_poly *ref = ao_lisp_atom_ref(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(atom); - -	if (!ref) -		return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); -	*ref = val; -	return val; -} - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val) -{ -	ao_poly *ref = ao_lisp_atom_ref(atom); - -	if (ref) { -		if (ao_lisp_frame_current) -			return ao_lisp_error(AO_LISP_REDEFINED, "attempt to redefine atom %s", ao_lisp_poly_atom(atom)->name); -		*ref = val; -		return val; -	} -	return ao_lisp_frame_add(ao_lisp_frame_current ? ao_lisp_frame_current : ao_lisp_frame_global, atom, val); -} - -void -ao_lisp_atom_write(ao_poly a) -{ -	struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); -	printf("%s", atom->name); -} diff --git a/src/lisp/ao_lisp_bool.c b/src/lisp/ao_lisp_bool.c deleted file mode 100644 index 391a7f78..00000000 --- a/src/lisp/ao_lisp_bool.c +++ /dev/null @@ -1,73 +0,0 @@ -/* - * Copyright © 2017 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 bool_mark(void *addr) -{ -	(void) addr; -} - -static int bool_size(void *addr) -{ -	(void) addr; -	return sizeof (struct ao_lisp_bool); -} - -static void bool_move(void *addr) -{ -	(void) addr; -} - -const struct ao_lisp_type ao_lisp_bool_type = { -	.mark = bool_mark, -	.size = bool_size, -	.move = bool_move, -	.name = "bool" -}; - -void -ao_lisp_bool_write(ao_poly v) -{ -	struct ao_lisp_bool	*b = ao_lisp_poly_bool(v); - -	if (b->value) -		printf("#t"); -	else -		printf("#f"); -} - -#ifdef AO_LISP_MAKE_CONST - -struct ao_lisp_bool	*ao_lisp_true, *ao_lisp_false; - -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value) -{ -	struct ao_lisp_bool	**b; - -	if (value) -		b = &ao_lisp_true; -	else -		b = &ao_lisp_false; - -	if (!*b) { -		*b = ao_lisp_alloc(sizeof (struct ao_lisp_bool)); -		(*b)->type = AO_LISP_BOOL; -		(*b)->value = value; -	} -	return *b; -} - -#endif diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c deleted file mode 100644 index 6af2a6ea..00000000 --- a/src/lisp/ao_lisp_builtin.c +++ /dev/null @@ -1,868 +0,0 @@ -/* - * 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 <limits.h> -#include <math.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 - -#define AO_LISP_BUILTIN_CASENAME -#include "ao_lisp_builtin.h" - -char *ao_lisp_args_name(uint8_t args) { -	args &= AO_LISP_FUNC_MASK; -	switch (args) { -	case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; -	case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; -	case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; -	default: return "???"; -	} -} -#else - -#define AO_LISP_BUILTIN_ARRAYNAME -#include "ao_lisp_builtin.h" - -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_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_write(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_cons_cdr(cons); -	} -	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_bool_true; -} - -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_cons_cdr(cons); -	} -	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: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car); -	return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_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_do_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_do_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; -	car = ao_lisp_arg(cons, 0); -	cdr = ao_lisp_arg(cons, 1); -	return ao_lisp__cons(car, cdr); -} - -ao_poly -ao_lisp_do_last(struct ao_lisp_cons *cons) -{ -	struct ao_lisp_cons	*list; -	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; -	for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); -	     list; -	     list = ao_lisp_cons_cdr(list)) -	{ -		if (!list->cdr) -			return list->car; -	} -	return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_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_do_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_do_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_do_def(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_def, cons, 2, 2)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_def, cons, 0, AO_LISP_ATOM, 0)) -		return AO_LISP_NIL; - -	return ao_lisp_atom_def(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_do_setq(struct ao_lisp_cons *cons) -{ -	ao_poly	name; -	if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2)) -		return AO_LISP_NIL; -	name = cons->car; -	if (ao_lisp_poly_type(name) != AO_LISP_ATOM) -		return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom %v", name); -	if (!ao_lisp_atom_ref(name)) -		return ao_lisp_error(AO_LISP_INVALID, "atom %v not defined", name); -	return ao_lisp__cons(_ao_lisp_atom_set, -			     ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, -							 ao_lisp__cons(name, AO_LISP_NIL)), -					   cons->cdr)); -} - -ao_poly -ao_lisp_do_cond(struct ao_lisp_cons *cons) -{ -	ao_lisp_set_cond(cons); -	return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_begin(struct ao_lisp_cons *cons) -{ -	ao_lisp_stack->state = eval_begin; -	ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); -	return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_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_do_write(struct ao_lisp_cons *cons) -{ -	ao_poly	val = AO_LISP_NIL; -	while (cons) { -		val = cons->car; -		ao_lisp_poly_write(val); -		cons = ao_lisp_cons_cdr(cons); -		if (cons) -			printf(" "); -	} -	printf("\n"); -	return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_display(struct ao_lisp_cons *cons) -{ -	ao_poly	val = AO_LISP_NIL; -	while (cons) { -		val = cons->car; -		ao_lisp_poly_display(val); -		cons = ao_lisp_cons_cdr(cons); -	} -	return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) -{ -	struct ao_lisp_cons *cons = cons; -	ao_poly	ret = AO_LISP_NIL; - -	for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { -		ao_poly		car = cons->car; -		uint8_t		rt = ao_lisp_poly_type(ret); -		uint8_t		ct = ao_lisp_poly_type(car); - -		if (cons == orig_cons) { -			ret = car; -			if (cons->cdr == AO_LISP_NIL) { -				switch (op) { -				case builtin_minus: -					if (ao_lisp_integer_typep(ct)) -						ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); -					else if (ct == AO_LISP_FLOAT) -						ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); -					break; -				case builtin_divide: -					if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) -						; -					else if (ao_lisp_number_typep(ct)) { -						float	v = ao_lisp_poly_number(ret); -						ret = ao_lisp_float_get(1/v); -					} -					break; -				default: -					break; -				} -			} -		} else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { -			int32_t	r = ao_lisp_poly_integer(ret); -			int32_t	c = ao_lisp_poly_integer(car); -			int64_t t; - -			switch(op) { -			case builtin_plus: -				r += c; -			check_overflow: -				if (r < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < r) -					goto inexact; -				break; -			case builtin_minus: -				r -= c; -				goto check_overflow; -				break; -			case builtin_times: -				t = (int64_t) r * (int64_t) c; -				if (t < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < t) -					goto inexact; -				r = (int32_t) t; -				break; -			case builtin_divide: -				if (c != 0 && (r % c) == 0) -					r /= c; -				else -					goto inexact; -				break; -			case builtin_quotient: -				if (c == 0) -					return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); -				if (r % c != 0 && (c < 0) != (r < 0)) -					r = r / c - 1; -				else -					r = r / c; -				break; -			case builtin_remainder: -				if (c == 0) -					return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); -				r %= c; -				break; -			case builtin_modulo: -				if (c == 0) -					return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); -				r %= c; -				if ((r < 0) != (c < 0)) -					r += c; -				break; -			default: -				break; -			} -			ret = ao_lisp_integer_poly(r); -		} else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { -			float r, c; -		inexact: -			r = ao_lisp_poly_number(ret); -			c = ao_lisp_poly_number(car); -			switch(op) { -			case builtin_plus: -				r += c; -				break; -			case builtin_minus: -				r -= c; -				break; -			case builtin_times: -				r *= c; -				break; -			case builtin_divide: -				r /= c; -				break; -			case builtin_quotient: -			case builtin_remainder: -			case builtin_modulo: -				return ao_lisp_error(AO_LISP_INVALID, "non-integer value in integer divide"); -			default: -				break; -			} -			ret = ao_lisp_float_get(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_do_plus(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_plus); -} - -ao_poly -ao_lisp_do_minus(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_minus); -} - -ao_poly -ao_lisp_do_times(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_times); -} - -ao_poly -ao_lisp_do_divide(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_divide); -} - -ao_poly -ao_lisp_do_quotient(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_quotient); -} - -ao_poly -ao_lisp_do_modulo(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_modulo); -} - -ao_poly -ao_lisp_do_remainder(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_remainder); -} - -ao_poly -ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) -{ -	ao_poly	left; - -	if (!cons) -		return _ao_lisp_bool_true; - -	left = cons->car; -	for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { -		ao_poly	right = cons->car; - -		if (op == builtin_equal) { -			if (left != right) -				return _ao_lisp_bool_false; -		} else { -			uint8_t	lt = ao_lisp_poly_type(left); -			uint8_t	rt = ao_lisp_poly_type(right); -			if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) { -				int32_t l = ao_lisp_poly_integer(left); -				int32_t r = ao_lisp_poly_integer(right); - -				switch (op) { -				case builtin_less: -					if (!(l < r)) -						return _ao_lisp_bool_false; -					break; -				case builtin_greater: -					if (!(l > r)) -						return _ao_lisp_bool_false; -					break; -				case builtin_less_equal: -					if (!(l <= r)) -						return _ao_lisp_bool_false; -					break; -				case builtin_greater_equal: -					if (!(l >= r)) -						return _ao_lisp_bool_false; -					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_bool_false; -					break; -				case builtin_greater: -					if (!(c > 0)) -						return _ao_lisp_bool_false; -					break; -				case builtin_less_equal: -					if (!(c <= 0)) -						return _ao_lisp_bool_false; -					break; -				case builtin_greater_equal: -					if (!(c >= 0)) -						return _ao_lisp_bool_false; -					break; -				default: -					break; -				} -			} -		} -		left = right; -	} -	return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_equal(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_equal); -} - -ao_poly -ao_lisp_do_less(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_less); -} - -ao_poly -ao_lisp_do_greater(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_greater); -} - -ao_poly -ao_lisp_do_less_equal(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_less_equal); -} - -ao_poly -ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_lisp_do_list_to_string(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_list2d3estring, 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_do_string_to_list(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_string2d3elist, 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_do_flush_output(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0)) -		return AO_LISP_NIL; -	ao_lisp_os_flush(); -	return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_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_do_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_apply(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX)) -		return AO_LISP_NIL; -	ao_lisp_stack->state = eval_apply; -	return ao_lisp_cons_poly(cons); -} - -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); -} - -ao_poly -ao_lisp_do_nullp(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	if (ao_lisp_arg(cons, 0) == AO_LISP_NIL) -		return _ao_lisp_bool_true; -	else -		return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_not(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	if (ao_lisp_arg(cons, 0) == _ao_lisp_bool_false) -		return _ao_lisp_bool_true; -	else -		return _ao_lisp_bool_false; -} - -static ao_poly -ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == type) -		return _ao_lisp_bool_true; -	return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_pairp(struct ao_lisp_cons *cons) -{ -	ao_poly	v; -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	v = ao_lisp_arg(cons, 0); -	if (v != AO_LISP_NIL && ao_lisp_poly_type(v) == AO_LISP_CONS) -		return _ao_lisp_bool_true; -	return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_integerp(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { -	case AO_LISP_INT: -	case AO_LISP_BIGINT: -		return _ao_lisp_bool_true; -	default: -		return _ao_lisp_bool_false; -	} -} - -ao_poly -ao_lisp_do_numberp(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { -	case AO_LISP_INT: -	case AO_LISP_BIGINT: -	case AO_LISP_FLOAT: -		return _ao_lisp_bool_true; -	default: -		return _ao_lisp_bool_false; -	} -} - -ao_poly -ao_lisp_do_stringp(struct ao_lisp_cons *cons) -{ -	return ao_lisp_do_typep(AO_LISP_STRING, cons); -} - -ao_poly -ao_lisp_do_symbolp(struct ao_lisp_cons *cons) -{ -	return ao_lisp_do_typep(AO_LISP_ATOM, cons); -} - -ao_poly -ao_lisp_do_booleanp(struct ao_lisp_cons *cons) -{ -	return ao_lisp_do_typep(AO_LISP_BOOL, cons); -} - -ao_poly -ao_lisp_do_procedurep(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { -	case AO_LISP_BUILTIN: -	case AO_LISP_LAMBDA: -		return _ao_lisp_bool_true; -	default: -	return _ao_lisp_bool_false; -	} -} - -/* This one is special -- a list is either nil or - * a 'proper' list with only cons cells - */ -ao_poly -ao_lisp_do_listp(struct ao_lisp_cons *cons) -{ -	ao_poly	v; -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	v = ao_lisp_arg(cons, 0); -	for (;;) { -		if (v == AO_LISP_NIL) -			return _ao_lisp_bool_true; -		if (ao_lisp_poly_type(v) != AO_LISP_CONS) -			return _ao_lisp_bool_false; -		v = ao_lisp_poly_cons(v)->cdr; -	} -} - -ao_poly -ao_lisp_do_set_car(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) -		return AO_LISP_NIL; -	return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1); -} - -ao_poly -ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) -		return AO_LISP_NIL; -	return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); -} - -ao_poly -ao_lisp_do_symbol_to_string(struct ao_lisp_cons *cons) -{ -	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_ATOM, 0)) -		return AO_LISP_NIL; -	return ao_lisp_string_poly(ao_lisp_string_copy(ao_lisp_poly_atom(ao_lisp_arg(cons, 0))->name)); -} - -ao_poly -ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) -{ -	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_STRING, 0)) -		return AO_LISP_NIL; - -	return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); -} - -ao_poly -ao_lisp_do_read_char(struct ao_lisp_cons *cons) -{ -	int	c; -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) -		return AO_LISP_NIL; -	c = getchar(); -	return ao_lisp_int_poly(c); -} - -ao_poly -ao_lisp_do_write_char(struct ao_lisp_cons *cons) -{ -	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; -	putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0))); -	return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_exit(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) -		return AO_LISP_NIL; -	ao_lisp_exception |= AO_LISP_EXIT; -	return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons) -{ -	int	jiffy; - -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) -		return AO_LISP_NIL; -	jiffy = ao_lisp_os_jiffy(); -	return (ao_lisp_int_poly(jiffy)); -} - -ao_poly -ao_lisp_do_current_second(struct ao_lisp_cons *cons) -{ -	int	second; - -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) -		return AO_LISP_NIL; -	second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND; -	return (ao_lisp_int_poly(second)); -} - -ao_poly -ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) -		return AO_LISP_NIL; -	return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND)); -} - -#define AO_LISP_BUILTIN_FUNCS -#include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt deleted file mode 100644 index cb65e252..00000000 --- a/src/lisp/ao_lisp_builtin.txt +++ /dev/null @@ -1,68 +0,0 @@ -f_lambda	eval -f_lambda	read -nlambda		lambda -nlambda		nlambda -nlambda		macro -f_lambda	car -f_lambda	cdr -f_lambda	cons -f_lambda	last -f_lambda	length -nlambda		quote -atom		quasiquote -atom		unquote -atom		unquote_splicing	unquote-splicing -f_lambda	set -macro		setq		set! -f_lambda	def -nlambda		cond -nlambda		begin -nlambda		while -f_lambda	write -f_lambda	display -f_lambda	plus		+ -f_lambda	minus		- -f_lambda	times		* -f_lambda	divide		/ -f_lambda	modulo		modulo	% -f_lambda	remainder -f_lambda	quotient -f_lambda	equal		=	eq?	eqv? -f_lambda	less		< -f_lambda	greater		> -f_lambda	less_equal	<= -f_lambda	greater_equal	>= -f_lambda	list_to_string		list->string -f_lambda	string_to_list		string->list -f_lambda	flush_output		flush-output -f_lambda	delay -f_lambda	led -f_lambda	save -f_lambda	restore -f_lambda	call_cc		call-with-current-continuation	call/cc -f_lambda	collect -f_lambda	nullp		null? -f_lambda	not -f_lambda	listp		list? -f_lambda	pairp		pair? -f_lambda	integerp	integer? exact? exact-integer? -f_lambda	numberp		number? real? -f_lambda	booleanp	boolean? -f_lambda	set_car		set-car! -f_lambda	set_cdr		set-cdr! -f_lambda	symbolp		symbol? -f_lambda	symbol_to_string	symbol->string -f_lambda	string_to_symbol	string->symbol -f_lambda	stringp		string? -f_lambda	procedurep	procedure? -lambda		apply -f_lambda	read_char	read-char -f_lambda	write_char	write-char -f_lambda	exit -f_lambda	current_jiffy	current-jiffy -f_lambda	current_second	current-second -f_lambda	jiffies_per_second	jiffies-per-second -f_lambda	finitep		finite? -f_lambda	infinitep	infinite? -f_lambda	inexactp	inexact? -f_lambda	sqrt diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c deleted file mode 100644 index d3b97383..00000000 --- a/src/lisp/ao_lisp_cons.c +++ /dev/null @@ -1,184 +0,0 @@ -/* - * 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_poly cdr = cons->cdr; - -		ao_lisp_poly_mark(cons->car, 1); -		if (!cdr) -			break; -		if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { -			ao_lisp_poly_mark(cdr, 1); -			break; -		} -		cons = ao_lisp_poly_cons(cdr); -		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 (;;) { -		ao_poly			cdr; -		struct ao_lisp_cons	*c; -		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 = cons->cdr; -		if (!cdr) -			break; -		if (ao_lisp_poly_base_type(cdr) != AO_LISP_CONS) { -			(void) ao_lisp_poly_move(&cons->cdr, 0); -			break; -		} -		c = ao_lisp_poly_cons(cdr); -		ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &c); -		if (c != ao_lisp_poly_cons(cons->cdr)) -			cons->cdr = ao_lisp_cons_poly(c); -		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 = c; -	} -} - -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, ao_poly 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_poly_stash(1, cdr); -		cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); -		cdr = ao_lisp_poly_fetch(1); -		car = ao_lisp_poly_fetch(0); -		if (!cons) -			return NULL; -	} -	cons->car = car; -	cons->cdr = cdr; -	return cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons) -{ -	ao_poly	cdr = cons->cdr; -	if (cdr == AO_LISP_NIL) -		return NULL; -	if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { -		(void) ao_lisp_error(AO_LISP_INVALID, "improper list"); -		return NULL; -	} -	return ao_lisp_poly_cons(cdr); -} - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly cdr) -{ -	return ao_lisp_cons_poly(ao_lisp_cons_cons(car, cdr)); -} - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons) -{ -#if DBG_FREE_CONS -	ao_lisp_cons_check(cons); -#endif -	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_write(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_write(cons->car); -		c = cons->cdr; -		if (ao_lisp_poly_type(c) == AO_LISP_CONS) { -			cons = ao_lisp_poly_cons(c); -			first = 0; -		} else { -			printf(" . "); -			ao_lisp_poly_write(c); -			cons = NULL; -		} -	} -	printf(")"); -} - -void -ao_lisp_cons_display(ao_poly c) -{ -	struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); - -	while (cons) { -		ao_lisp_poly_display(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 deleted file mode 100644 index 422bdd63..00000000 --- a/src/lisp/ao_lisp_const.lisp +++ /dev/null @@ -1,813 +0,0 @@ -; -; 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 -(def (quote list) (lambda l l)) - -(def (quote def!) -     (macro (name value) -	    (list -	     def -	     (list quote name) -	     value) -	    ) -     ) - -(begin - (def! append -   (lambda args -	  (def! append-list -	    (lambda (a b) -	      (cond ((null? a) b) -		    (else (cons (car a) (append-list (cdr a) b))) -		    ) -	      ) -	    ) -	     -	  (def! append-lists -	    (lambda (lists) -	      (cond ((null? lists) lists) -		    ((null? (cdr lists)) (car lists)) -		    (else (append-list (car lists) (append-lists (cdr lists)))) -		    ) -	      ) -	    ) -	  (append-lists args) -	  ) -   ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - -					; boolean operators - -(begin - (def! or -   (macro l -	  (def! _or -	    (lambda (l) -	      (cond ((null? l) #f) -		    ((null? (cdr l)) -		     (car l)) -		    (else -		     (list -		      cond -		      (list -		       (car l)) -		      (list -		       'else -		       (_or (cdr l)) -		       ) -		      ) -		     ) -		    ) -	      ) -	    ) -	  (_or l))) - 'or) - -					; execute to resolve macros - -(or #f #t) - -(begin - (def! and -   (macro l -	  (def! _and -	    (lambda (l) -	      (cond ((null? l) #t) -		    ((null? (cdr l)) -		     (car l)) -		    (else -		     (list -		      cond -		      (list -		       (car l) -		       (_and (cdr l)) -		       ) -		      ) -		     ) -		    ) -	      ) -	    ) -	  (_and l) -	  ) -   ) - 'and) - -					; execute to resolve macros - -(and #t #f) - -(begin - (def! quasiquote -   (macro (x) -	  (def! constant? -					; A constant value is either a pair starting with quote, -					; or anything which is neither a pair nor a symbol - -	    (lambda (exp) -	      (cond ((pair? exp) -		     (eq? (car exp) 'quote) -		     ) -		    (else -		     (not (symbol? exp)) -		     ) -		    ) -	      ) -	    ) -	  (def! combine-skeletons -	    (lambda (left right exp) -	      (cond -	       ((and (constant? left) (constant? right))  -		(cond ((and (eqv? (eval left) (car exp)) -			    (eqv? (eval right) (cdr exp))) -		       (list 'quote exp) -		       ) -		      (else -		       (list 'quote (cons (eval left) (eval right))) -		       ) -		      ) -		) -	       ((null? right) -		(list 'list left) -		) -	       ((and (pair? right) (eq? (car right) 'list)) -		(cons 'list (cons left (cdr right))) -		) -	       (else -		(list 'cons left right) -		) -	       ) -	      ) -	    ) - -	  (def! expand-quasiquote -	    (lambda (exp nesting) -	      (cond - -					; non cons -- constants -					; themselves, others are -					; quoted - -	       ((not (pair? exp))  -		(cond ((constant? exp) -		       exp -		       ) -		      (else -		       (list 'quote exp) -		       ) -		      ) -		) - -					; check for an unquote exp and -					; add the param unquoted - -	       ((and (eq? (car exp) 'unquote) (= (length exp) 2)) -		(cond ((= nesting 0) -		       (car (cdr exp)) -		       ) -		      (else -		       (combine-skeletons ''unquote  -					  (expand-quasiquote (cdr exp) (- nesting 1)) -					  exp)) -		      ) -		) - -					; nested quasi-quote -- -					; construct the right -					; expression - -	       ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) -		(combine-skeletons ''quasiquote  -				   (expand-quasiquote (cdr exp) (+ nesting 1)) -				   exp)) - -					; check for an -					; unquote-splicing member, -					; compute the expansion of the -					; value and append the rest of -					; the quasiquote result to it - -	       ((and (pair? (car exp)) -		     (eq? (car (car exp)) 'unquote-splicing) -		     (= (length (car exp)) 2)) -		(cond ((= nesting 0) -		       (list 'append (car (cdr (car exp))) -			     (expand-quasiquote (cdr exp) nesting)) -		       ) -		      (else -		       (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) -					  (expand-quasiquote (cdr exp) nesting) -					  exp)) -		      ) -		) - -					; for other lists, just glue -					; the expansion of the first -					; element to the expansion of -					; the rest of the list - -	       (else (combine-skeletons (expand-quasiquote (car exp) nesting) -					(expand-quasiquote (cdr exp) nesting) -					exp) -		     ) -	       ) -	      ) -	    ) -	  (def! result (expand-quasiquote x 0)) -	  result -	  ) -   ) - 'quasiquote) - -					; -					; Define a variable without returning the value -					; Useful when defining functions to avoid -					; having lots of output generated. -					; -					; Also accepts the alternate -					; form for defining lambdas of -					; (define (name x y z) sexprs ...)  -					; - -(begin - (def! define -   (macro (first . rest) -					; check for alternate lambda definition form - -	  (cond ((list? first) -		 (set! rest -		       (append -			(list -			 'lambda -			 (cdr first)) -			rest)) -		 (set! first (car first)) -		 ) -		(else -		 (set! rest (car rest)) -		 ) -		) -	  (def! result `(,begin -			 (,def (,quote ,first) ,rest) -			 (,quote ,first)) -	    ) -	  result -	  ) -   ) - 'define - ) - -					; basic list accessors - -(define (caar l) (car (car l))) - -(define (cadr l) (car (cdr l))) - -(define (cdar l) (cdr (car l))) - -(define (caddr l) (car (cdr (cdr l)))) - -					; (if <condition> <if-true>) -					; (if <condition> <if-true> <if-false) - -(define if -  (macro (test . args) -	 (cond ((null? (cdr args)) -		`(cond (,test ,(car args))) -		) -	       (else -		`(cond (,test ,(car args)) -		       (else ,(cadr args))) -		) -	       ) -	 ) -  ) - -(if (> 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - -					; simple math operators - -(define zero? (macro (value) `(eq? ,value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) `(> ,value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) `(< ,value 0))) - -(negative? 12) -(negative? -12) - -(define (abs x) (if (>= x 0) x (- x))) - -(abs 12) -(abs -12) - -(define max (lambda (first . rest) -		   (while (not (null? rest)) -		     (cond ((< first (car rest)) -			    (set! first (car rest))) -			   ) -		     (set! rest (cdr rest)) -		     ) -		   first) -  ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (first . rest) -		   (while (not (null? rest)) -		     (cond ((> first (car rest)) -			    (set! first (car rest))) -			   ) -		     (set! rest (cdr rest)) -		     ) -		   first) -  ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? x) (zero? (% x 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? x) (not (even? x))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - - -(define (list-tail x k) -  (if (zero? k) -      x -    (list-tail (cdr x (- k 1))) -    ) -  ) - -(define (list-ref x k) -  (car (list-tail x k)) -  ) - -					; define a set of local -					; variables all at once 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)) (set! y (+ x 1)) y) - -(define let -  (macro (vars . exprs) -	 (define (make-names vars) -	   (cond ((not (null? vars)) -		  (cons (car (car vars)) -			(make-names (cdr vars)))) -		 (else ()) -		 ) -	   ) - -					; the parameters to the lambda is a list -					; of nils of the right length - -	 (define (make-vals vars) -	   (cond ((not (null? vars)) -		  (cons (cond ((null? (cdr (car vars))) ()) -			      (else -			       (car (cdr (car vars)))) -			      ) -			(make-vals (cdr vars)))) -		 (else ()) -		 ) -	   ) -					; prepend the set operations -					; to the expressions - -					; build the lambda. - -	 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) -	 ) -     ) -		    - -(let ((x 1) (y)) (set! y 2) (+ x y)) - -					; define a set of local -					; variables one at a time 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)) (set! y (+ x 1)) y) - -(define let* -  (macro (vars . exprs) - -					; -					; make the list of names in the let -					; - -	 (define (make-names vars) -	   (cond ((not (null? vars)) -		  (cons (car (car vars)) -			(make-names (cdr vars)))) -		 (else ()) -		 ) -	   ) - -					; the set of expressions is -					; the list of set expressions -					; pre-pended to the -					; expressions to evaluate - -	 (define (make-exprs vars exprs) -	   (cond ((null? vars) exprs) -		 (else -		  (cons -		   (list set -			 (list quote -			       (car (car vars)) -			       ) -			 (cond ((null? (cdr (car vars))) ()) -			       (else (cadr (car vars)))) -			 ) -		   (make-exprs (cdr vars) exprs) -		   ) -		  ) -		 ) -	   ) - -					; the parameters to the lambda is a list -					; of nils of the right length - -	 (define (make-nils vars) -	   (cond ((null? vars) ()) -		 (else (cons () (make-nils (cdr vars)))) -		 ) -	   ) -					; build the lambda. - -	 `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) -	 ) -     ) - -(let* ((x 1) (y x)) (+ x y)) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(when #t (write 'when)) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(unless #f (write 'unless)) - -(define (reverse list) -  (let ((result ())) -    (while (not (null? list)) -      (set! result (cons (car list) result)) -      (set! list (cdr list)) -      ) -    result) -  ) - -(reverse '(1 2 3)) - -(define (list-tail x k) -  (if (zero? k) -      x -    (list-tail (cdr x) (- k 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref x k) (car (list-tail x k))) - -(list-ref '(1 2 3) 2) -     -					; recursive equality - -(define (equal? a b) -  (cond ((eq? a b) #t) -	((and (pair? a) (pair? b)) -	 (and (equal? (car a) (car b)) -	      (equal? (cdr a) (cdr b))) -	 ) -	(else #f) -	) -  ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) - -(define member (lambda (obj list . test?) -		      (cond ((null? list) -			     #f -			     ) -			    (else -			     (if (null? test?) (set! test? equal?) (set! test? (car test?))) -			     (if (test? obj (car list)) -				 list -			       (member obj (cdr list) test?)) -			     ) -			    ) -		      ) -  ) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) - -(define (memq obj list) (member obj list eq?)) - -(memq 2 '(1 2 3)) - -(memq 4 '(1 2 3)) - -(memq '(2) '((1) (2) (3))) - -(define (memv obj list) (member obj list eqv?)) - -(memv 2 '(1 2 3)) - -(memv 4 '(1 2 3)) - -(memv '(2) '((1) (2) (3))) - -(define (_assoc obj list test?) -  (if (null? list) -      #f -    (if (test? obj (caar list)) -	(car list) -      (_assoc obj (cdr list) test?) -      ) -    ) -  ) - -(define (assq obj list) (_assoc obj list eq?)) -(define (assv obj list) (_assoc obj list eqv?)) -(define (assoc obj list) (_assoc obj list equal?)) - -(assq 'a '((a 1) (b 2) (c 3))) -(assv 'b '((a 1) (b 2) (c 3))) -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define char? integer?) - -(char? #\q) -(char? "h") - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(char-lower-case? #\a) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(char-alphabetic? #\a) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(char-numeric? #\a) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(char-whitespace? #\a) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) - -(define (char->integer c) c) -(define (integer->char c) char-integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(char-upcase #\a) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(char-downcase #\a) -(char-downcase #\B) -(char-downcase #\0) -(char-downcase #\space) - -(define string (lambda chars (list->string chars))) - -(display "apply\n") -(apply cons '(a b)) - -(define map -  (lambda (proc . lists) -	 (define (args lists) -	   (cond ((null? lists) ()) -		 (else -		  (cons (caar lists) (args (cdr lists))) -		  ) -		 ) -	   ) -	 (define (next lists) -	   (cond ((null? lists) ()) -		 (else -		  (cons (cdr (car lists)) (next (cdr lists))) -		  ) -		 ) -	   ) -	 (define (domap lists) -	   (cond ((null? (car lists)) ()) -		 (else -		  (cons (apply proc (args lists)) (domap (next lists))) -		  ) -		 ) -	   ) -	 (domap lists) -	 ) -  ) - -(map cadr '((a b) (d e) (g h))) - -(define for-each (lambda (proc . lists) -			(apply map proc lists) -			#t)) - -(for-each display '("hello" " " "world" "\n")) - -(define (_string-ml strings) -  (if (null? strings) () -    (cons (string->list (car strings)) (_string-ml (cdr strings))) -    ) -  ) - -(define string-map (lambda (proc . strings) -			  (list->string (apply map proc (_string-ml strings)))))) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-for-each (lambda (proc . strings) -			       (apply for-each proc (_string-ml strings)))) - -(string-for-each write-char "IBM\n") - -(define (newline) (write-char #\newline)) - -(newline) - -(call-with-current-continuation - (lambda (exit) -   (for-each (lambda (x) -	       (write "test" x) -	       (if (negative? x) -		   (exit x))) -	     '(54 0 37 -3 245 19)) -   #t)) - - -					; `q -> (quote q) -					; `(q) -> (append (quote (q))) -					; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) -					; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - - -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) - - -(define repeat -  (macro (count . rest) -	 (define counter '__count__) -	 (cond ((pair? count) -		(set! counter (car count)) -		(set! count (cadr count)) -		) -	       ) -	 `(let ((,counter 0) -		(__max__ ,count) -		) -	    (while (< ,counter __max__) -	      ,@rest -	      (set! ,counter (+ ,counter 1)) -	      ) -	    ) -	 ) -  ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write 'goodbye x)) - -(define case -  (macro (test . l) -					; construct the body of the -					; case, dealing with the -					; lambda version ( => lambda) - -	 (define (_unarrow l) -	   (cond ((null? l) l) -		 ((eq? (car l) '=>) `(( ,(cadr l) __key__))) -		 (else l)) -	   ) - -					; Build the case elements, which is -					; simply a list of cond clauses - -	 (define (_case l) - -	   (cond ((null? l) ()) - -					; else case - -		 ((eq? (caar l) 'else) -		  `((else ,@(_unarrow (cdr (car l)))))) - -					; regular case -		  -		 (else -		  (cons -		   `((eqv? ,(caar l) __key__) -		     ,@(_unarrow (cdr (car l)))) -		   (_case (cdr l))) -		  ) -		 ) -	   ) - -					; now construct the overall -					; expression, using a lambda -					; to hold the computed value -					; of the test expression - -	 `((lambda (__key__) -	     (cond ,@(_case l))) ,test) -	 ) -  ) - -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) - -;(define number->string (lambda (arg . opt) -;			      (let ((base (if (null? opt) 10 (car opt))) -					; -; -				 diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c deleted file mode 100644 index 7f909487..00000000 --- a/src/lisp/ao_lisp_error.c +++ /dev/null @@ -1,139 +0,0 @@ -/* - * 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_write(cons->car); -				printf("\n"); -				if (poly == last) -					break; -				poly = cons->cdr; -			} -			printf("\t\t         )\n"); -		} else -			printf(")\n"); -	} else { -		ao_lisp_poly_write(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) { -		struct ao_lisp_frame_vals	*vals = ao_lisp_poly_frame_vals(frame->vals); -		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_write(vals->vals[f].atom); -				printf(" = "); -				ao_lisp_poly_write(vals->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"); -} - -void -ao_lisp_vprintf(char *format, va_list args) -{ -	char c; - -	while ((c = *format++) != '\0') { -		if (c == '%') { -			switch (c = *format++) { -			case 'v': -				ao_lisp_poly_write((ao_poly) va_arg(args, unsigned int)); -				break; -			case 'p': -				printf("%p", va_arg(args, void *)); -				break; -			case 'd': -				printf("%d", va_arg(args, int)); -				break; -			case 's': -				printf("%s", va_arg(args, char *)); -				break; -			default: -				putchar(c); -				break; -			} -		} else -			putchar(c); -	} -} - -void -ao_lisp_printf(char *format, ...) -{ -	va_list args; -	va_start(args, format); -	ao_lisp_vprintf(format, args); -	va_end(args); -} - -ao_poly -ao_lisp_error(int error, char *format, ...) -{ -	va_list	args; - -	ao_lisp_exception |= error; -	va_start(args, format); -	ao_lisp_vprintf(format, args); -	putchar('\n'); -	va_end(args); -	ao_lisp_printf("Value:  %v\n", ao_lisp_v); -	ao_lisp_printf("Frame:  %v\n", ao_lisp_frame_poly(ao_lisp_frame_current)); -	printf("Stack:\n"); -	ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); -	ao_lisp_printf("Globals: %v\n", ao_lisp_frame_poly(ao_lisp_frame_global)); -	return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c deleted file mode 100644 index c3dd2ed2..00000000 --- a/src/lisp/ao_lisp_eval.c +++ /dev/null @@ -1,578 +0,0 @@ -/* - * 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; -uint8_t				ao_lisp_skip_cons_free; - -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: %v\n", ao_lisp_v); -	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_BOOL: -	case AO_LISP_INT: -	case AO_LISP_BIGINT: -	case AO_LISP_FLOAT: -	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, macro or nlambda. - * - * For lambda, 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: -			DBGI(".. lambda\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("\t.. sexprs       "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -			DBGI("\t.. 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(ao_lisp_v, AO_LISP_NIL); -	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 && (builtin->args & AO_LISP_FUNC_FREE_ARGS) && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) { -			struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); -			ao_lisp_stack->values = AO_LISP_NIL; -			ao_lisp_cons_free(cons); -		} - -		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_begin; -		v = ao_lisp_lambda_eval(); -		ao_lisp_stack->sexprs = v; -		ao_lisp_stack->values = AO_LISP_NIL; -		ao_lisp_stack->values_tail = AO_LISP_NIL; -		DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -		DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -		break; -	case AO_LISP_STACK: -		DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); -		ao_lisp_v = ao_lisp_stack_eval(); -		DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); -		DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -		break; -	} -	ao_lisp_skip_cons_free = 0; -	return 1; -} - -/* - * Finish setting up the apply evaluation - * - * The value is the list to execute - */ -static int -ao_lisp_eval_apply(void) -{ -	struct ao_lisp_cons	*cons = ao_lisp_poly_cons(ao_lisp_v); -	struct ao_lisp_cons	*cdr, *prev; - -	/* Glue the arguments into the right shape. That's all but the last -	 * concatenated onto the last -	 */ -	cdr = cons; -	for (;;) { -		prev = cdr; -		cdr = ao_lisp_poly_cons(prev->cdr); -		if (cdr->cdr == AO_LISP_NIL) -			break; -	} -	DBGI("before mangling: "); DBG_POLY(ao_lisp_v); DBG("\n"); -	prev->cdr = cdr->car; -	ao_lisp_stack->values = ao_lisp_v; -	ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; -	DBGI("apply: "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); -	ao_lisp_stack->state = eval_exec; -	ao_lisp_skip_cons_free = 1; -	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_bool_false; -		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; -		if (ao_lisp_v == _ao_lisp_atom_else) -			ao_lisp_v = _ao_lisp_bool_true; -		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 != _ao_lisp_bool_false) { -		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_begin; -			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_begin 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_begin 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_begin(void) -{ -	DBGI("begin: "); 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_begin; -			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_bool_false) { -		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_begin; -		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_apply] = ao_lisp_eval_apply, -	[eval_cond] = ao_lisp_eval_cond, -	[eval_cond_test] = ao_lisp_eval_cond_test, -	[eval_begin] = ao_lisp_eval_begin, -	[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[] = { -	[eval_sexpr] = "sexpr", -	[eval_val] = "val", -	[eval_formal] = "formal", -	[eval_exec] = "exec", -	[eval_apply] = "apply", -	[eval_cond] = "cond", -	[eval_cond_test] = "cond_test", -	[eval_begin] = "begin", -	[eval_while] = "while", -	[eval_while_test] = "while_test", -	[eval_macro] = "macro", -}; - -/* - * 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; - -	ao_lisp_frame_init(); - -	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_float.c b/src/lisp/ao_lisp_float.c deleted file mode 100644 index 0aa6f2ea..00000000 --- a/src/lisp/ao_lisp_float.c +++ /dev/null @@ -1,148 +0,0 @@ -/* - * Copyright © 2017 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 <math.h> - -static void float_mark(void *addr) -{ -	(void) addr; -} - -static int float_size(void *addr) -{ -	if (!addr) -		return 0; -	return sizeof (struct ao_lisp_float); -} - -static void float_move(void *addr) -{ -	(void) addr; -} - -const struct ao_lisp_type ao_lisp_float_type = { -	.mark = float_mark, -	.size = float_size, -	.move = float_move, -	.name = "float", -}; - -void -ao_lisp_float_write(ao_poly p) -{ -	struct ao_lisp_float *f = ao_lisp_poly_float(p); -	float	v = f->value; - -	if (isnanf(v)) -		printf("+nan.0"); -	else if (isinff(v)) { -		if (v < 0) -			printf("-"); -		else -			printf("+"); -		printf("inf.0"); -	} else -		printf ("%g", f->value); -} - -float -ao_lisp_poly_number(ao_poly p) -{ -	switch (ao_lisp_poly_base_type(p)) { -	case AO_LISP_INT: -		return ao_lisp_poly_int(p); -	case AO_LISP_OTHER: -		switch (ao_lisp_other_type(ao_lisp_poly_other(p))) { -		case AO_LISP_BIGINT: -			return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); -		case AO_LISP_FLOAT: -			return ao_lisp_poly_float(p)->value; -		} -	} -	return NAN; -} - -ao_poly -ao_lisp_float_get(float value) -{ -	struct ao_lisp_float	*f; - -	f = ao_lisp_alloc(sizeof (struct ao_lisp_float)); -	f->type = AO_LISP_FLOAT; -	f->value = value; -	return ao_lisp_float_poly(f); -} - -ao_poly -ao_lisp_do_inexactp(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_FLOAT) -		return _ao_lisp_bool_true; -	return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_finitep(struct ao_lisp_cons *cons) -{ -	ao_poly	value; -	float	f; - -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	value = ao_lisp_arg(cons, 0); -	switch (ao_lisp_poly_type(value)) { -	case AO_LISP_INT: -	case AO_LISP_BIGINT: -		return _ao_lisp_bool_true; -	case AO_LISP_FLOAT: -		f = ao_lisp_poly_float(value)->value; -		if (!isnan(f) && !isinf(f)) -			return _ao_lisp_bool_true; -	} -	return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_infinitep(struct ao_lisp_cons *cons) -{ -	ao_poly	value; -	float	f; - -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	value = ao_lisp_arg(cons, 0); -	switch (ao_lisp_poly_type(value)) { -	case AO_LISP_FLOAT: -		f = ao_lisp_poly_float(value)->value; -		if (isinf(f)) -			return _ao_lisp_bool_true; -	} -	return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_sqrt(struct ao_lisp_cons *cons) -{ -	ao_poly	value; - -	if (!ao_lisp_check_argc(_ao_lisp_atom_sqrt, cons, 1, 1)) -		return AO_LISP_NIL; -	value = ao_lisp_arg(cons, 0); -	if (!ao_lisp_number_typep(ao_lisp_poly_type(value))) -		return ao_lisp_error(AO_LISP_INVALID, "%s: non-numeric", ao_lisp_poly_atom(_ao_lisp_atom_sqrt)->name); -	return ao_lisp_float_get(sqrtf(ao_lisp_poly_number(value))); -} diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c deleted file mode 100644 index c285527e..00000000 --- a/src/lisp/ao_lisp_frame.c +++ /dev/null @@ -1,330 +0,0 @@ -/* - * 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_vals_num_size(int num) -{ -	return sizeof (struct ao_lisp_frame_vals) + num * sizeof (struct ao_lisp_val); -} - -static int -frame_vals_size(void *addr) -{ -	struct ao_lisp_frame_vals	*vals = addr; -	return frame_vals_num_size(vals->size); -} - -static void -frame_vals_mark(void *addr) -{ -	struct ao_lisp_frame_vals	*vals = addr; -	int				f; - -	for (f = 0; f < vals->size; f++) { -		struct ao_lisp_val	*v = &vals->vals[f]; - -		ao_lisp_poly_mark(v->val, 0); -		MDBG_MOVE("frame mark atom %s %d val %d at %d    ", -			  ao_lisp_poly_atom(v->atom)->name, -			  MDBG_OFFSET(ao_lisp_ref(v->atom)), -			  MDBG_OFFSET(ao_lisp_ref(v->val)), f); -		MDBG_DO(ao_lisp_poly_write(v->val)); -		MDBG_DO(printf("\n")); -	} -} - -static void -frame_vals_move(void *addr) -{ -	struct ao_lisp_frame_vals	*vals = addr; -	int				f; - -	for (f = 0; f < vals->size; f++) { -		struct ao_lisp_val	*v = &vals->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); -	} -} - -const struct ao_lisp_type ao_lisp_frame_vals_type = { -	.mark = frame_vals_mark, -	.size = frame_vals_size, -	.move = frame_vals_move, -	.name = "frame_vals" -}; - -static int -frame_size(void *addr) -{ -	(void) addr; -	return sizeof (struct ao_lisp_frame); -} - -static void -frame_mark(void *addr) -{ -	struct ao_lisp_frame	*frame = addr; - -	for (;;) { -		MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); -		if (!AO_LISP_IS_POOL(frame)) -			break; -		ao_lisp_poly_mark(frame->vals, 0); -		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; - -	for (;;) { -		struct ao_lisp_frame	*prev; -		int			ret; - -		MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); -		if (!AO_LISP_IS_POOL(frame)) -			break; -		ao_lisp_poly_move(&frame->vals, 0); -		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_write(ao_poly p) -{ -	struct ao_lisp_frame		*frame = ao_lisp_poly_frame(p); -	struct ao_lisp_frame_vals	*vals = ao_lisp_poly_frame_vals(frame->vals); -	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_write(vals->vals[f].atom); -				printf(" = "); -				ao_lisp_poly_write(vals->vals[f].val); -			} -			if (frame->prev) -				ao_lisp_poly_write(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) -{ -	struct ao_lisp_frame_vals	*vals = ao_lisp_poly_frame_vals(frame->vals); -	int 				l = 0; -	int 				r = top - 1; - -	while (l <= r) { -		int m = (l + r) >> 1; -		if (vals->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) -{ -	struct ao_lisp_frame_vals	*vals = ao_lisp_poly_frame_vals(frame->vals); -	int				l = ao_lisp_frame_find(frame, frame->num, atom); - -	if (l >= frame->num) -		return NULL; - -	if (vals->vals[l].atom != atom) -		return NULL; -	return &vals->vals[l].val; -} - -struct ao_lisp_frame	*ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -static struct ao_lisp_frame_vals * -ao_lisp_frame_vals_new(int num) -{ -	struct ao_lisp_frame_vals	*vals; - -	vals = ao_lisp_alloc(frame_vals_num_size(num)); -	if (!vals) -		return NULL; -	vals->type = AO_LISP_FRAME_VALS; -	vals->size = num; -	memset(vals->vals, '\0', num * sizeof (struct ao_lisp_val)); -	return vals; -} - -struct ao_lisp_frame * -ao_lisp_frame_new(int num) -{ -	struct ao_lisp_frame		*frame; -	struct ao_lisp_frame_vals	*vals; - -	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); -		vals = ao_lisp_poly_frame_vals(frame->vals); -	} else { -		frame = ao_lisp_alloc(sizeof (struct ao_lisp_frame)); -		if (!frame) -			return NULL; -		frame->type = AO_LISP_FRAME; -		frame->num = 0; -		frame->prev = AO_LISP_NIL; -		frame->vals = AO_LISP_NIL; -		ao_lisp_frame_stash(0, frame); -		vals = ao_lisp_frame_vals_new(num); -		frame = ao_lisp_frame_fetch(0); -		if (!vals) -			return NULL; -		frame->vals = ao_lisp_frame_vals_poly(vals); -		frame->num = num; -	} -	frame->prev = AO_LISP_NIL; -	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 (frame && !ao_lisp_frame_marked(frame)) { -		int	num = frame->num; -		if (num < AO_LISP_FRAME_FREE) { -			struct ao_lisp_frame_vals	*vals; - -			vals = ao_lisp_poly_frame_vals(frame->vals); -			memset(vals->vals, '\0', vals->size * sizeof (struct ao_lisp_val)); -			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, int new_num) -{ -	struct ao_lisp_frame_vals	*vals; -	struct ao_lisp_frame_vals	*new_vals; -	int				copy; - -	if (new_num == frame->num) -		return frame; -	ao_lisp_frame_stash(0, frame); -	new_vals = ao_lisp_frame_vals_new(new_num); -	frame = ao_lisp_frame_fetch(0); -	if (!new_vals) -		return NULL; -	vals = ao_lisp_poly_frame_vals(frame->vals); -	copy = new_num; -	if (copy > frame->num) -		copy = frame->num; -	memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_lisp_val)); -	frame->vals = ao_lisp_frame_vals_poly(new_vals); -	frame->num = new_num; -	return frame; -} - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) -{ -	struct ao_lisp_frame_vals	*vals = ao_lisp_poly_frame_vals(frame->vals); -	int 				l = ao_lisp_frame_find(frame, num, atom); - -	memmove(&vals->vals[l+1], -		&vals->vals[l], -		(num - l) * sizeof (struct ao_lisp_val)); -	vals->vals[l].atom = atom; -	vals->vals[l].val = val; -} - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) -{ -	ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; - -	if (!ref) { -		int f = frame->num; -		ao_lisp_poly_stash(0, atom); -		ao_lisp_poly_stash(1, val); -		frame = ao_lisp_frame_realloc(frame, f + 1); -		val = ao_lisp_poly_fetch(1); -		atom = ao_lisp_poly_fetch(0); -		if (!frame) -			return AO_LISP_NIL; -		ao_lisp_frame_bind(frame, frame->num - 1, atom, val); -	} else -		*ref = val; -	return val; -} - -struct ao_lisp_frame	*ao_lisp_frame_global; -struct ao_lisp_frame	*ao_lisp_frame_current; - -void -ao_lisp_frame_init(void) -{ -	if (!ao_lisp_frame_global) -		ao_lisp_frame_global = ao_lisp_frame_new(0); -} diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c deleted file mode 100644 index 8e467755..00000000 --- a/src/lisp/ao_lisp_int.c +++ /dev/null @@ -1,79 +0,0 @@ -/* - * 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_write(ao_poly p) -{ -	int i = ao_lisp_poly_int(p); -	printf("%d", i); -} - -int32_t -ao_lisp_poly_integer(ao_poly p) -{ -	switch (ao_lisp_poly_base_type(p)) { -	case AO_LISP_INT: -		return ao_lisp_poly_int(p); -	case AO_LISP_OTHER: -		if (ao_lisp_other_type(ao_lisp_poly_other(p)) == AO_LISP_BIGINT) -			return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); -	} -	return AO_LISP_NOT_INTEGER; -} - -ao_poly -ao_lisp_integer_poly(int32_t p) -{ -	struct ao_lisp_bigint	*bi; - -	if (AO_LISP_MIN_INT <= p && p <= AO_LISP_MAX_INT) -		return ao_lisp_int_poly(p); -	bi = ao_lisp_alloc(sizeof (struct ao_lisp_bigint)); -	bi->value = ao_lisp_int_bigint(p); -	return ao_lisp_bigint_poly(bi); -} - -static void bigint_mark(void *addr) -{ -	(void) addr; -} - -static int bigint_size(void *addr) -{ -	if (!addr) -		return 0; -	return sizeof (struct ao_lisp_bigint); -} - -static void bigint_move(void *addr) -{ -	(void) addr; -} - -const struct ao_lisp_type ao_lisp_bigint_type = { -	.mark = bigint_mark, -	.size = bigint_size, -	.move = bigint_move, -	.name = "bigint", -}; - -void -ao_lisp_bigint_write(ao_poly p) -{ -	struct ao_lisp_bigint	*bi = ao_lisp_poly_bigint(p); - -	printf("%d", ao_lisp_bigint_int(bi->value)); -} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c deleted file mode 100644 index e72281db..00000000 --- a/src/lisp/ao_lisp_lambda.c +++ /dev/null @@ -1,208 +0,0 @@ -/* - * 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_write(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_write(cons->car); -		cons = ao_lisp_poly_cons(cons->cdr); -	} -	printf(")"); -} - -ao_poly -ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) -{ -	struct ao_lisp_lambda	*lambda; -	ao_poly			formal; -	struct ao_lisp_cons	*cons; - -	formal = ao_lisp_arg(code, 0); -	while (formal != AO_LISP_NIL) { -		switch (ao_lisp_poly_type(formal)) { -		case AO_LISP_CONS: -			cons = ao_lisp_poly_cons(formal); -			if (ao_lisp_poly_type(cons->car) != AO_LISP_ATOM) -				return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", cons->car); -			formal = cons->cdr; -			break; -		case AO_LISP_ATOM: -			formal = AO_LISP_NIL; -			break; -		default: -			return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", formal); -		} -	} - -	ao_lisp_cons_stash(0, code); -	lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); -	code = ao_lisp_cons_fetch(0); -	if (!lambda) -		return AO_LISP_NIL; - -	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_do_lambda(struct ao_lisp_cons *cons) -{ -	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); -} - -ao_poly -ao_lisp_do_nlambda(struct ao_lisp_cons *cons) -{ -	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); -} - -ao_poly -ao_lisp_do_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); -	ao_poly			formals; -	struct ao_lisp_frame	*next_frame; -	int			args_wanted; -	ao_poly			varargs = AO_LISP_NIL; -	int			args_provided; -	int			f; -	struct ao_lisp_cons	*vals; - -	DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - -	args_wanted = 0; -	for (formals = ao_lisp_arg(code, 0); -	     ao_lisp_is_pair(formals); -	     formals = ao_lisp_poly_cons(formals)->cdr) -		++args_wanted; -	if (formals != AO_LISP_NIL) { -		if (ao_lisp_poly_type(formals) != AO_LISP_ATOM) -			return ao_lisp_error(AO_LISP_INVALID, "bad lambda form"); -		varargs = formals; -	} - -	/* Create a frame to hold the variables -	 */ -	args_provided = ao_lisp_cons_length(cons) - 1; -	if (varargs == AO_LISP_NIL) { -		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) -			return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); -	} - -	ao_lisp_poly_stash(1, varargs); -	next_frame = ao_lisp_frame_new(args_wanted + (varargs != AO_LISP_NIL)); -	varargs = ao_lisp_poly_fetch(1); -	if (!next_frame) -		return AO_LISP_NIL; - -	/* 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); -	formals = 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); - -	for (f = 0; f < args_wanted; f++) { -		struct ao_lisp_cons *arg = ao_lisp_poly_cons(formals); -		DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); -		ao_lisp_frame_bind(next_frame, f, arg->car, vals->car); -		formals = arg->cdr; -		vals = ao_lisp_poly_cons(vals->cdr); -	} -	if (varargs) { -		DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); -		/* -		 * Bind the rest of the arguments to the final parameter -		 */ -		ao_lisp_frame_bind(next_frame, f, varargs, ao_lisp_cons_poly(vals)); -	} else { -		/* -		 * Mark the cons cells from the actuals as freed for immediate re-use, unless -		 * the actuals point into the source function (nlambdas and macros), or if the -		 * stack containing them was copied as a part of a continuation -		 */ -		if (lambda->args == AO_LISP_FUNC_LAMBDA && !ao_lisp_stack_marked(ao_lisp_stack)) { -			ao_lisp_stack->values = AO_LISP_NIL; -			ao_lisp_cons_free(cons); -		} -	} -	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 deleted file mode 100644 index fe7c47f4..00000000 --- a/src/lisp/ao_lisp_lex.c +++ /dev/null @@ -1,16 +0,0 @@ -/* - * 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_builtin b/src/lisp/ao_lisp_make_builtin deleted file mode 100644 index 783ab378..00000000 --- a/src/lisp/ao_lisp_make_builtin +++ /dev/null @@ -1,190 +0,0 @@ -#!/usr/bin/nickle - -typedef struct { -	string	type; -	string	c_name; -	string[*]	lisp_names; -} builtin_t; - -string[string] type_map = { -	"lambda" => "LAMBDA", -	"nlambda" => "NLAMBDA", -	"macro" => "MACRO", -	"f_lambda" => "F_LAMBDA", -	"atom" => "atom", -}; - -string[*] -make_lisp(string[*] tokens) -{ -	string[...] lisp = {}; - -	if (dim(tokens) < 3) -		return (string[1]) { tokens[dim(tokens) - 1] }; -	return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; -} - -builtin_t -read_builtin(file f) { -	string	line = File::fgets(f); -	string[*]	tokens = String::wordsplit(line, " \t"); - -	return (builtin_t) { -		.type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", -		.c_name = dim(tokens) > 1 ? tokens[1] : "#", -		.lisp_names = make_lisp(tokens), -	}; -} - -builtin_t[*] -read_builtins(file f) { -	builtin_t[...] builtins = {}; - -	while (!File::end(f)) { -		builtin_t	b = read_builtin(f); - -		if (b.type[0] != '#') -			builtins[dim(builtins)] = b; -	} -	return builtins; -} - -bool is_atom(builtin_t b) = b.type == "atom"; - -void -dump_ids(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_ID\n"); -	printf("#undef AO_LISP_BUILTIN_ID\n"); -	printf("enum ao_lisp_builtin_id {\n"); -	for (int i = 0; i < dim(builtins); i++) -		if (!is_atom(builtins[i])) -			printf("\tbuiltin_%s,\n", builtins[i].c_name); -	printf("\t_builtin_last\n"); -	printf("};\n"); -	printf("#endif /* AO_LISP_BUILTIN_ID */\n"); -} - -void -dump_casename(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_CASENAME\n"); -	printf("#undef AO_LISP_BUILTIN_CASENAME\n"); -	printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); -	printf("\tswitch(b) {\n"); -	for (int i = 0; i < dim(builtins); i++) -		if (!is_atom(builtins[i])) -			printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", -			       builtins[i].c_name, builtins[i].lisp_names[0]); -	printf("\tdefault: return \"???\";\n"); -	printf("\t}\n"); -	printf("}\n"); -	printf("#endif /* AO_LISP_BUILTIN_CASENAME */\n"); -} - -void -cify_lisp(string l) { -	for (int j = 0; j < String::length(l); j++) { -		int c= l[j]; -		if (Ctype::isalnum(c) || c == '_') -			printf("%c", c); -		else -			printf("%02x", c); -	} -} - -void -dump_arrayname(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_ARRAYNAME\n"); -	printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n"); -	printf("static const ao_poly builtin_names[] = {\n"); -	for (int i = 0; i < dim(builtins); i++) { -		if (!is_atom(builtins[i])) { -			printf("\t[builtin_%s] = _ao_lisp_atom_", -			       builtins[i].c_name); -			cify_lisp(builtins[i].lisp_names[0]); -			printf(",\n"); -		} -	} -	printf("};\n"); -	printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n"); -} - -void -dump_funcs(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_FUNCS\n"); -	printf("#undef AO_LISP_BUILTIN_FUNCS\n"); -	printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n"); -	for (int i = 0; i < dim(builtins); i++) { -		if (!is_atom(builtins[i])) -			printf("\t[builtin_%s] = ao_lisp_do_%s,\n", -			       builtins[i].c_name, -			       builtins[i].c_name); -	} -	printf("};\n"); -	printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); -} - -void -dump_decls(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); -	printf("#undef AO_LISP_BUILTIN_DECLS\n"); -	for (int i = 0; i < dim(builtins); i++) { -		if (!is_atom(builtins[i])) { -			printf("ao_poly\n"); -			printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", -			       builtins[i].c_name); -		} -	} -	printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); -} - -void -dump_consts(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_CONSTS\n"); -	printf("#undef AO_LISP_BUILTIN_CONSTS\n"); -	printf("struct builtin_func funcs[] = {\n"); -	for (int i = 0; i < dim(builtins); i++) { -		if (!is_atom(builtins[i])) { -			for (int j = 0; j < dim(builtins[i].lisp_names); j++) { -				printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", -					builtins[i].lisp_names[j], -					builtins[i].type, -					builtins[i].c_name); -			} -		} -	} -	printf("};\n"); -	printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); -} - -void -dump_atoms(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_ATOMS\n"); -	printf("#undef AO_LISP_BUILTIN_ATOMS\n"); -	for (int i = 0; i < dim(builtins); i++) { -		for (int j = 0; j < dim(builtins[i].lisp_names); j++) { -			printf("#define _ao_lisp_atom_"); -			cify_lisp(builtins[i].lisp_names[j]); -			printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); -		} -	} -	printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); -} - -void main() { -	if (dim(argv) < 2) { -		File::fprintf(stderr, "usage: %s <file>\n", argv[0]); -		exit(1); -	} -	twixt(file f = File::open(argv[1], "r"); File::close(f)) { -		builtin_t[*]	builtins = read_builtins(f); -		dump_ids(builtins); -		dump_casename(builtins); -		dump_arrayname(builtins); -		dump_funcs(builtins); -		dump_decls(builtins); -		dump_consts(builtins); -		dump_atoms(builtins); -	} -} - -main(); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c deleted file mode 100644 index 6e4b411e..00000000 --- a/src/lisp/ao_lisp_make_const.c +++ /dev/null @@ -1,395 +0,0 @@ -/* - * 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; -	enum ao_lisp_builtin_id	func; -}; - -#define AO_LISP_BUILTIN_CONSTS -#include "ao_lisp_builtin.h" - -#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(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_write(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_write(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; -	ao_poly			list; - -	if (p == AO_LISP_NIL) -		return AO_LISP_NIL; - -	MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_write(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; - -		list = cons->cdr; -		p = AO_LISP_NIL; -		while (list != AO_LISP_NIL && ao_lisp_poly_type(list) == AO_LISP_CONS) { -			cons = ao_lisp_poly_cons(list); -			m = ao_has_macro(cons->car); -			if (m) { -				p = m; -				break; -			} -			list = cons->cdr; -		} -		break; - -	default: -		p = AO_LISP_NIL; -		break; -	} -	MACRO_DEBUG(--macro_scan_depth;	indent(); printf("... "); ao_lisp_poly_write(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_write(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; -	enum ao_lisp_builtin_id	prev_func; - -	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; -		} -	} - -	ao_lisp_frame_init(); - -	/* Boolean values #f and #t */ -	ao_lisp_bool_get(0); -	ao_lisp_bool_get(1); - -	prev_func = _builtin_last; -	for (f = 0; f < (int) N_FUNC; f++) { -		if (funcs[f].func != prev_func) -			b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); -		a = ao_lisp_atom_intern(funcs[f].name); -		ao_lisp_atom_def(ao_lisp_atom_poly(a), -				 ao_lisp_builtin_poly(b)); -	} - -	/* end of file value */ -	a = ao_lisp_atom_intern("eof"); -	ao_lisp_atom_def(ao_lisp_atom_poly(a), -			 ao_lisp_atom_poly(a)); - -	/* 'else' */ -	a = ao_lisp_atom_intern("else"); - -	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++) { -		struct ao_lisp_frame_vals	*vals = ao_lisp_poly_frame_vals(ao_lisp_frame_global->vals); -		val = ao_has_macro(vals->vals[f].val); -		if (val != AO_LISP_NIL) { -			printf("error: function %s contains unresolved macro: ", -			       ao_lisp_poly_atom(vals->vals[f].atom)->name); -			ao_lisp_poly_write(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)); - -	fprintf(out, "#define _ao_lisp_bool_false 0x%04x\n", ao_lisp_bool_poly(ao_lisp_false)); -	fprintf(out, "#define _ao_lisp_bool_true 0x%04x\n", ao_lisp_bool_poly(ao_lisp_true)); - -	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 deleted file mode 100644 index 5471b137..00000000 --- a/src/lisp/ao_lisp_mem.c +++ /dev/null @@ -1,968 +0,0 @@ -/* - * 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> -#include <assert.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 struct ao_lisp_frame	*save_frame[1]; -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 = &ao_lisp_frame_type, -		.addr = (void **) &save_frame[0], -	}, -	{ -		.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, -	}, -#ifdef AO_LISP_MAKE_CONST -	{ -		.type = &ao_lisp_bool_type, -		.addr = (void **) &ao_lisp_false, -	}, -	{ -		.type = &ao_lisp_bool_type, -		.addr = (void **) &ao_lisp_true, -	}, -#endif -}; - -#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 *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_FRAME_VALS] = &ao_lisp_frame_vals_type, -	[AO_LISP_LAMBDA] = &ao_lisp_lambda_type, -	[AO_LISP_STACK] = &ao_lisp_stack_type, -	[AO_LISP_BOOL] = &ao_lisp_bool_type, -	[AO_LISP_BIGINT] = &ao_lisp_bigint_type, -	[AO_LISP_FLOAT] = &ao_lisp_float_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 -	MDBG_DO(ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global))); - -	/* 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; -} - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons) -{ -	ao_poly	cdr; -	int offset; - -	chunk_low = 0; -	reset_chunks(); -	walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -	while (cons) { -		if (!AO_LISP_IS_POOL(cons)) -			break; -		offset = pool_offset(cons); -		if (busy(ao_lisp_busy, offset)) { -			ao_lisp_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_lisp_cons_poly(cons), ao_lisp_cons_poly(cons)); -			abort(); -		} -		cdr = cons->cdr; -		if (!ao_lisp_is_pair(cdr)) -			break; -		cons = ao_lisp_poly_cons(cdr); -	} -} -#endif - -/* - * Mark interfaces for objects - */ - - -/* - * Mark a block of memory with an explicit size - */ - -int -ao_lisp_mark_block(void *addr, int size) -{ -	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, size); -	return 0; -} - -/* - * 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; -	MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); -	return addr; -} - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) -{ -	assert(save_cons[id] == 0); -	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) -{ -	assert(save_poly[id] == AO_LISP_NIL); -	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) -{ -	assert(save_string[id] == NULL); -	save_string[id] = string; -} - -char * -ao_lisp_string_fetch(int id) -{ -	char *string = save_string[id]; -	save_string[id] = NULL; -	return string; -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) -{ -	assert(save_frame[id] == NULL); -	save_frame[id] = frame; -} - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id) -{ -	struct ao_lisp_frame *frame = save_frame[id]; -	save_frame[id] = NULL; -	return frame; -} diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h deleted file mode 100644 index 4285cb8c..00000000 --- a/src/lisp/ao_lisp_os.h +++ /dev/null @@ -1,63 +0,0 @@ -/* - * 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); -} - -#define AO_LISP_JIFFIES_PER_SECOND	100 - -static inline void -ao_lisp_os_delay(int jiffies) -{ -	struct timespec ts = { -		.tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, -		.tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) -	}; -	nanosleep(&ts, NULL); -} - -static inline int -ao_lisp_os_jiffy(void) -{ -	struct timespec tp; -	clock_gettime(CLOCK_MONOTONIC, &tp); -	return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); -} -#endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c deleted file mode 100644 index d14f4151..00000000 --- a/src/lisp/ao_lisp_poly.c +++ /dev/null @@ -1,118 +0,0 @@ -/* - * 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 (*write)(ao_poly); -	void (*display)(ao_poly); -}; - -static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { -	[AO_LISP_CONS] = { -		.write = ao_lisp_cons_write, -		.display = ao_lisp_cons_display, -	}, -	[AO_LISP_STRING] = { -		.write = ao_lisp_string_write, -		.display = ao_lisp_string_display, -	}, -	[AO_LISP_INT] = { -		.write = ao_lisp_int_write, -		.display = ao_lisp_int_write, -	}, -	[AO_LISP_ATOM] = { -		.write = ao_lisp_atom_write, -		.display = ao_lisp_atom_write, -	}, -	[AO_LISP_BUILTIN] = { -		.write = ao_lisp_builtin_write, -		.display = ao_lisp_builtin_write, -	}, -	[AO_LISP_FRAME] = { -		.write = ao_lisp_frame_write, -		.display = ao_lisp_frame_write, -	}, -	[AO_LISP_FRAME_VALS] = { -		.write = NULL, -		.display = NULL, -	}, -	[AO_LISP_LAMBDA] = { -		.write = ao_lisp_lambda_write, -		.display = ao_lisp_lambda_write, -	}, -	[AO_LISP_STACK] = { -		.write = ao_lisp_stack_write, -		.display = ao_lisp_stack_write, -	}, -	[AO_LISP_BOOL] = { -		.write = ao_lisp_bool_write, -		.display = ao_lisp_bool_write, -	}, -	[AO_LISP_BIGINT] = { -		.write = ao_lisp_bigint_write, -		.display = ao_lisp_bigint_write, -	}, -	[AO_LISP_FLOAT] = { -		.write = ao_lisp_float_write, -		.display = ao_lisp_float_write, -	}, -}; - -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_write(ao_poly p) -{ -	const struct ao_lisp_funcs *f = funcs(p); - -	if (f && f->write) -		f->write(p); -} - -void -ao_lisp_poly_display(ao_poly p) -{ -	const struct ao_lisp_funcs *f = funcs(p); - -	if (f && f->display) -		f->display(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 deleted file mode 100644 index 0ca12a81..00000000 --- a/src/lisp/ao_lisp_read.c +++ /dev/null @@ -1,655 +0,0 @@ -/* - * 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" -#include <math.h> -#include <stdlib.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|POUND,	/* # */ - 	PRINTABLE,		/* $ */ - 	PRINTABLE,		/* % */ - 	PRINTABLE,		/* & */ - 	PRINTABLE|SPECIAL,	/* ' */ - 	PRINTABLE|SPECIAL,	/* ( */ - 	PRINTABLE|SPECIAL,	/* ) */ - 	PRINTABLE,		/* * */ - 	PRINTABLE|SIGN,		/* + */ - 	PRINTABLE|SPECIAL,	/* , */ - 	PRINTABLE|SIGN,		/* - */ - 	PRINTABLE|DOTC|FLOATC,	/* . */ - 	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|FLOATC,	/*  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|SPECIAL,	/*  ` */ -	PRINTABLE,		/*  a */ -	PRINTABLE,		/*  b */ -	PRINTABLE,		/*  c */ -	PRINTABLE,		/*  d */ -	PRINTABLE|FLOATC,	/*  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,		/*  | */ -	PRINTABLE,		/*  } */ -	PRINTABLE,		/*  ~ */ -	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 uint16_t	lex_class; - -static int -lexc(void) -{ -	int	c; -	do { -		c = lex_get(); -		if (c == EOF) { -			c = 0; -			lex_class = ENDOFFILE; -		} else { -			c &= 0x7f; -			lex_class = lex_classes[c]; -		} -	} while (lex_class & IGNORE); -	return c; -} - -static int -lex_quoted(void) -{ -	int	c; -	int	v; -	int	count; - -	c = lex_get(); -	if (c == EOF) { -		lex_class = ENDOFFILE; -		return 0; -	} -	lex_class = 0; -	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; -	} -} - -#define AO_LISP_TOKEN_MAX	32 - -static char	token_string[AO_LISP_TOKEN_MAX]; -static int32_t	token_int; -static int	token_len; -static float	token_float; - -static inline void add_token(int c) { -	if (c && token_len < AO_LISP_TOKEN_MAX - 1) -		token_string[token_len++] = c; -} - -static inline void del_token(void) { -	if (token_len > 0) -		token_len--; -} - -static inline void end_token(void) { -	token_string[token_len] = '\0'; -} - -struct namedfloat { -	const char	*name; -	float		value; -}; - -static const struct namedfloat namedfloats[] = { -	{ .name = "+inf.0", .value = INFINITY }, -	{ .name = "-inf.0", .value = -INFINITY }, -	{ .name = "+nan.0", .value = NAN }, -	{ .name = "-nan.0", .value = NAN }, -}; - -#define NUM_NAMED_FLOATS	(sizeof namedfloats / sizeof namedfloats[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 & (SPECIAL|DOTC)) { -			add_token(c); -			end_token(); -			switch (c) { -			case '(': -			case '[': -				return OPEN; -			case ')': -			case ']': -				return CLOSE; -			case '\'': -				return QUOTE; -			case '.': -				return DOT; -			case '`': -				return QUASIQUOTE; -			case ',': -				c = lexc(); -				if (c == '@') { -					add_token(c); -					end_token(); -					return UNQUOTE_SPLICING; -				} else { -					lex_unget(c); -					return UNQUOTE; -				} -			} -		} -		if (lex_class & POUND) { -			c = lexc(); -			switch (c) { -			case 't': -				add_token(c); -				end_token(); -				return BOOL; -			case 'f': -				add_token(c); -				end_token(); -				return BOOL; -			case '\\': -				for (;;) { -					int alphabetic; -					c = lexc(); -					alphabetic = (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')); -					if (token_len == 0) { -						add_token(c); -						if (!alphabetic) -							break; -					} else { -						if (alphabetic) -							add_token(c); -						else { -							lex_unget(c); -							break; -						} -					} -				} -				end_token(); -				if (token_len == 1) -					token_int = token_string[0]; -				else if (!strcmp(token_string, "space")) -					token_int = ' '; -				else if (!strcmp(token_string, "newline")) -					token_int = '\n'; -				else if (!strcmp(token_string, "tab")) -					token_int = '\t'; -				else if (!strcmp(token_string, "return")) -					token_int = '\r'; -				else if (!strcmp(token_string, "formfeed")) -					token_int = '\f'; -				else { -					ao_lisp_error(AO_LISP_INVALID, "invalid character token #\\%s", token_string); -					continue; -				} -				return NUM; -			} -		} -		if (lex_class & STRINGC) { -			for (;;) { -				c = lexc(); -				if (lex_class & BACKSLASH) -					c = lex_quoted(); -				if (lex_class & (STRINGC|ENDOFFILE)) { -					end_token(); -					return STRING; -				} -				add_token(c); -			} -		} -		if (lex_class & PRINTABLE) { -			int	isfloat; -			int	hasdigit; -			int	isneg; -			int	isint; -			int	epos; - -			isfloat = 1; -			isint = 1; -			hasdigit = 0; -			token_int = 0; -			isneg = 0; -			epos = 0; -			for (;;) { -				if (!(lex_class & NUMBER)) { -					isint = 0; -					isfloat = 0; -				} else { -					if (!(lex_class & INTEGER)) -						isint = 0; - 					if (token_len != epos && -					    (lex_class & SIGN)) -					{ -						isint = 0; -						isfloat = 0; -					} -					if (c == '-') -						isneg = 1; -					if (c == '.' && epos != 0) -						isfloat = 0; -					if (c == 'e' || c == 'E') { -						if (token_len == 0) -							isfloat = 0; -						else -							epos = token_len + 1; -					} -					if (lex_class & DIGIT) { -						hasdigit = 1; -						if (isint) -							token_int = token_int * 10 + c - '0'; -					} -				} -				add_token (c); -				c = lexc (); -				if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { -					unsigned int u; -//					if (lex_class & ENDOFFILE) -//						clearerr (f); -					lex_unget(c); -					end_token (); -					if (isint && hasdigit) { -						if (isneg) -							token_int = -token_int; -						return NUM; -					} -					if (isfloat && hasdigit) { -						token_float = strtof(token_string, NULL); -						return FLOAT; -					} -					for (u = 0; u < NUM_NAMED_FLOATS; u++) -						if (!strcmp(namedfloats[u].name, token_string)) { -							token_float = namedfloats[u].value; -							return FLOAT; -						} -					return NAME; -				} -			} -		} -	} -} - -static inline int lex(void) -{ -	int	parse_token = _lex(); -	RDBGI("token %d (%s)\n", parse_token, token_string); -	return parse_token; -} - -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; - -#define READ_IN_QUOTE	0x01 -#define READ_SAW_DOT	0x02 -#define READ_DONE_DOT	0x04 - -static int -push_read_stack(int cons, int read_state) -{ -	RDBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); -	RDBG_IN(); -	if (cons) { -		ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), -						       ao_lisp__cons(ao_lisp_int_poly(read_state), -								     ao_lisp_cons_poly(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	read_state = 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); -		read_state = 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; -	} -	RDBG_OUT(); -	RDBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); -	return read_state; -} - -ao_poly -ao_lisp_read(void) -{ -	struct ao_lisp_atom	*atom; -	char			*string; -	int			cons; -	int			read_state; -	ao_poly			v = AO_LISP_NIL; - -	cons = 0; -	read_state = 0; -	ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; -	for (;;) { -		parse_token = lex(); -		while (parse_token == OPEN) { -			if (!push_read_stack(cons, read_state)) -				return AO_LISP_NIL; -			cons++; -			read_state = 0; -			parse_token = lex(); -		} - -		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_integer_poly(token_int); -			break; -		case FLOAT: -			v = ao_lisp_float_get(token_float); -			break; -		case BOOL: -			if (token_string[0] == 't') -				v = _ao_lisp_bool_true; -			else -				v = _ao_lisp_bool_false; -			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: -		case QUASIQUOTE: -		case UNQUOTE: -		case UNQUOTE_SPLICING: -			if (!push_read_stack(cons, read_state)) -				return AO_LISP_NIL; -			cons++; -			read_state = READ_IN_QUOTE; -			switch (parse_token) { -			case QUOTE: -				v = _ao_lisp_atom_quote; -				break; -			case QUASIQUOTE: -				v = _ao_lisp_atom_quasiquote; -				break; -			case UNQUOTE: -				v = _ao_lisp_atom_unquote; -				break; -			case UNQUOTE_SPLICING: -				v = _ao_lisp_atom_unquote2dsplicing; -				break; -			} -			break; -		case CLOSE: -			if (!cons) { -				v = AO_LISP_NIL; -				break; -			} -			v = ao_lisp_cons_poly(ao_lisp_read_cons); -			--cons; -			read_state = pop_read_stack(cons); -			break; -		case DOT: -			if (!cons) { -				ao_lisp_error(AO_LISP_INVALID, ". outside of cons"); -				return AO_LISP_NIL; -			} -			if (!ao_lisp_read_cons) { -				ao_lisp_error(AO_LISP_INVALID, ". first in cons"); -				return AO_LISP_NIL; -			} -			read_state |= READ_SAW_DOT; -			continue; -		} - -		/* loop over QUOTE ends */ -		for (;;) { -			if (!cons) -				return v; - -			if (read_state & READ_DONE_DOT) { -				ao_lisp_error(AO_LISP_INVALID, ". not last in cons"); -				return AO_LISP_NIL; -			} - -			if (read_state & READ_SAW_DOT) { -				read_state |= READ_DONE_DOT; -				ao_lisp_read_cons_tail->cdr = v; -			} else { -				struct ao_lisp_cons	*read = ao_lisp_cons_cons(v, AO_LISP_NIL); -				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 (!(read_state & READ_IN_QUOTE) || !ao_lisp_read_cons->cdr) -				break; - -			v = ao_lisp_cons_poly(ao_lisp_read_cons); -			--cons; -			read_state = pop_read_stack(cons); -		} -	} -	return v; -} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h deleted file mode 100644 index 8f6bf130..00000000 --- a/src/lisp/ao_lisp_read.h +++ /dev/null @@ -1,58 +0,0 @@ -/* - * 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_ - -/* - * token classes - */ - -# define END			0 -# define NAME			1 -# define OPEN  			2 -# define CLOSE			3 -# define QUOTE			4 -# define QUASIQUOTE		5 -# define UNQUOTE		6 -# define UNQUOTE_SPLICING	7 -# define STRING			8 -# define NUM			9 -# define FLOAT			10 -# define DOT			11 -# define BOOL			12 - -/* - * character classes - */ - -# define PRINTABLE	0x0001	/* \t \n ' ' - ~ */ -# define SPECIAL	0x0002	/* ( [ { ) ] } ' ` , */ -# define DOTC		0x0004	/* . */ -# define WHITE		0x0008	/* ' ' \t \n */ -# define DIGIT		0x0010	/* [0-9] */ -# define SIGN		0x0020	/* +- */ -# define FLOATC		0x0040	/* . e E */ -# define ENDOFFILE	0x0080	/* end of file */ -# define COMMENT	0x0100	/* ; */ -# define IGNORE		0x0200	/* \0 - ' ' */ -# define BACKSLASH	0x0400	/* \ */ -# define STRINGC	0x0800	/* " */ -# define POUND		0x1000	/* # */ - -# define NOTNAME	(STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define INTEGER	(DIGIT|SIGN) -# define NUMBER		(INTEGER|FLOATC) - -#endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c deleted file mode 100644 index 43cc387f..00000000 --- a/src/lisp/ao_lisp_rep.c +++ /dev/null @@ -1,36 +0,0 @@ -/* - * 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) -			break; -		out = ao_lisp_eval(in); -		if (ao_lisp_exception) { -			if (ao_lisp_exception & AO_LISP_EXIT) -				break; -			ao_lisp_exception = 0; -		} else { -			ao_lisp_poly_write(out); -			putchar ('\n'); -		} -	} -	return out; -} diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c deleted file mode 100644 index c990e9c6..00000000 --- a/src/lisp/ao_lisp_save.c +++ /dev/null @@ -1,77 +0,0 @@ -/* - * 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_do_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_bool_true; -#endif -	return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_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_bool_false; - -		return _ao_lisp_bool_true; -	} -#endif -	return _ao_lisp_bool_false; -} diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c deleted file mode 100644 index e7c89801..00000000 --- a/src/lisp/ao_lisp_stack.c +++ /dev/null @@ -1,280 +0,0 @@ -/* - * 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; - -	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_write(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_write(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_do_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_begin; -	return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c deleted file mode 100644 index 1daa50ea..00000000 --- a/src/lisp/ao_lisp_string.c +++ /dev/null @@ -1,161 +0,0 @@ -/* - * 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_integer_typep(ao_lisp_poly_type(cons->car))) -			return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); -		*s++ = ao_lisp_poly_integer(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), AO_LISP_NIL); -		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_write(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: -			if (c < ' ') -				printf("\\%03o", c); -			else -				putchar(c); -			break; -		} -	} -	putchar('"'); -} - -void -ao_lisp_string_display(ao_poly p) -{ -	char	*s = ao_lisp_poly_string(p); -	char	c; - -	while ((c = *s++)) -		putchar(c); -} | 
