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 | |
| 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')
51 files changed, 5617 insertions, 5575 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/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_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_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_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_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_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_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/scheme/.gitignore b/src/scheme/.gitignore new file mode 100644 index 00000000..ee72cb9d --- /dev/null +++ b/src/scheme/.gitignore @@ -0,0 +1,2 @@ +ao_scheme_const.h +ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile new file mode 100644 index 00000000..d8e4b553 --- /dev/null +++ b/src/scheme/Makefile @@ -0,0 +1,16 @@ +all: ao_scheme_builtin.h ao_scheme_const.h + +clean: +	+cd make-const && make clean +	rm -f ao_scheme_const.h ao_scheme_builtin.h + +ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const +	make-const/ao_scheme_make_const -o $@ ao_scheme_const.lisp + +ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt +	nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ + +make-const/ao_scheme_make_const: FRC +	+cd make-const && make ao_scheme_make_const + +FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc new file mode 100644 index 00000000..d23ee3d7 --- /dev/null +++ b/src/scheme/Makefile-inc @@ -0,0 +1,24 @@ +SCHEME_SRCS=\ +	ao_scheme_mem.c \ +	ao_scheme_cons.c \ +	ao_scheme_string.c \ +	ao_scheme_atom.c \ +	ao_scheme_int.c \ +	ao_scheme_poly.c \ +	ao_scheme_bool.c \ +	ao_scheme_float.c \ +	ao_scheme_builtin.c \ +	ao_scheme_read.c \ +	ao_scheme_frame.c \ +	ao_scheme_lambda.c \ +	ao_scheme_eval.c \ +	ao_scheme_rep.c \ +	ao_scheme_save.c \ +	ao_scheme_stack.c \ +	ao_scheme_error.c  + +SCHEME_HDRS=\ +	ao_scheme.h \ +	ao_scheme_os.h \ +	ao_scheme_read.h \ +	ao_scheme_builtin.h diff --git a/src/lisp/Makefile-lisp b/src/scheme/Makefile-scheme index 998c7673..2427cffa 100644 --- a/src/lisp/Makefile-lisp +++ b/src/scheme/Makefile-scheme @@ -1,4 +1,4 @@  include ../lisp/Makefile-inc -ao_lisp_const.h: $(LISP_SRCS) $(LISP_HDRS) +ao_scheme_const.h: $(LISP_SRCS) $(LISP_HDRS)  	+cd ../lisp && make $@ diff --git a/src/lisp/README b/src/scheme/README index c1e84475..98932b44 100644 --- a/src/lisp/README +++ b/src/scheme/README @@ -5,7 +5,6 @@ This follows the R7RS with the following known exceptions:  * 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 syntax-rules; (have classic macros)  * No record types  * No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h new file mode 100644 index 00000000..4589f8a5 --- /dev/null +++ b/src/scheme/ao_scheme.h @@ -0,0 +1,928 @@ +/* + * 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_SCHEME_H_ +#define _AO_SCHEME_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_scheme_os.h> +#ifndef __BYTE_ORDER +#include <endian.h> +#endif + +typedef uint16_t	ao_poly; +typedef int16_t		ao_signed_poly; + +#ifdef AO_SCHEME_SAVE + +struct ao_scheme_os_save { +	ao_poly		atoms; +	ao_poly		globals; +	uint16_t	const_checksum; +	uint16_t	const_checksum_inv; +}; + +#define AO_SCHEME_POOL_EXTRA	(sizeof(struct ao_scheme_os_save)) +#define AO_SCHEME_POOL	((int) (AO_SCHEME_POOL_TOTAL - AO_SCHEME_POOL_EXTRA)) + +int +ao_scheme_os_save(void); + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); + +int +ao_scheme_os_restore(void); + +#endif + +#ifdef AO_SCHEME_MAKE_CONST +#define AO_SCHEME_POOL_CONST	16384 +extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern(n)) +#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) + +#define _ao_scheme_bool_true	_bool(1) +#define _ao_scheme_bool_false	_bool(0) + +#define _ao_scheme_atom_eof	_atom("eof") +#define _ao_scheme_atom_else	_atom("else") + +#define AO_SCHEME_BUILTIN_ATOMS +#include "ao_scheme_builtin.h" + +#else +#include "ao_scheme_const.h" +#ifndef AO_SCHEME_POOL +#define AO_SCHEME_POOL	3072 +#endif +extern uint8_t		ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); +#endif + +/* Primitive types */ +#define AO_SCHEME_CONS		0 +#define AO_SCHEME_INT		1 +#define AO_SCHEME_STRING	2 +#define AO_SCHEME_OTHER		3 + +#define AO_SCHEME_TYPE_MASK	0x0003 +#define AO_SCHEME_TYPE_SHIFT	2 +#define AO_SCHEME_REF_MASK	0x7ffc +#define AO_SCHEME_CONST		0x8000 + +/* These have a type value at the start of the struct */ +#define AO_SCHEME_ATOM		4 +#define AO_SCHEME_BUILTIN	5 +#define AO_SCHEME_FRAME		6 +#define AO_SCHEME_FRAME_VALS	7 +#define AO_SCHEME_LAMBDA	8 +#define AO_SCHEME_STACK		9 +#define AO_SCHEME_BOOL		10 +#define AO_SCHEME_BIGINT	11 +#define AO_SCHEME_FLOAT		12 +#define AO_SCHEME_NUM_TYPE	13 + +/* Leave two bits for types to use as they please */ +#define AO_SCHEME_OTHER_TYPE_MASK	0x3f + +#define AO_SCHEME_NIL	0 + +extern uint16_t		ao_scheme_top; + +#define AO_SCHEME_OOM			0x01 +#define AO_SCHEME_DIVIDE_BY_ZERO	0x02 +#define AO_SCHEME_INVALID		0x04 +#define AO_SCHEME_UNDEFINED		0x08 +#define AO_SCHEME_REDEFINED		0x10 +#define AO_SCHEME_EOF			0x20 +#define AO_SCHEME_EXIT			0x40 + +extern uint8_t		ao_scheme_exception; + +static inline int +ao_scheme_is_const(ao_poly poly) { +	return poly & AO_SCHEME_CONST; +} + +#define AO_SCHEME_IS_CONST(a)	(ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) +#define AO_SCHEME_IS_POOL(a)	(ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +#define AO_SCHEME_IS_INT(p)	(ao_scheme_poly_base_type(p) == AO_SCHEME_INT) + +void * +ao_scheme_ref(ao_poly poly); + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type); + +struct ao_scheme_type { +	int	(*size)(void *addr); +	void	(*mark)(void *addr); +	void	(*move)(void *addr); +	char	name[]; +}; + +struct ao_scheme_cons { +	ao_poly		car; +	ao_poly		cdr; +}; + +struct ao_scheme_atom { +	uint8_t		type; +	uint8_t		pad[1]; +	ao_poly		next; +	char		name[]; +}; + +struct ao_scheme_val { +	ao_poly		atom; +	ao_poly		val; +}; + +struct ao_scheme_frame_vals { +	uint8_t			type; +	uint8_t			size; +	struct ao_scheme_val	vals[]; +}; + +struct ao_scheme_frame { +	uint8_t			type; +	uint8_t			num; +	ao_poly			prev; +	ao_poly			vals; +}; + +struct ao_scheme_bool { +	uint8_t			type; +	uint8_t			value; +	uint16_t		pad; +}; + +struct ao_scheme_bigint { +	uint32_t		value; +}; + +struct ao_scheme_float { +	uint8_t			type; +	uint8_t			pad1; +	uint16_t		pad2; +	float			value; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { +	return AO_SCHEME_BIGINT | (i << 8); +} +static inline int32_t +ao_scheme_bigint_int(uint32_t bi) { +	return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { +	return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); +} +static inlint int32_t +ao_scheme_bigint_int(uint32_t bi) { +	return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_SCHEME_MIN_INT	(-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) +#define AO_SCHEME_MAX_INT	((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) +#define AO_SCHEME_MIN_BIGINT	(-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT	((1 << 24) - 1) + +#define AO_SCHEME_NOT_INTEGER	0x7fffffff + +/* Set on type when the frame escapes the lambda */ +#define AO_SCHEME_FRAME_MARK	0x80 +#define AO_SCHEME_FRAME_PRINT	0x40 + +static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { +	return f->type & AO_SCHEME_FRAME_MARK; +} + +static inline struct ao_scheme_frame * +ao_scheme_poly_frame(ao_poly poly) { +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_poly(struct ao_scheme_frame *frame) { +	return ao_scheme_poly(frame, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_frame_vals * +ao_scheme_poly_frame_vals(ao_poly poly) { +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_vals_poly(struct ao_scheme_frame_vals *vals) { +	return ao_scheme_poly(vals, AO_SCHEME_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_scheme_stack { +	uint8_t			type;		/* AO_SCHEME_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_SCHEME_STACK_MARK	0x80	/* set on type when a reference has been taken */ +#define AO_SCHEME_STACK_PRINT	0x40	/* stack is being printed */ + +static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { +	return s->type & AO_SCHEME_STACK_MARK; +} + +static inline void ao_scheme_stack_mark(struct ao_scheme_stack *s) { +	s->type |= AO_SCHEME_STACK_MARK; +} + +static inline struct ao_scheme_stack * +ao_scheme_poly_stack(ao_poly p) +{ +	return ao_scheme_ref(p); +} + +static inline ao_poly +ao_scheme_stack_poly(struct ao_scheme_stack *stack) +{ +	return ao_scheme_poly(stack, AO_SCHEME_OTHER); +} + +extern ao_poly			ao_scheme_v; + +#define AO_SCHEME_FUNC_LAMBDA		0 +#define AO_SCHEME_FUNC_NLAMBDA		1 +#define AO_SCHEME_FUNC_MACRO		2 + +#define AO_SCHEME_FUNC_FREE_ARGS	0x80 +#define AO_SCHEME_FUNC_MASK		0x7f + +#define AO_SCHEME_FUNC_F_LAMBDA		(AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_LAMBDA) +#define AO_SCHEME_FUNC_F_NLAMBDA	(AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_NLAMBDA) +#define AO_SCHEME_FUNC_F_MACRO		(AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_MACRO) + +struct ao_scheme_builtin { +	uint8_t		type; +	uint8_t		args; +	uint16_t	func; +}; + +#define AO_SCHEME_BUILTIN_ID +#include "ao_scheme_builtin.h" + +typedef ao_poly (*ao_scheme_func_t)(struct ao_scheme_cons *cons); + +extern const ao_scheme_func_t	ao_scheme_builtins[]; + +static inline ao_scheme_func_t +ao_scheme_func(struct ao_scheme_builtin *b) +{ +	return ao_scheme_builtins[b->func]; +} + +struct ao_scheme_lambda { +	uint8_t		type; +	uint8_t		args; +	ao_poly		code; +	ao_poly		frame; +}; + +static inline struct ao_scheme_lambda * +ao_scheme_poly_lambda(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_lambda_poly(struct ao_scheme_lambda *lambda) +{ +	return ao_scheme_poly(lambda, AO_SCHEME_OTHER); +} + +static inline void * +ao_scheme_poly_other(ao_poly poly) { +	return ao_scheme_ref(poly); +} + +static inline uint8_t +ao_scheme_other_type(void *other) { +#if DBG_MEM +	if ((*((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK) >= AO_SCHEME_NUM_TYPE) +		ao_scheme_abort(); +#endif +	return *((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK; +} + +static inline ao_poly +ao_scheme_other_poly(const void *other) +{ +	return ao_scheme_poly(other, AO_SCHEME_OTHER); +} + +static inline int +ao_scheme_size_round(int size) +{ +	return (size + 3) & ~3; +} + +static inline int +ao_scheme_size(const struct ao_scheme_type *type, void *addr) +{ +	return ao_scheme_size_round(type->size(addr)); +} + +#define AO_SCHEME_OTHER_POLY(other) ((ao_poly)(other) + AO_SCHEME_OTHER) + +static inline int ao_scheme_poly_base_type(ao_poly poly) { +	return poly & AO_SCHEME_TYPE_MASK; +} + +static inline int ao_scheme_poly_type(ao_poly poly) { +	int	type = poly & AO_SCHEME_TYPE_MASK; +	if (type == AO_SCHEME_OTHER) +		return ao_scheme_other_type(ao_scheme_poly_other(poly)); +	return type; +} + +static inline int +ao_scheme_is_cons(ao_poly poly) { +	return (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline int +ao_scheme_is_pair(ao_poly poly) { +	return poly != AO_SCHEME_NIL && (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline struct ao_scheme_cons * +ao_scheme_poly_cons(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_cons_poly(struct ao_scheme_cons *cons) +{ +	return ao_scheme_poly(cons, AO_SCHEME_CONS); +} + +static inline int32_t +ao_scheme_poly_int(ao_poly poly) +{ +	return (int32_t) ((ao_signed_poly) poly >> AO_SCHEME_TYPE_SHIFT); +} + +static inline ao_poly +ao_scheme_int_poly(int32_t i) +{ +	return ((ao_poly) i << 2) | AO_SCHEME_INT; +} + +static inline struct ao_scheme_bigint * +ao_scheme_poly_bigint(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) +{ +	return ao_scheme_poly(bi, AO_SCHEME_OTHER); +} + +static inline char * +ao_scheme_poly_string(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_string_poly(char *s) +{ +	return ao_scheme_poly(s, AO_SCHEME_STRING); +} + +static inline struct ao_scheme_atom * +ao_scheme_poly_atom(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_atom_poly(struct ao_scheme_atom *a) +{ +	return ao_scheme_poly(a, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_builtin * +ao_scheme_poly_builtin(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_builtin_poly(struct ao_scheme_builtin *b) +{ +	return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline ao_poly +ao_scheme_bool_poly(struct ao_scheme_bool *b) +{ +	return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_bool * +ao_scheme_poly_bool(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_float_poly(struct ao_scheme_float *f) +{ +	return ao_scheme_poly(f, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_float * +ao_scheme_poly_float(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* memory functions */ + +extern int ao_scheme_collects[2]; +extern int ao_scheme_freed[2]; +extern int ao_scheme_loops[2]; + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); + +void * +ao_scheme_move_map(void *addr); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); + +void * +ao_scheme_alloc(int size); + +#define AO_SCHEME_COLLECT_FULL		1 +#define AO_SCHEME_COLLECT_INCREMENTAL	0 + +int +ao_scheme_collect(uint8_t style); + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons); +#endif + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id); + +void +ao_scheme_poly_stash(int id, ao_poly poly); + +ao_poly +ao_scheme_poly_fetch(int id); + +void +ao_scheme_string_stash(int id, char *string); + +char * +ao_scheme_string_fetch(int id); + +static inline void +ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { +	ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +} + +static inline struct ao_scheme_stack * +ao_scheme_stack_fetch(int id) { +	return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id); + +/* bool */ + +extern const struct ao_scheme_type ao_scheme_bool_type; + +void +ao_scheme_bool_write(ao_poly v); + +#ifdef AO_SCHEME_MAKE_CONST +struct ao_scheme_bool	*ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value); +#endif + +/* cons */ +extern const struct ao_scheme_type ao_scheme_cons_type; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr); + +/* Return a cons or NULL for a proper list, else error */ +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr); + +extern struct ao_scheme_cons *ao_scheme_cons_free_list; + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons); + +void +ao_scheme_cons_write(ao_poly); + +void +ao_scheme_cons_display(ao_poly); + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons); + +/* string */ +extern const struct ao_scheme_type ao_scheme_string_type; + +char * +ao_scheme_string_copy(char *a); + +char * +ao_scheme_string_cat(char *a, char *b); + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme_string_unpack(char *a); + +void +ao_scheme_string_write(ao_poly s); + +void +ao_scheme_string_display(ao_poly s); + +/* atom */ +extern const struct ao_scheme_type ao_scheme_atom_type; + +extern struct ao_scheme_atom	*ao_scheme_atoms; +extern struct ao_scheme_frame	*ao_scheme_frame_global; +extern struct ao_scheme_frame	*ao_scheme_frame_current; + +void +ao_scheme_atom_write(ao_poly a); + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name); + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); + +ao_poly +ao_scheme_atom_get(ao_poly atom); + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val); + +/* int */ +void +ao_scheme_int_write(ao_poly i); + +int32_t +ao_scheme_poly_integer(ao_poly p); + +ao_poly +ao_scheme_integer_poly(int32_t i); + +static inline int +ao_scheme_integer_typep(uint8_t t) +{ +	return (t == AO_SCHEME_INT) || (t == AO_SCHEME_BIGINT); +} + +void +ao_scheme_bigint_write(ao_poly i); + +extern const struct ao_scheme_type	ao_scheme_bigint_type; +/* prim */ +void +ao_scheme_poly_write(ao_poly p); + +void +ao_scheme_poly_display(ao_poly p); + +int +ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); + +/* returns 1 if the object has already been moved */ +int +ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); + +/* eval */ + +void +ao_scheme_eval_clear_globals(void); + +int +ao_scheme_eval_restart(void); + +ao_poly +ao_scheme_eval(ao_poly p); + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *cons); + +/* float */ +extern const struct ao_scheme_type ao_scheme_float_type; + +void +ao_scheme_float_write(ao_poly p); + +ao_poly +ao_scheme_float_get(float value); + +static inline uint8_t +ao_scheme_number_typep(uint8_t t) +{ +	return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* builtin */ +void +ao_scheme_builtin_write(ao_poly b); + +extern const struct ao_scheme_type ao_scheme_builtin_type; + +/* Check argument count */ +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc); + +char * +ao_scheme_args_name(uint8_t args); + +/* read */ +extern struct ao_scheme_cons	*ao_scheme_read_cons; +extern struct ao_scheme_cons	*ao_scheme_read_cons_tail; +extern struct ao_scheme_cons	*ao_scheme_read_stack; + +ao_poly +ao_scheme_read(void); + +/* rep */ +ao_poly +ao_scheme_read_eval_print(void); + +/* frame */ +extern const struct ao_scheme_type ao_scheme_frame_type; +extern const struct ao_scheme_type ao_scheme_frame_vals_type; + +#define AO_SCHEME_FRAME_FREE	6 + +extern struct ao_scheme_frame	*ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame); + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom); + +struct ao_scheme_frame * +ao_scheme_frame_new(int num); + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame); + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); + +void +ao_scheme_frame_write(ao_poly p); + +void +ao_scheme_frame_init(void); + +/* lambda */ +extern const struct ao_scheme_type ao_scheme_lambda_type; + +extern const char * const ao_scheme_state_names[]; + +struct ao_scheme_lambda * +ao_scheme_lambda_new(ao_poly cons); + +void +ao_scheme_lambda_write(ao_poly lambda); + +ao_poly +ao_scheme_lambda_eval(void); + +/* stack */ + +extern const struct ao_scheme_type ao_scheme_stack_type; +extern struct ao_scheme_stack	*ao_scheme_stack; +extern struct ao_scheme_stack	*ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack); + +int +ao_scheme_stack_push(void); + +void +ao_scheme_stack_pop(void); + +void +ao_scheme_stack_clear(void); + +void +ao_scheme_stack_write(ao_poly stack); + +ao_poly +ao_scheme_stack_eval(void); + +/* error */ + +void +ao_scheme_vprintf(char *format, va_list args); + +void +ao_scheme_printf(char *format, ...); + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last); + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame); + +ao_poly +ao_scheme_error(int error, char *format, ...); + +/* builtins */ + +#define AO_SCHEME_BUILTIN_DECLS +#include "ao_scheme_builtin.h" + +/* debugging macros */ + +#if DBG_EVAL || DBG_READ || DBG_MEM +#define DBG_CODE	1 +int ao_scheme_stack_depth; +#define DBG_DO(a)	a +#define DBG_INDENT()	do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf("  "); } while(0) +#define DBG_IN()	(++ao_scheme_stack_depth) +#define DBG_OUT()	(--ao_scheme_stack_depth) +#define DBG_RESET()	(ao_scheme_stack_depth = 0) +#define DBG(...) 	ao_scheme_printf(__VA_ARGS__) +#define DBGI(...)	do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBG_CONS(a)	ao_scheme_cons_write(ao_scheme_cons_poly(a)) +#define DBG_POLY(a)	ao_scheme_poly_write(a) +#define OFFSET(a)	((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) +#define DBG_STACK()	ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)) +static inline void +ao_scheme_frames_dump(void) +{ +	struct ao_scheme_stack *s; +	DBGI(".. current frame: "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	for (s = ao_scheme_stack; s; s = ao_scheme_poly_stack(s->prev)) { +		DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); +	} +} +#define DBG_FRAMES()	ao_scheme_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_scheme_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_SCHEME_H_ */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c new file mode 100644 index 00000000..cb32b7fe --- /dev/null +++ b/src/scheme/ao_scheme_atom.c @@ -0,0 +1,167 @@ +/* + * 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_scheme.h" + +static int name_size(char *name) +{ +	return sizeof(struct ao_scheme_atom) + strlen(name) + 1; +} + +static int atom_size(void *addr) +{ +	struct ao_scheme_atom	*atom = addr; +	if (!atom) +		return 0; +	return name_size(atom->name); +} + +static void atom_mark(void *addr) +{ +	struct ao_scheme_atom	*atom = addr; + +	for (;;) { +		atom = ao_scheme_poly_atom(atom->next); +		if (!atom) +			break; +		if (ao_scheme_mark_memory(&ao_scheme_atom_type, atom)) +			break; +	} +} + +static void atom_move(void *addr) +{ +	struct ao_scheme_atom	*atom = addr; +	int			ret; + +	for (;;) { +		struct ao_scheme_atom *next = ao_scheme_poly_atom(atom->next); + +		if (!next) +			break; +		ret = ao_scheme_move_memory(&ao_scheme_atom_type, (void **) &next); +		if (next != ao_scheme_poly_atom(atom->next)) +			atom->next = ao_scheme_atom_poly(next); +		if (ret) +			break; +		atom = next; +	} +} + +const struct ao_scheme_type ao_scheme_atom_type = { +	.mark = atom_mark, +	.size = atom_size, +	.move = atom_move, +	.name = "atom" +}; + +struct ao_scheme_atom	*ao_scheme_atoms; + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name) +{ +	struct ao_scheme_atom	*atom; + +	for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { +		if (!strcmp(atom->name, name)) +			return atom; +	} +#ifdef ao_builtin_atoms +	for (atom = ao_scheme_poly_atom(ao_builtin_atoms); atom; atom = ao_scheme_poly_atom(atom->next)) { +		if (!strcmp(atom->name, name)) +			return atom; +	} +#endif +	ao_scheme_string_stash(0, name); +	atom = ao_scheme_alloc(name_size(name)); +	name = ao_scheme_string_fetch(0); +	if (atom) { +		atom->type = AO_SCHEME_ATOM; +		atom->next = ao_scheme_atom_poly(ao_scheme_atoms); +		ao_scheme_atoms = atom; +		strcpy(atom->name, name); +	} +	return atom; +} + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref) +{ +	ao_poly	*ref; +	struct ao_scheme_frame *frame; + +	for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) { +		ref = ao_scheme_frame_ref(frame, atom); +		if (ref) { +			if (frame_ref) +				*frame_ref = frame; +			return ref; +		} +	} +	ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom); +	if (ref) +		if (frame_ref) +			*frame_ref = ao_scheme_frame_global; +	return ref; +} + +ao_poly +ao_scheme_atom_get(ao_poly atom) +{ +	ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +#ifdef ao_builtin_frame +	if (!ref) +		ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom); +#endif +	if (ref) +		return *ref; +	return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +} + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val) +{ +	ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +	if (!ref) +		return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +	*ref = val; +	return val; +} + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val) +{ +	struct ao_scheme_frame	*frame; +	ao_poly *ref = ao_scheme_atom_ref(atom, &frame); + +	if (ref) { +		if (frame == ao_scheme_frame_current) +			return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name); +		*ref = val; +		return val; +	} +	return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val); +} + +void +ao_scheme_atom_write(ao_poly a) +{ +	struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); +	printf("%s", atom->name); +} diff --git a/src/lisp/ao_lisp_bool.c b/src/scheme/ao_scheme_bool.c index 391a7f78..c1e880ca 100644 --- a/src/lisp/ao_lisp_bool.c +++ b/src/scheme/ao_scheme_bool.c @@ -12,7 +12,7 @@   * General Public License for more details.   */ -#include "ao_lisp.h" +#include "ao_scheme.h"  static void bool_mark(void *addr)  { @@ -22,7 +22,7 @@ static void bool_mark(void *addr)  static int bool_size(void *addr)  {  	(void) addr; -	return sizeof (struct ao_lisp_bool); +	return sizeof (struct ao_scheme_bool);  }  static void bool_move(void *addr) @@ -30,7 +30,7 @@ static void bool_move(void *addr)  	(void) addr;  } -const struct ao_lisp_type ao_lisp_bool_type = { +const struct ao_scheme_type ao_scheme_bool_type = {  	.mark = bool_mark,  	.size = bool_size,  	.move = bool_move, @@ -38,9 +38,9 @@ const struct ao_lisp_type ao_lisp_bool_type = {  };  void -ao_lisp_bool_write(ao_poly v) +ao_scheme_bool_write(ao_poly v)  { -	struct ao_lisp_bool	*b = ao_lisp_poly_bool(v); +	struct ao_scheme_bool	*b = ao_scheme_poly_bool(v);  	if (b->value)  		printf("#t"); @@ -48,23 +48,23 @@ ao_lisp_bool_write(ao_poly v)  		printf("#f");  } -#ifdef AO_LISP_MAKE_CONST +#ifdef AO_SCHEME_MAKE_CONST -struct ao_lisp_bool	*ao_lisp_true, *ao_lisp_false; +struct ao_scheme_bool	*ao_scheme_true, *ao_scheme_false; -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value) +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value)  { -	struct ao_lisp_bool	**b; +	struct ao_scheme_bool	**b;  	if (value) -		b = &ao_lisp_true; +		b = &ao_scheme_true;  	else -		b = &ao_lisp_false; +		b = &ao_scheme_false;  	if (!*b) { -		*b = ao_lisp_alloc(sizeof (struct ao_lisp_bool)); -		(*b)->type = AO_LISP_BOOL; +		*b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); +		(*b)->type = AO_SCHEME_BOOL;  		(*b)->value = value;  	}  	return *b; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c new file mode 100644 index 00000000..49f218f6 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,868 @@ +/* + * 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_scheme.h" +#include <limits.h> +#include <math.h> + +static int +builtin_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_builtin); +} + +static void +builtin_mark(void *addr) +{ +	(void) addr; +} + +static void +builtin_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_builtin_type = { +	.size = builtin_size, +	.mark = builtin_mark, +	.move = builtin_move +}; + +#ifdef AO_SCHEME_MAKE_CONST + +#define AO_SCHEME_BUILTIN_CASENAME +#include "ao_scheme_builtin.h" + +char *ao_scheme_args_name(uint8_t args) { +	args &= AO_SCHEME_FUNC_MASK; +	switch (args) { +	case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; +	case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; +	case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; +	default: return "???"; +	} +} +#else + +#define AO_SCHEME_BUILTIN_ARRAYNAME +#include "ao_scheme_builtin.h" + +static char * +ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { +	if (b < _builtin_last) +		return ao_scheme_poly_atom(builtin_names[b])->name; +	return "???"; +} + +static const ao_poly ao_scheme_args_atoms[] = { +	[AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, +	[AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, +	[AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, +}; + +char * +ao_scheme_args_name(uint8_t args) +{ +	args &= AO_SCHEME_FUNC_MASK; +	if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) +		return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; +	return "(unknown)"; +} +#endif + +void +ao_scheme_builtin_write(ao_poly b) +{ +	struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); +	printf("%s", ao_scheme_builtin_name(builtin->func)); +} + +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) +{ +	int	argc = 0; + +	while (cons && argc <= max) { +		argc++; +		cons = ao_scheme_cons_cdr(cons); +	} +	if (argc < min || argc > max) +		return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +{ +	if (!cons) +		return AO_SCHEME_NIL; +	while (argc--) { +		if (!cons) +			return AO_SCHEME_NIL; +		cons = ao_scheme_cons_cdr(cons); +	} +	return cons->car; +} + +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok) +{ +	ao_poly car = ao_scheme_arg(cons, argc); + +	if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) +		return ao_scheme_error(AO_SCHEME_INVALID, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_car(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(cons->car)->car; +} + +ao_poly +ao_scheme_do_cdr(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_scheme_do_cons(struct ao_scheme_cons *cons) +{ +	ao_poly	car, cdr; +	if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2)) +		return AO_SCHEME_NIL; +	car = ao_scheme_arg(cons, 0); +	cdr = ao_scheme_arg(cons, 1); +	return ao_scheme__cons(car, cdr); +} + +ao_poly +ao_scheme_do_last(struct ao_scheme_cons *cons) +{ +	struct ao_scheme_cons	*list; +	if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0)); +	     list; +	     list = ao_scheme_cons_cdr(list)) +	{ +		if (!list->cdr) +			return list->car; +	} +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_length(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_quote(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1)) +		return AO_SCHEME_NIL; +	return ao_scheme_arg(cons, 0); +} + +ao_poly +ao_scheme_do_set(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0)) +		return AO_SCHEME_NIL; + +	return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_def(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0)) +		return AO_SCHEME_NIL; + +	return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_setq(struct ao_scheme_cons *cons) +{ +	ao_poly	name; +	if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2)) +		return AO_SCHEME_NIL; +	name = cons->car; +	if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM) +		return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name); +	if (!ao_scheme_atom_ref(name, NULL)) +		return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name); +	return ao_scheme__cons(_ao_scheme_atom_set, +			     ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote, +							 ao_scheme__cons(name, AO_SCHEME_NIL)), +					   cons->cdr)); +} + +ao_poly +ao_scheme_do_cond(struct ao_scheme_cons *cons) +{ +	ao_scheme_set_cond(cons); +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_begin(struct ao_scheme_cons *cons) +{ +	ao_scheme_stack->state = eval_begin; +	ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_while(struct ao_scheme_cons *cons) +{ +	ao_scheme_stack->state = eval_while; +	ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_write(struct ao_scheme_cons *cons) +{ +	ao_poly	val = AO_SCHEME_NIL; +	while (cons) { +		val = cons->car; +		ao_scheme_poly_write(val); +		cons = ao_scheme_cons_cdr(cons); +		if (cons) +			printf(" "); +	} +	printf("\n"); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_display(struct ao_scheme_cons *cons) +{ +	ao_poly	val = AO_SCHEME_NIL; +	while (cons) { +		val = cons->car; +		ao_scheme_poly_display(val); +		cons = ao_scheme_cons_cdr(cons); +	} +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) +{ +	struct ao_scheme_cons *cons = cons; +	ao_poly	ret = AO_SCHEME_NIL; + +	for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { +		ao_poly		car = cons->car; +		uint8_t		rt = ao_scheme_poly_type(ret); +		uint8_t		ct = ao_scheme_poly_type(car); + +		if (cons == orig_cons) { +			ret = car; +			if (cons->cdr == AO_SCHEME_NIL) { +				switch (op) { +				case builtin_minus: +					if (ao_scheme_integer_typep(ct)) +						ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); +					else if (ct == AO_SCHEME_FLOAT) +						ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); +					break; +				case builtin_divide: +					if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) +						; +					else if (ao_scheme_number_typep(ct)) { +						float	v = ao_scheme_poly_number(ret); +						ret = ao_scheme_float_get(1/v); +					} +					break; +				default: +					break; +				} +			} +		} else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { +			int32_t	r = ao_scheme_poly_integer(ret); +			int32_t	c = ao_scheme_poly_integer(car); +			int64_t t; + +			switch(op) { +			case builtin_plus: +				r += c; +			check_overflow: +				if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_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_SCHEME_MIN_BIGINT || AO_SCHEME_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_scheme_error(AO_SCHEME_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_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); +				r %= c; +				break; +			case builtin_modulo: +				if (c == 0) +					return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); +				r %= c; +				if ((r < 0) != (c < 0)) +					r += c; +				break; +			default: +				break; +			} +			ret = ao_scheme_integer_poly(r); +		} else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { +			float r, c; +		inexact: +			r = ao_scheme_poly_number(ret); +			c = ao_scheme_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_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); +			default: +				break; +			} +			ret = ao_scheme_float_get(r); +		} + +		else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) +			ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), +								     ao_scheme_poly_string(car))); +		else +			return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); +	} +	return ret; +} + +ao_poly +ao_scheme_do_plus(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_plus); +} + +ao_poly +ao_scheme_do_minus(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_minus); +} + +ao_poly +ao_scheme_do_times(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_times); +} + +ao_poly +ao_scheme_do_divide(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_divide); +} + +ao_poly +ao_scheme_do_quotient(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_quotient); +} + +ao_poly +ao_scheme_do_modulo(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_modulo); +} + +ao_poly +ao_scheme_do_remainder(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_remainder); +} + +ao_poly +ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) +{ +	ao_poly	left; + +	if (!cons) +		return _ao_scheme_bool_true; + +	left = cons->car; +	for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { +		ao_poly	right = cons->car; + +		if (op == builtin_equal) { +			if (left != right) +				return _ao_scheme_bool_false; +		} else { +			uint8_t	lt = ao_scheme_poly_type(left); +			uint8_t	rt = ao_scheme_poly_type(right); +			if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { +				int32_t l = ao_scheme_poly_integer(left); +				int32_t r = ao_scheme_poly_integer(right); + +				switch (op) { +				case builtin_less: +					if (!(l < r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater: +					if (!(l > r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_less_equal: +					if (!(l <= r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater_equal: +					if (!(l >= r)) +						return _ao_scheme_bool_false; +					break; +				default: +					break; +				} +			} else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { +				int c = strcmp(ao_scheme_poly_string(left), +					       ao_scheme_poly_string(right)); +				switch (op) { +				case builtin_less: +					if (!(c < 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater: +					if (!(c > 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_less_equal: +					if (!(c <= 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater_equal: +					if (!(c >= 0)) +						return _ao_scheme_bool_false; +					break; +				default: +					break; +				} +			} +		} +		left = right; +	} +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_equal(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_equal); +} + +ao_poly +ao_scheme_do_less(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_less); +} + +ao_poly +ao_scheme_do_greater(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_greater); +} + +ao_poly +ao_scheme_do_less_equal(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_less_equal); +} + +ao_poly +ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_flush_output(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) +		return AO_SCHEME_NIL; +	ao_scheme_os_flush(); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_led(struct ao_scheme_cons *cons) +{ +	ao_poly led; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) +		return AO_SCHEME_NIL; +	led = ao_scheme_arg(cons, 0); +	ao_scheme_os_led(ao_scheme_poly_int(led)); +	return led; +} + +ao_poly +ao_scheme_do_delay(struct ao_scheme_cons *cons) +{ +	ao_poly delay; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) +		return AO_SCHEME_NIL; +	delay = ao_scheme_arg(cons, 0); +	ao_scheme_os_delay(ao_scheme_poly_int(delay)); +	return delay; +} + +ao_poly +ao_scheme_do_eval(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) +		return AO_SCHEME_NIL; +	ao_scheme_stack->state = eval_sexpr; +	return cons->car; +} + +ao_poly +ao_scheme_do_apply(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX)) +		return AO_SCHEME_NIL; +	ao_scheme_stack->state = eval_apply; +	return ao_scheme_cons_poly(cons); +} + +ao_poly +ao_scheme_do_read(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_read(); +} + +ao_poly +ao_scheme_do_collect(struct ao_scheme_cons *cons) +{ +	int	free; +	(void) cons; +	free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); +	return ao_scheme_int_poly(free); +} + +ao_poly +ao_scheme_do_nullp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) +		return _ao_scheme_bool_true; +	else +		return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_not(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) +		return _ao_scheme_bool_true; +	else +		return _ao_scheme_bool_false; +} + +static ao_poly +ao_scheme_do_typep(int type, struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type) +		return _ao_scheme_bool_true; +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_pairp(struct ao_scheme_cons *cons) +{ +	ao_poly	v; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	v = ao_scheme_arg(cons, 0); +	if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) +		return _ao_scheme_bool_true; +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_integerp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +		return _ao_scheme_bool_true; +	default: +		return _ao_scheme_bool_false; +	} +} + +ao_poly +ao_scheme_do_numberp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +	case AO_SCHEME_FLOAT: +		return _ao_scheme_bool_true; +	default: +		return _ao_scheme_bool_false; +	} +} + +ao_poly +ao_scheme_do_stringp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_STRING, cons); +} + +ao_poly +ao_scheme_do_symbolp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_ATOM, cons); +} + +ao_poly +ao_scheme_do_booleanp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_BOOL, cons); +} + +ao_poly +ao_scheme_do_procedurep(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { +	case AO_SCHEME_BUILTIN: +	case AO_SCHEME_LAMBDA: +		return _ao_scheme_bool_true; +	default: +	return _ao_scheme_bool_false; +	} +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_scheme_do_listp(struct ao_scheme_cons *cons) +{ +	ao_poly	v; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	v = ao_scheme_arg(cons, 0); +	for (;;) { +		if (v == AO_SCHEME_NIL) +			return _ao_scheme_bool_true; +		if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) +			return _ao_scheme_bool_false; +		v = ao_scheme_poly_cons(v)->cdr; +	} +} + +ao_poly +ao_scheme_do_set_car(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); +} + +ao_poly +ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; + +	return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_read_char(struct ao_scheme_cons *cons) +{ +	int	c; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	c = getchar(); +	return ao_scheme_int_poly(c); +} + +ao_poly +ao_scheme_do_write_char(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) +		return AO_SCHEME_NIL; +	putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_exit(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	ao_scheme_exception |= AO_SCHEME_EXIT; +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) +{ +	int	jiffy; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	jiffy = ao_scheme_os_jiffy(); +	return (ao_scheme_int_poly(jiffy)); +} + +ao_poly +ao_scheme_do_current_second(struct ao_scheme_cons *cons) +{ +	int	second; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; +	return (ao_scheme_int_poly(second)); +} + +ao_poly +ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); +} + +#define AO_SCHEME_BUILTIN_FUNCS +#include "ao_scheme_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/scheme/ao_scheme_builtin.txt index cb65e252..cb65e252 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..03dad956 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,201 @@ +/* + * 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_scheme.h" + +static void cons_mark(void *addr) +{ +	struct ao_scheme_cons	*cons = addr; + +	for (;;) { +		ao_poly cdr = cons->cdr; + +		ao_scheme_poly_mark(cons->car, 1); +		if (!cdr) +			break; +		if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { +			ao_scheme_poly_mark(cdr, 1); +			break; +		} +		cons = ao_scheme_poly_cons(cdr); +		if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) +			break; +	} +} + +static int cons_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_cons); +} + +static void cons_move(void *addr) +{ +	struct ao_scheme_cons	*cons = addr; + +	if (!cons) +		return; + +	for (;;) { +		ao_poly			cdr; +		struct ao_scheme_cons	*c; +		int	ret; + +		MDBG_MOVE("cons_move start %d (%d, %d)\n", +			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); +		(void) ao_scheme_poly_move(&cons->car, 1); +		cdr = cons->cdr; +		if (!cdr) +			break; +		if (ao_scheme_poly_base_type(cdr) != AO_SCHEME_CONS) { +			(void) ao_scheme_poly_move(&cons->cdr, 0); +			break; +		} +		c = ao_scheme_poly_cons(cdr); +		ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); +		if (c != ao_scheme_poly_cons(cons->cdr)) +			cons->cdr = ao_scheme_cons_poly(c); +		MDBG_MOVE("cons_move end %d (%d, %d)\n", +			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); +		if (ret) +			break; +		cons = c; +	} +} + +const struct ao_scheme_type ao_scheme_cons_type = { +	.mark = cons_mark, +	.size = cons_size, +	.move = cons_move, +	.name = "cons", +}; + +struct ao_scheme_cons *ao_scheme_cons_free_list; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr) +{ +	struct ao_scheme_cons	*cons; + +	if (ao_scheme_cons_free_list) { +		cons = ao_scheme_cons_free_list; +		ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); +	} else { +		ao_scheme_poly_stash(0, car); +		ao_scheme_poly_stash(1, cdr); +		cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); +		cdr = ao_scheme_poly_fetch(1); +		car = ao_scheme_poly_fetch(0); +		if (!cons) +			return NULL; +	} +	cons->car = car; +	cons->cdr = cdr; +	return cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons) +{ +	ao_poly	cdr = cons->cdr; +	if (cdr == AO_SCHEME_NIL) +		return NULL; +	if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { +		(void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); +		return NULL; +	} +	return ao_scheme_poly_cons(cdr); +} + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr) +{ +	return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); +} + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons) +{ +#if DBG_FREE_CONS +	ao_scheme_cons_check(cons); +#endif +	while (cons) { +		ao_poly cdr = cons->cdr; +		cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); +		ao_scheme_cons_free_list = cons; +		cons = ao_scheme_poly_cons(cdr); +	} +} + +void +ao_scheme_cons_write(ao_poly c) +{ +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(c); +	ao_poly			cdr; +	int			first = 1; + +	printf("("); +	while (cons) { +		if (!first) +			printf(" "); +		ao_scheme_poly_write(cons->car); +		cdr = cons->cdr; +		if (cdr == c) { +			printf(" ..."); +			break; +		} +		if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { +			cons = ao_scheme_poly_cons(cdr); +			first = 0; +		} else { +			printf(" . "); +			ao_scheme_poly_write(cdr); +			cons = NULL; +		} +	} +	printf(")"); +} + +void +ao_scheme_cons_display(ao_poly c) +{ +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(c); +	ao_poly			cdr; + +	while (cons) { +		ao_scheme_poly_display(cons->car); +		cdr = cons->cdr; +		if (cdr == c) { +			printf("..."); +			break; +		} +		if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) +			cons = ao_scheme_poly_cons(cdr); +		else { +			ao_scheme_poly_display(cdr); +			cons = NULL; +		} +	} +} + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons) +{ +	int	len = 0; +	while (cons) { +		len++; +		cons = ao_scheme_poly_cons(cons->cdr); +	} +	return len; +} diff --git a/src/lisp/ao_lisp_const.lisp b/src/scheme/ao_scheme_const.lisp index 422bdd63..422bdd63 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/scheme/ao_scheme_const.lisp diff --git a/src/lisp/ao_lisp_error.c b/src/scheme/ao_scheme_error.c index 7f909487..d580a2c0 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/scheme/ao_scheme_error.c @@ -12,23 +12,23 @@   * General Public License for more details.   */ -#include "ao_lisp.h" +#include "ao_scheme.h"  #include <stdarg.h>  void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) +ao_scheme_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 (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) {  		if (poly) {  			while (poly) { -				struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); +				struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly);  				if (!first)  					printf("\t\t         ");  				else  					first = 0; -				ao_lisp_poly_write(cons->car); +				ao_scheme_poly_write(cons->car);  				printf("\n");  				if (poly == last)  					break; @@ -38,7 +38,7 @@ ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last)  		} else  			printf(")\n");  	} else { -		ao_lisp_poly_write(poly); +		ao_scheme_poly_write(poly);  		printf("\n");  	}  } @@ -50,31 +50,31 @@ static void tabs(int indent)  }  void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_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) +		struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +		if (frame->type & AO_SCHEME_FRAME_PRINT)  			printf("recurse...");  		else { -			frame->type |= AO_LISP_FRAME_PRINT; +			frame->type |= AO_SCHEME_FRAME_PRINT;  			for (f = 0; f < frame->num; f++) {  				if (f != 0) {  					tabs(indent);  					printf("         ");  				} -				ao_lisp_poly_write(vals->vals[f].atom); +				ao_scheme_poly_write(vals->vals[f].atom);  				printf(" = "); -				ao_lisp_poly_write(vals->vals[f].val); +				ao_scheme_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; +				ao_scheme_error_frame(indent + 1, "prev:   ", ao_scheme_poly_frame(frame->prev)); +			frame->type &= ~AO_SCHEME_FRAME_PRINT;  		}  		tabs(indent);  		printf("        }\n"); @@ -83,7 +83,7 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame)  }  void -ao_lisp_vprintf(char *format, va_list args) +ao_scheme_vprintf(char *format, va_list args)  {  	char c; @@ -91,7 +91,7 @@ ao_lisp_vprintf(char *format, va_list args)  		if (c == '%') {  			switch (c = *format++) {  			case 'v': -				ao_lisp_poly_write((ao_poly) va_arg(args, unsigned int)); +				ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int));  				break;  			case 'p':  				printf("%p", va_arg(args, void *)); @@ -112,28 +112,28 @@ ao_lisp_vprintf(char *format, va_list args)  }  void -ao_lisp_printf(char *format, ...) +ao_scheme_printf(char *format, ...)  {  	va_list args;  	va_start(args, format); -	ao_lisp_vprintf(format, args); +	ao_scheme_vprintf(format, args);  	va_end(args);  }  ao_poly -ao_lisp_error(int error, char *format, ...) +ao_scheme_error(int error, char *format, ...)  {  	va_list	args; -	ao_lisp_exception |= error; +	ao_scheme_exception |= error;  	va_start(args, format); -	ao_lisp_vprintf(format, args); +	ao_scheme_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)); +	ao_scheme_printf("Value:  %v\n", ao_scheme_v); +	ao_scheme_printf("Frame:  %v\n", ao_scheme_frame_poly(ao_scheme_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; +	ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)); +	ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); +	return AO_SCHEME_NIL;  } diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c new file mode 100644 index 00000000..9b3cf63e --- /dev/null +++ b/src/scheme/ao_scheme_eval.c @@ -0,0 +1,578 @@ +/* + * 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_scheme.h" +#include <assert.h> + +struct ao_scheme_stack		*ao_scheme_stack; +ao_poly				ao_scheme_v; +uint8_t				ao_scheme_skip_cons_free; + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *c) +{ +	ao_scheme_stack->state = eval_cond; +	ao_scheme_stack->sexprs = ao_scheme_cons_poly(c); +	return AO_SCHEME_NIL; +} + +static int +func_type(ao_poly func) +{ +	if (func == AO_SCHEME_NIL) +		return ao_scheme_error(AO_SCHEME_INVALID, "func is nil"); +	switch (ao_scheme_poly_type(func)) { +	case AO_SCHEME_BUILTIN: +		return ao_scheme_poly_builtin(func)->args & AO_SCHEME_FUNC_MASK; +	case AO_SCHEME_LAMBDA: +		return ao_scheme_poly_lambda(func)->args; +	case AO_SCHEME_STACK: +		return AO_SCHEME_FUNC_LAMBDA; +	default: +		ao_scheme_error(AO_SCHEME_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_scheme_eval_sexpr(void) +{ +	DBGI("sexpr: %v\n", ao_scheme_v); +	switch (ao_scheme_poly_type(ao_scheme_v)) { +	case AO_SCHEME_CONS: +		if (ao_scheme_v == AO_SCHEME_NIL) { +			if (!ao_scheme_stack->values) { +				/* +				 * empty list evaluates to empty list +				 */ +				ao_scheme_v = AO_SCHEME_NIL; +				ao_scheme_stack->state = eval_val; +			} else { +				/* +				 * done with arguments, go execute it +				 */ +				ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; +				ao_scheme_stack->state = eval_exec; +			} +		} else { +			if (!ao_scheme_stack->values) +				ao_scheme_stack->list = ao_scheme_v; +			/* +			 * Evaluate another argument and then switch +			 * to 'formal' to add the value to the values +			 * list +			 */ +			ao_scheme_stack->sexprs = ao_scheme_v; +			ao_scheme_stack->state = eval_formal; +			if (!ao_scheme_stack_push()) +				return 0; +			/* +			 * push will reset the state to 'sexpr', which +			 * will evaluate the expression +			 */ +			ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; +		} +		break; +	case AO_SCHEME_ATOM: +		DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); +		/* fall through */ +	case AO_SCHEME_BOOL: +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +	case AO_SCHEME_FLOAT: +	case AO_SCHEME_STRING: +	case AO_SCHEME_BUILTIN: +	case AO_SCHEME_LAMBDA: +		ao_scheme_stack->state = eval_val; +		break; +	} +	DBGI(".. result "); DBG_POLY(ao_scheme_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_scheme_eval_val(void) +{ +	DBGI("val: "); DBG_POLY(ao_scheme_v); DBG("\n"); +	/* +	 * Value computed, pop the stack +	 * to figure out what to do with the value +	 */ +	ao_scheme_stack_pop(); +	DBGI("..state %d\n", ao_scheme_stack ? ao_scheme_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_scheme_eval_formal(void) +{ +	ao_poly			formal; +	struct ao_scheme_stack	*prev; + +	DBGI("formal: "); DBG_POLY(ao_scheme_v); DBG("\n"); + +	/* Check what kind of function we've got */ +	if (!ao_scheme_stack->values) { +		switch (func_type(ao_scheme_v)) { +		case AO_SCHEME_FUNC_LAMBDA: +			DBGI(".. lambda\n"); +			break; +		case AO_SCHEME_FUNC_MACRO: +			/* Evaluate the result once more */ +			ao_scheme_stack->state = eval_macro; +			if (!ao_scheme_stack_push()) +				return 0; + +			/* After the function returns, take that +			 * value and re-evaluate it +			 */ +			prev = ao_scheme_poly_stack(ao_scheme_stack->prev); +			ao_scheme_stack->sexprs = prev->sexprs; + +			DBGI(".. start macro\n"); +			DBGI("\t.. sexprs       "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +			DBGI("\t.. values       "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); +			DBG_FRAMES(); + +			/* fall through ... */ +		case AO_SCHEME_FUNC_NLAMBDA: +			DBGI(".. nlambda or macro\n"); + +			/* use the raw sexprs as values */ +			ao_scheme_stack->values = ao_scheme_stack->sexprs; +			ao_scheme_stack->values_tail = AO_SCHEME_NIL; +			ao_scheme_stack->state = eval_exec; + +			/* ready to execute now */ +			return 1; +		case -1: +			return 0; +		} +	} + +	/* Append formal to list of values */ +	formal = ao_scheme__cons(ao_scheme_v, AO_SCHEME_NIL); +	if (!formal) +		return 0; + +	if (ao_scheme_stack->values_tail) +		ao_scheme_poly_cons(ao_scheme_stack->values_tail)->cdr = formal; +	else +		ao_scheme_stack->values = formal; +	ao_scheme_stack->values_tail = formal; + +	DBGI(".. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + +	/* +	 * Step to the next argument, if this is last, then +	 * 'sexpr' will end up switching to 'exec' +	 */ +	ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + +	ao_scheme_stack->state = eval_sexpr; + +	DBGI(".. "); DBG_POLY(ao_scheme_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_scheme_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_scheme_eval_exec(void) +{ +	ao_poly v; +	struct ao_scheme_builtin	*builtin; + +	DBGI("exec: "); DBG_POLY(ao_scheme_v); DBG(" values "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); +	ao_scheme_stack->sexprs = AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_v)) { +	case AO_SCHEME_BUILTIN: +		ao_scheme_stack->state = eval_val; +		builtin = ao_scheme_poly_builtin(ao_scheme_v); +		v = ao_scheme_func(builtin) ( +			ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr)); +		DBG_DO(if (!ao_scheme_exception && ao_scheme_poly_builtin(ao_scheme_v)->func == builtin_set) { +				struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); +				ao_poly atom = ao_scheme_arg(cons, 1); +				ao_poly val = ao_scheme_arg(cons, 2); +				DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); +			}); +		builtin = ao_scheme_poly_builtin(ao_scheme_v); +		if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack) && !ao_scheme_skip_cons_free) { +			struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); +			ao_scheme_stack->values = AO_SCHEME_NIL; +			ao_scheme_cons_free(cons); +		} + +		ao_scheme_v = v; +		ao_scheme_stack->values = AO_SCHEME_NIL; +		ao_scheme_stack->values_tail = AO_SCHEME_NIL; +		DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		break; +	case AO_SCHEME_LAMBDA: +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		ao_scheme_stack->state = eval_begin; +		v = ao_scheme_lambda_eval(); +		ao_scheme_stack->sexprs = v; +		ao_scheme_stack->values = AO_SCHEME_NIL; +		ao_scheme_stack->values_tail = AO_SCHEME_NIL; +		DBGI(".. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		break; +	case AO_SCHEME_STACK: +		DBGI(".. stack "); DBG_POLY(ao_scheme_v); DBG("\n"); +		ao_scheme_v = ao_scheme_stack_eval(); +		DBGI(".. value "); DBG_POLY(ao_scheme_v); DBG("\n"); +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		break; +	} +	ao_scheme_skip_cons_free = 0; +	return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_scheme_eval_apply(void) +{ +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_v); +	struct ao_scheme_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_scheme_poly_cons(prev->cdr); +		if (cdr->cdr == AO_SCHEME_NIL) +			break; +	} +	DBGI("before mangling: "); DBG_POLY(ao_scheme_v); DBG("\n"); +	prev->cdr = cdr->car; +	ao_scheme_stack->values = ao_scheme_v; +	ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; +	DBGI("apply: "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); +	ao_scheme_stack->state = eval_exec; +	ao_scheme_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_scheme_eval_cond(void) +{ +	DBGI("cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); +	if (!ao_scheme_stack->sexprs) { +		ao_scheme_v = _ao_scheme_bool_false; +		ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; +		if (!ao_scheme_v || ao_scheme_poly_type(ao_scheme_v) != AO_SCHEME_CONS) { +			ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); +			return 0; +		} +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; +		if (ao_scheme_v == _ao_scheme_atom_else) +			ao_scheme_v = _ao_scheme_bool_true; +		ao_scheme_stack->state = eval_cond_test; +		if (!ao_scheme_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_scheme_eval_cond_test(void) +{ +	DBGI("cond_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); +	if (ao_scheme_v != _ao_scheme_bool_false) { +		struct ao_scheme_cons *car = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car); +		ao_poly c = car->cdr; + +		if (c) { +			ao_scheme_stack->state = eval_begin; +			ao_scheme_stack->sexprs = c; +		} else +			ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; +		DBGI("next cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +		ao_scheme_stack->state = eval_cond; +	} +	return 1; +} + +/* + * Evaluate a list of sexprs, returning the value from the last one. + * + * ao_scheme_begin records the list in stack->sexprs, so we just need to + * walk that list. Set ao_scheme_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_scheme_eval_begin(void) +{ +	DBGI("begin: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + +	if (!ao_scheme_stack->sexprs) { +		ao_scheme_v = AO_SCHEME_NIL; +		ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; +		ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_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_scheme_stack->sexprs) { +			ao_scheme_stack->state = eval_begin; +			if (!ao_scheme_stack_push()) +				return 0; +		} +		ao_scheme_stack->state = eval_sexpr; +	} +	return 1; +} + +/* + * Conditionally execute a list of sexprs while the first is true + */ +static int +ao_scheme_eval_while(void) +{ +	DBGI("while: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + +	ao_scheme_stack->values = ao_scheme_v; +	if (!ao_scheme_stack->sexprs) { +		ao_scheme_v = AO_SCHEME_NIL; +		ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; +		ao_scheme_stack->state = eval_while_test; +		if (!ao_scheme_stack_push()) +			return 0; +	} +	return 1; +} + +/* + * Check the while condition, terminate the loop if nil. Otherwise keep going + */ +static int +ao_scheme_eval_while_test(void) +{ +	DBGI("while_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + +	if (ao_scheme_v != _ao_scheme_bool_false) { +		ao_scheme_stack->values = ao_scheme_v; +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; +		ao_scheme_stack->state = eval_while; +		if (!ao_scheme_stack_push()) +			return 0; +		ao_scheme_stack->state = eval_begin; +		ao_scheme_stack->sexprs = ao_scheme_v; +	} +	else +	{ +		ao_scheme_stack->state = eval_val; +		ao_scheme_v = ao_scheme_stack->values; +	} +	return 1; +} + +/* + * Replace the original sexpr with the macro expansion, then + * execute that + */ +static int +ao_scheme_eval_macro(void) +{ +	DBGI("macro: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + +	if (ao_scheme_v == AO_SCHEME_NIL) +		ao_scheme_abort(); +	if (ao_scheme_poly_type(ao_scheme_v) == AO_SCHEME_CONS) { +		*ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); +		ao_scheme_v = ao_scheme_stack->sexprs; +		DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); +	} +	ao_scheme_stack->sexprs = AO_SCHEME_NIL; +	ao_scheme_stack->state = eval_sexpr; +	return 1; +} + +static int (*const evals[])(void) = { +	[eval_sexpr] = ao_scheme_eval_sexpr, +	[eval_val] = ao_scheme_eval_val, +	[eval_formal] = ao_scheme_eval_formal, +	[eval_exec] = ao_scheme_eval_exec, +	[eval_apply] = ao_scheme_eval_apply, +	[eval_cond] = ao_scheme_eval_cond, +	[eval_cond_test] = ao_scheme_eval_cond_test, +	[eval_begin] = ao_scheme_eval_begin, +	[eval_while] = ao_scheme_eval_while, +	[eval_while_test] = ao_scheme_eval_while_test, +	[eval_macro] = ao_scheme_eval_macro, +}; + +const char * const ao_scheme_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_scheme_eval_clear_globals(void) +{ +	ao_scheme_stack = NULL; +	ao_scheme_frame_current = NULL; +	ao_scheme_v = AO_SCHEME_NIL; +} + +int +ao_scheme_eval_restart(void) +{ +	return ao_scheme_stack_push(); +} + +ao_poly +ao_scheme_eval(ao_poly _v) +{ +	ao_scheme_v = _v; + +	ao_scheme_frame_init(); + +	if (!ao_scheme_stack_push()) +		return AO_SCHEME_NIL; + +	while (ao_scheme_stack) { +		if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) { +			ao_scheme_stack_clear(); +			return AO_SCHEME_NIL; +		} +	} +	DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); +	ao_scheme_frame_current = NULL; +	return ao_scheme_v; +} diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c new file mode 100644 index 00000000..541f0264 --- /dev/null +++ b/src/scheme/ao_scheme_float.c @@ -0,0 +1,148 @@ +/* + * 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_scheme.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_scheme_float); +} + +static void float_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_float_type = { +	.mark = float_mark, +	.size = float_size, +	.move = float_move, +	.name = "float", +}; + +void +ao_scheme_float_write(ao_poly p) +{ +	struct ao_scheme_float *f = ao_scheme_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_scheme_poly_number(ao_poly p) +{ +	switch (ao_scheme_poly_base_type(p)) { +	case AO_SCHEME_INT: +		return ao_scheme_poly_int(p); +	case AO_SCHEME_OTHER: +		switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { +		case AO_SCHEME_BIGINT: +			return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); +		case AO_SCHEME_FLOAT: +			return ao_scheme_poly_float(p)->value; +		} +	} +	return NAN; +} + +ao_poly +ao_scheme_float_get(float value) +{ +	struct ao_scheme_float	*f; + +	f = ao_scheme_alloc(sizeof (struct ao_scheme_float)); +	f->type = AO_SCHEME_FLOAT; +	f->value = value; +	return ao_scheme_float_poly(f); +} + +ao_poly +ao_scheme_do_inexactp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT) +		return _ao_scheme_bool_true; +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_finitep(struct ao_scheme_cons *cons) +{ +	ao_poly	value; +	float	f; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	value = ao_scheme_arg(cons, 0); +	switch (ao_scheme_poly_type(value)) { +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +		return _ao_scheme_bool_true; +	case AO_SCHEME_FLOAT: +		f = ao_scheme_poly_float(value)->value; +		if (!isnan(f) && !isinf(f)) +			return _ao_scheme_bool_true; +	} +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_infinitep(struct ao_scheme_cons *cons) +{ +	ao_poly	value; +	float	f; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	value = ao_scheme_arg(cons, 0); +	switch (ao_scheme_poly_type(value)) { +	case AO_SCHEME_FLOAT: +		f = ao_scheme_poly_float(value)->value; +		if (isinf(f)) +			return _ao_scheme_bool_true; +	} +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_sqrt(struct ao_scheme_cons *cons) +{ +	ao_poly	value; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1)) +		return AO_SCHEME_NIL; +	value = ao_scheme_arg(cons, 0); +	if (!ao_scheme_number_typep(ao_scheme_poly_type(value))) +		return ao_scheme_error(AO_SCHEME_INVALID, "%s: non-numeric", ao_scheme_poly_atom(_ao_scheme_atom_sqrt)->name); +	return ao_scheme_float_get(sqrtf(ao_scheme_poly_number(value))); +} diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c new file mode 100644 index 00000000..e5d481e7 --- /dev/null +++ b/src/scheme/ao_scheme_frame.c @@ -0,0 +1,330 @@ +/* + * 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_scheme.h" + +static inline int +frame_vals_num_size(int num) +{ +	return sizeof (struct ao_scheme_frame_vals) + num * sizeof (struct ao_scheme_val); +} + +static int +frame_vals_size(void *addr) +{ +	struct ao_scheme_frame_vals	*vals = addr; +	return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ +	struct ao_scheme_frame_vals	*vals = addr; +	int				f; + +	for (f = 0; f < vals->size; f++) { +		struct ao_scheme_val	*v = &vals->vals[f]; + +		ao_scheme_poly_mark(v->val, 0); +		MDBG_MOVE("frame mark atom %s %d val %d at %d    ", +			  ao_scheme_poly_atom(v->atom)->name, +			  MDBG_OFFSET(ao_scheme_ref(v->atom)), +			  MDBG_OFFSET(ao_scheme_ref(v->val)), f); +		MDBG_DO(ao_scheme_poly_write(v->val)); +		MDBG_DO(printf("\n")); +	} +} + +static void +frame_vals_move(void *addr) +{ +	struct ao_scheme_frame_vals	*vals = addr; +	int				f; + +	for (f = 0; f < vals->size; f++) { +		struct ao_scheme_val	*v = &vals->vals[f]; + +		ao_scheme_poly_move(&v->atom, 0); +		ao_scheme_poly_move(&v->val, 0); +		MDBG_MOVE("frame move atom %s %d val %d at %d\n", +			  ao_scheme_poly_atom(v->atom)->name, +			  MDBG_OFFSET(ao_scheme_ref(v->atom)), +			  MDBG_OFFSET(ao_scheme_ref(v->val)), f); +	} +} + +const struct ao_scheme_type ao_scheme_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_scheme_frame); +} + +static void +frame_mark(void *addr) +{ +	struct ao_scheme_frame	*frame = addr; + +	for (;;) { +		MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); +		if (!AO_SCHEME_IS_POOL(frame)) +			break; +		ao_scheme_poly_mark(frame->vals, 0); +		frame = ao_scheme_poly_frame(frame->prev); +		MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); +		if (!frame) +			break; +		if (ao_scheme_mark_memory(&ao_scheme_frame_type, frame)) +			break; +	} +} + +static void +frame_move(void *addr) +{ +	struct ao_scheme_frame	*frame = addr; + +	for (;;) { +		struct ao_scheme_frame	*prev; +		int			ret; + +		MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); +		if (!AO_SCHEME_IS_POOL(frame)) +			break; +		ao_scheme_poly_move(&frame->vals, 0); +		prev = ao_scheme_poly_frame(frame->prev); +		if (!prev) +			break; +		ret = ao_scheme_move_memory(&ao_scheme_frame_type, (void **) &prev); +		if (prev != ao_scheme_poly_frame(frame->prev)) { +			MDBG_MOVE("frame prev moved from %d to %d\n", +				  MDBG_OFFSET(ao_scheme_poly_frame(frame->prev)), +				  MDBG_OFFSET(prev)); +			frame->prev = ao_scheme_frame_poly(prev); +		} +		if (ret) +			break; +		frame = prev; +	} +} + +const struct ao_scheme_type ao_scheme_frame_type = { +	.mark = frame_mark, +	.size = frame_size, +	.move = frame_move, +	.name = "frame", +}; + +void +ao_scheme_frame_write(ao_poly p) +{ +	struct ao_scheme_frame		*frame = ao_scheme_poly_frame(p); +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int				f; + +	printf ("{"); +	if (frame) { +		if (frame->type & AO_SCHEME_FRAME_PRINT) +			printf("recurse..."); +		else { +			frame->type |= AO_SCHEME_FRAME_PRINT; +			for (f = 0; f < frame->num; f++) { +				if (f != 0) +					printf(", "); +				ao_scheme_poly_write(vals->vals[f].atom); +				printf(" = "); +				ao_scheme_poly_write(vals->vals[f].val); +			} +			if (frame->prev) +				ao_scheme_poly_write(frame->prev); +			frame->type &= ~AO_SCHEME_FRAME_PRINT; +		} +	} +	printf("}"); +} + +static int +ao_scheme_frame_find(struct ao_scheme_frame *frame, int top, ao_poly atom) +{ +	struct ao_scheme_frame_vals	*vals = ao_scheme_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_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom) +{ +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int				l = ao_scheme_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_scheme_frame	*ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +static struct ao_scheme_frame_vals * +ao_scheme_frame_vals_new(int num) +{ +	struct ao_scheme_frame_vals	*vals; + +	vals = ao_scheme_alloc(frame_vals_num_size(num)); +	if (!vals) +		return NULL; +	vals->type = AO_SCHEME_FRAME_VALS; +	vals->size = num; +	memset(vals->vals, '\0', num * sizeof (struct ao_scheme_val)); +	return vals; +} + +struct ao_scheme_frame * +ao_scheme_frame_new(int num) +{ +	struct ao_scheme_frame		*frame; +	struct ao_scheme_frame_vals	*vals; + +	if (num < AO_SCHEME_FRAME_FREE && (frame = ao_scheme_frame_free_list[num])) { +		ao_scheme_frame_free_list[num] = ao_scheme_poly_frame(frame->prev); +		vals = ao_scheme_poly_frame_vals(frame->vals); +	} else { +		frame = ao_scheme_alloc(sizeof (struct ao_scheme_frame)); +		if (!frame) +			return NULL; +		frame->type = AO_SCHEME_FRAME; +		frame->num = 0; +		frame->prev = AO_SCHEME_NIL; +		frame->vals = AO_SCHEME_NIL; +		ao_scheme_frame_stash(0, frame); +		vals = ao_scheme_frame_vals_new(num); +		frame = ao_scheme_frame_fetch(0); +		if (!vals) +			return NULL; +		frame->vals = ao_scheme_frame_vals_poly(vals); +		frame->num = num; +	} +	frame->prev = AO_SCHEME_NIL; +	return frame; +} + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame) +{ +	if (!frame) +		return AO_SCHEME_NIL; +	frame->type |= AO_SCHEME_FRAME_MARK; +	return ao_scheme_frame_poly(frame); +} + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame) +{ +	if (frame && !ao_scheme_frame_marked(frame)) { +		int	num = frame->num; +		if (num < AO_SCHEME_FRAME_FREE) { +			struct ao_scheme_frame_vals	*vals; + +			vals = ao_scheme_poly_frame_vals(frame->vals); +			memset(vals->vals, '\0', vals->size * sizeof (struct ao_scheme_val)); +			frame->prev = ao_scheme_frame_poly(ao_scheme_frame_free_list[num]); +			ao_scheme_frame_free_list[num] = frame; +		} +	} +} + +static struct ao_scheme_frame * +ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) +{ +	struct ao_scheme_frame_vals	*vals; +	struct ao_scheme_frame_vals	*new_vals; +	int				copy; + +	if (new_num == frame->num) +		return frame; +	ao_scheme_frame_stash(0, frame); +	new_vals = ao_scheme_frame_vals_new(new_num); +	frame = ao_scheme_frame_fetch(0); +	if (!new_vals) +		return NULL; +	vals = ao_scheme_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_scheme_val)); +	frame->vals = ao_scheme_frame_vals_poly(new_vals); +	frame->num = new_num; +	return frame; +} + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val) +{ +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int 				l = ao_scheme_frame_find(frame, num, atom); + +	memmove(&vals->vals[l+1], +		&vals->vals[l], +		(num - l) * sizeof (struct ao_scheme_val)); +	vals->vals[l].atom = atom; +	vals->vals[l].val = val; +} + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) +{ +	ao_poly *ref = frame ? ao_scheme_frame_ref(frame, atom) : NULL; + +	if (!ref) { +		int f = frame->num; +		ao_scheme_poly_stash(0, atom); +		ao_scheme_poly_stash(1, val); +		frame = ao_scheme_frame_realloc(frame, f + 1); +		val = ao_scheme_poly_fetch(1); +		atom = ao_scheme_poly_fetch(0); +		if (!frame) +			return AO_SCHEME_NIL; +		ao_scheme_frame_bind(frame, frame->num - 1, atom, val); +	} else +		*ref = val; +	return val; +} + +struct ao_scheme_frame	*ao_scheme_frame_global; +struct ao_scheme_frame	*ao_scheme_frame_current; + +void +ao_scheme_frame_init(void) +{ +	if (!ao_scheme_frame_global) +		ao_scheme_frame_global = ao_scheme_frame_new(0); +} diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c new file mode 100644 index 00000000..350a5d35 --- /dev/null +++ b/src/scheme/ao_scheme_int.c @@ -0,0 +1,79 @@ +/* + * 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_scheme.h" + +void +ao_scheme_int_write(ao_poly p) +{ +	int i = ao_scheme_poly_int(p); +	printf("%d", i); +} + +int32_t +ao_scheme_poly_integer(ao_poly p) +{ +	switch (ao_scheme_poly_base_type(p)) { +	case AO_SCHEME_INT: +		return ao_scheme_poly_int(p); +	case AO_SCHEME_OTHER: +		if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) +			return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); +	} +	return AO_SCHEME_NOT_INTEGER; +} + +ao_poly +ao_scheme_integer_poly(int32_t p) +{ +	struct ao_scheme_bigint	*bi; + +	if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) +		return ao_scheme_int_poly(p); +	bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); +	bi->value = ao_scheme_int_bigint(p); +	return ao_scheme_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_scheme_bigint); +} + +static void bigint_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_bigint_type = { +	.mark = bigint_mark, +	.size = bigint_size, +	.move = bigint_move, +	.name = "bigint", +}; + +void +ao_scheme_bigint_write(ao_poly p) +{ +	struct ao_scheme_bigint	*bi = ao_scheme_poly_bigint(p); + +	printf("%d", ao_scheme_bigint_int(bi->value)); +} diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c new file mode 100644 index 00000000..ec6f858c --- /dev/null +++ b/src/scheme/ao_scheme_lambda.c @@ -0,0 +1,208 @@ +/* + * 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_scheme.h" + +int +lambda_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_lambda); +} + +void +lambda_mark(void *addr) +{ +	struct ao_scheme_lambda	*lambda = addr; + +	ao_scheme_poly_mark(lambda->code, 0); +	ao_scheme_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ +	struct ao_scheme_lambda	*lambda = addr; + +	ao_scheme_poly_move(&lambda->code, 0); +	ao_scheme_poly_move(&lambda->frame, 0); +} + +const struct ao_scheme_type ao_scheme_lambda_type = { +	.size = lambda_size, +	.mark = lambda_mark, +	.move = lambda_move, +	.name = "lambda", +}; + +void +ao_scheme_lambda_write(ao_poly poly) +{ +	struct ao_scheme_lambda	*lambda = ao_scheme_poly_lambda(poly); +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(lambda->code); + +	printf("("); +	printf("%s", ao_scheme_args_name(lambda->args)); +	while (cons) { +		printf(" "); +		ao_scheme_poly_write(cons->car); +		cons = ao_scheme_poly_cons(cons->cdr); +	} +	printf(")"); +} + +ao_poly +ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) +{ +	struct ao_scheme_lambda	*lambda; +	ao_poly			formal; +	struct ao_scheme_cons	*cons; + +	formal = ao_scheme_arg(code, 0); +	while (formal != AO_SCHEME_NIL) { +		switch (ao_scheme_poly_type(formal)) { +		case AO_SCHEME_CONS: +			cons = ao_scheme_poly_cons(formal); +			if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM) +				return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car); +			formal = cons->cdr; +			break; +		case AO_SCHEME_ATOM: +			formal = AO_SCHEME_NIL; +			break; +		default: +			return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal); +		} +	} + +	ao_scheme_cons_stash(0, code); +	lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); +	code = ao_scheme_cons_fetch(0); +	if (!lambda) +		return AO_SCHEME_NIL; + +	lambda->type = AO_SCHEME_LAMBDA; +	lambda->args = args; +	lambda->code = ao_scheme_cons_poly(code); +	lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current); +	DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); +	DBG_STACK(); +	return ao_scheme_lambda_poly(lambda); +} + +ao_poly +ao_scheme_do_lambda(struct ao_scheme_cons *cons) +{ +	return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA); +} + +ao_poly +ao_scheme_do_nlambda(struct ao_scheme_cons *cons) +{ +	return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA); +} + +ao_poly +ao_scheme_do_macro(struct ao_scheme_cons *cons) +{ +	return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO); +} + +ao_poly +ao_scheme_lambda_eval(void) +{ +	struct ao_scheme_lambda	*lambda = ao_scheme_poly_lambda(ao_scheme_v); +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_stack->values); +	struct ao_scheme_cons	*code = ao_scheme_poly_cons(lambda->code); +	ao_poly			formals; +	struct ao_scheme_frame	*next_frame; +	int			args_wanted; +	ao_poly			varargs = AO_SCHEME_NIL; +	int			args_provided; +	int			f; +	struct ao_scheme_cons	*vals; + +	DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n"); + +	args_wanted = 0; +	for (formals = ao_scheme_arg(code, 0); +	     ao_scheme_is_pair(formals); +	     formals = ao_scheme_poly_cons(formals)->cdr) +		++args_wanted; +	if (formals != AO_SCHEME_NIL) { +		if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM) +			return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form"); +		varargs = formals; +	} + +	/* Create a frame to hold the variables +	 */ +	args_provided = ao_scheme_cons_length(cons) - 1; +	if (varargs == AO_SCHEME_NIL) { +		if (args_wanted != args_provided) +			return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided); +	} else { +		if (args_provided < args_wanted) +			return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); +	} + +	ao_scheme_poly_stash(1, varargs); +	next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); +	varargs = ao_scheme_poly_fetch(1); +	if (!next_frame) +		return AO_SCHEME_NIL; + +	/* Re-fetch all of the values in case something moved */ +	lambda = ao_scheme_poly_lambda(ao_scheme_v); +	cons = ao_scheme_poly_cons(ao_scheme_stack->values); +	code = ao_scheme_poly_cons(lambda->code); +	formals = ao_scheme_arg(code, 0); +	vals = ao_scheme_poly_cons(cons->cdr); + +	next_frame->prev = lambda->frame; +	ao_scheme_frame_current = next_frame; +	ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + +	for (f = 0; f < args_wanted; f++) { +		struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); +		DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); +		ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); +		formals = arg->cdr; +		vals = ao_scheme_poly_cons(vals->cdr); +	} +	if (varargs) { +		DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); +		/* +		 * Bind the rest of the arguments to the final parameter +		 */ +		ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_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_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { +			ao_scheme_stack->values = AO_SCHEME_NIL; +			ao_scheme_cons_free(cons); +		} +	} +	DBGI("eval frame: "); DBG_POLY(ao_scheme_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/scheme/ao_scheme_lex.c index fe7c47f4..266b1fc0 100644 --- a/src/lisp/ao_lisp_lex.c +++ b/src/scheme/ao_scheme_lex.c @@ -12,5 +12,5 @@   * General Public License for more details.   */ -#include "ao_lisp.h" +#include "ao_scheme.h" diff --git a/src/lisp/ao_lisp_make_builtin b/src/scheme/ao_scheme_make_builtin index 783ab378..8e9c2c0b 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/scheme/ao_scheme_make_builtin @@ -53,31 +53,31 @@ 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"); +	printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); +	printf("#undef AO_SCHEME_BUILTIN_ID\n"); +	printf("enum ao_scheme_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"); +	printf("#endif /* AO_SCHEME_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("#ifdef AO_SCHEME_BUILTIN_CASENAME\n"); +	printf("#undef AO_SCHEME_BUILTIN_CASENAME\n"); +	printf("static char *ao_scheme_builtin_name(enum ao_scheme_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", +			printf("\tcase builtin_%s: return ao_scheme_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"); +	printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n");  }  void @@ -93,59 +93,59 @@ cify_lisp(string l) {  void  dump_arrayname(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_ARRAYNAME\n"); -	printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n"); +	printf("#ifdef AO_SCHEME_BUILTIN_ARRAYNAME\n"); +	printf("#undef AO_SCHEME_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_", +			printf("\t[builtin_%s] = _ao_scheme_atom_",  			       builtins[i].c_name);  			cify_lisp(builtins[i].lisp_names[0]);  			printf(",\n");  		}  	}  	printf("};\n"); -	printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n"); +	printf("#endif /* AO_SCHEME_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"); +	printf("#ifdef AO_SCHEME_BUILTIN_FUNCS\n"); +	printf("#undef AO_SCHEME_BUILTIN_FUNCS\n"); +	printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n");  	for (int i = 0; i < dim(builtins); i++) {  		if (!is_atom(builtins[i])) -			printf("\t[builtin_%s] = ao_lisp_do_%s,\n", +			printf("\t[builtin_%s] = ao_scheme_do_%s,\n",  			       builtins[i].c_name,  			       builtins[i].c_name);  	}  	printf("};\n"); -	printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); +	printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n");  }  void  dump_decls(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); -	printf("#undef AO_LISP_BUILTIN_DECLS\n"); +	printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); +	printf("#undef AO_SCHEME_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", +			printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n",  			       builtins[i].c_name);  		}  	} -	printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); +	printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n");  }  void  dump_consts(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_CONSTS\n"); -	printf("#undef AO_LISP_BUILTIN_CONSTS\n"); +	printf("#ifdef AO_SCHEME_BUILTIN_CONSTS\n"); +	printf("#undef AO_SCHEME_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", +				printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n",  					builtins[i].lisp_names[j],  					builtins[i].type,  					builtins[i].c_name); @@ -153,21 +153,21 @@ dump_consts(builtin_t[*] builtins) {  		}  	}  	printf("};\n"); -	printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); +	printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n");  }  void  dump_atoms(builtin_t[*] builtins) { -	printf("#ifdef AO_LISP_BUILTIN_ATOMS\n"); -	printf("#undef AO_LISP_BUILTIN_ATOMS\n"); +	printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); +	printf("#undef AO_SCHEME_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_"); +			printf("#define _ao_scheme_atom_");  			cify_lisp(builtins[i].lisp_names[j]);  			printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]);  		}  	} -	printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); +	printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n");  }  void main() { diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c new file mode 100644 index 00000000..cf42ec52 --- /dev/null +++ b/src/scheme/ao_scheme_make_const.c @@ -0,0 +1,395 @@ +/* + * 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_scheme.h" +#include <stdlib.h> +#include <ctype.h> +#include <unistd.h> +#include <getopt.h> + +static struct ao_scheme_builtin * +ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { +	struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin)); + +	b->type = AO_SCHEME_BUILTIN; +	b->func = func; +	b->args = args; +	return b; +} + +struct builtin_func { +	char	*name; +	int	args; +	enum ao_scheme_builtin_id	func; +}; + +#define AO_SCHEME_BUILTIN_CONSTS +#include "ao_scheme_builtin.h" + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +struct ao_scheme_frame	*globals; + +static int +is_atom(int offset) +{ +	struct ao_scheme_atom *a; + +	for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) +		if (((uint8_t *) a->name - ao_scheme_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_scheme_macro_stack { +	struct ao_scheme_macro_stack *next; +	ao_poly	p; +}; + +struct ao_scheme_macro_stack *macro_stack; + +int +ao_scheme_macro_push(ao_poly p) +{ +	struct ao_scheme_macro_stack *m = macro_stack; + +	while (m) { +		if (m->p == p) +			return 1; +		m = m->next; +	} +	m = malloc (sizeof (struct ao_scheme_macro_stack)); +	m->p = p; +	m->next = macro_stack; +	macro_stack = m; +	return 0; +} + +void +ao_scheme_macro_pop(void) +{ +	struct ao_scheme_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_scheme_atom_ref(atom, NULL); +	if (ref) +		return *ref; +	return AO_SCHEME_NIL; +} + +ao_poly +ao_is_macro(ao_poly p) +{ +	struct ao_scheme_builtin	*builtin; +	struct ao_scheme_lambda	*lambda; +	ao_poly ret; + +	MACRO_DEBUG(indent(); printf ("is macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); +	switch (ao_scheme_poly_type(p)) { +	case AO_SCHEME_ATOM: +		if (ao_scheme_macro_push(p)) +			ret = AO_SCHEME_NIL; +		else { +			if (ao_is_macro(ao_macro_test_get(p))) +				ret = p; +			else +				ret = AO_SCHEME_NIL; +			ao_scheme_macro_pop(); +		} +		break; +	case AO_SCHEME_CONS: +		ret = ao_has_macro(p); +		break; +	case AO_SCHEME_BUILTIN: +		builtin = ao_scheme_poly_builtin(p); +		if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO) +			ret = p; +		else +			ret = 0; +		break; + +	case AO_SCHEME_LAMBDA: +		lambda = ao_scheme_poly_lambda(p); +		if (lambda->args == AO_SCHEME_FUNC_MACRO) +			ret = p; +		else +			ret = ao_has_macro(lambda->code); +		break; +	default: +		ret = AO_SCHEME_NIL; +		break; +	} +	MACRO_DEBUG(--macro_scan_depth;	indent(); printf ("... "); ao_scheme_poly_write(ret); printf("\n")); +	return ret; +} + +ao_poly +ao_has_macro(ao_poly p) +{ +	struct ao_scheme_cons	*cons; +	struct ao_scheme_lambda	*lambda; +	ao_poly			m; +	ao_poly			list; + +	if (p == AO_SCHEME_NIL) +		return AO_SCHEME_NIL; + +	MACRO_DEBUG(indent(); printf("has macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); +	switch (ao_scheme_poly_type(p)) { +	case AO_SCHEME_LAMBDA: +		lambda = ao_scheme_poly_lambda(p); +		p = ao_has_macro(lambda->code); +		break; +	case AO_SCHEME_CONS: +		cons = ao_scheme_poly_cons(p); +		if ((p = ao_is_macro(cons->car))) +			break; + +		list = cons->cdr; +		p = AO_SCHEME_NIL; +		while (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { +			cons = ao_scheme_poly_cons(list); +			m = ao_has_macro(cons->car); +			if (m) { +				p = m; +				break; +			} +			list = cons->cdr; +		} +		break; + +	default: +		p = AO_SCHEME_NIL; +		break; +	} +	MACRO_DEBUG(--macro_scan_depth;	indent(); printf("... "); ao_scheme_poly_write(p); printf("\n")); +	return p; +} + +int +ao_scheme_read_eval_abort(void) +{ +	ao_poly	in, out = AO_SCHEME_NIL; +	for(;;) { +		in = ao_scheme_read(); +		if (in == _ao_scheme_atom_eof) +			break; +		out = ao_scheme_eval(in); +		if (ao_scheme_exception) +			return 0; +		ao_scheme_poly_write(out); +		putchar ('\n'); +	} +	return 1; +} + +static FILE	*in; +static FILE	*out; + +int +ao_scheme_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_scheme_atom	*a; +	struct ao_scheme_builtin	*b; +	int	in_atom = 0; +	char	*out_name = NULL; +	int	c; +	enum ao_scheme_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_scheme_frame_init(); + +	/* Boolean values #f and #t */ +	ao_scheme_bool_get(0); +	ao_scheme_bool_get(1); + +	prev_func = _builtin_last; +	for (f = 0; f < (int) N_FUNC; f++) { +		if (funcs[f].func != prev_func) +			b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); +		a = ao_scheme_atom_intern(funcs[f].name); +		ao_scheme_atom_def(ao_scheme_atom_poly(a), +				 ao_scheme_builtin_poly(b)); +	} + +	/* end of file value */ +	a = ao_scheme_atom_intern("eof"); +	ao_scheme_atom_def(ao_scheme_atom_poly(a), +			 ao_scheme_atom_poly(a)); + +	/* 'else' */ +	a = ao_scheme_atom_intern("else"); + +	if (argv[optind]){ +		in = fopen(argv[optind], "r"); +		if (!in) { +			perror(argv[optind]); +			exit(1); +		} +	} +	if (!ao_scheme_read_eval_abort()) { +		fprintf(stderr, "eval failed\n"); +		exit(1); +	} + +	/* Reduce to referenced values */ +	ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + +	for (f = 0; f < ao_scheme_frame_global->num; f++) { +		struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); +		val = ao_has_macro(vals->vals[f].val); +		if (val != AO_SCHEME_NIL) { +			printf("error: function %s contains unresolved macro: ", +			       ao_scheme_poly_atom(vals->vals[f].atom)->name); +			ao_scheme_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_SCHEME_POOL_CONST %d\n", ao_scheme_top); +	fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n"); +	fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms)); +	fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global)); +	fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top)); + +	fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false)); +	fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true)); + +	for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) { +		char	*n = a->name, c; +		fprintf(out, "#define _ao_scheme_atom_"); +		while ((c = *n++)) { +			if (isalnum(c)) +				fprintf(out, "%c", c); +			else +				fprintf(out, "%02x", c); +		} +		fprintf(out, "  0x%04x\n", ao_scheme_atom_poly(a)); +	} +	fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); +	fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); +	for (o = 0; o < ao_scheme_top; o++) { +		uint8_t	c; +		if ((o & 0xf) == 0) +			fprintf(out, "\n\t"); +		else +			fprintf(out, " "); +		c = ao_scheme_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_SCHEME_CONST_BITS */\n"); +	exit(0); +} diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c new file mode 100644 index 00000000..acc726c8 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,968 @@ +/* + * 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_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include <stdio.h> +#include <assert.h> + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include <stdlib.h> +uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#undef AO_SCHEME_POOL +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#else + +uint8_t	ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_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_scheme_record { +	struct ao_scheme_record		*next; +	const struct ao_scheme_type	*type; +	void				*addr; +	int				size; +}; + +static struct ao_scheme_record	*record_head, **record_tail; + +static void +ao_scheme_record_free(struct ao_scheme_record *record) +{ +	while (record) { +		struct ao_scheme_record *next = record->next; +		free(record); +		record = next; +	} +} + +static void +ao_scheme_record_reset(void) +{ +	ao_scheme_record_free(record_head); +	record_head = NULL; +	record_tail = &record_head; +} + +static void +ao_scheme_record(const struct ao_scheme_type	*type, +	       void				*addr, +	       int				size) +{ +	struct ao_scheme_record	*r = malloc(sizeof (struct ao_scheme_record)); + +	r->next = NULL; +	r->type = type; +	r->addr = addr; +	r->size = size; +	*record_tail = r; +	record_tail = &r->next; +} + +static struct ao_scheme_record * +ao_scheme_record_save(void) +{ +	struct ao_scheme_record *r = record_head; + +	record_head = NULL; +	record_tail = &record_head; +	return r; +} + +static void +ao_scheme_record_compare(char *where, +		       struct ao_scheme_record *a, +		       struct ao_scheme_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_scheme_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_scheme_abort(); +	} +	if (b) { +		printf("%s record differs NULL -> %d %s %d\n", +		       where, +		       MDBG_OFFSET(b->addr), +		       b->type->name, +		       b->size); +		ao_scheme_abort(); +	} +} + +#else +#define ao_scheme_record_reset() +#endif + +uint8_t	ao_scheme_exception; + +struct ao_scheme_root { +	const struct ao_scheme_type	*type; +	void				**addr; +}; + +static struct ao_scheme_cons 	*save_cons[2]; +static char			*save_string[2]; +static struct ao_scheme_frame	*save_frame[1]; +static ao_poly			save_poly[3]; + +static const struct ao_scheme_root	ao_scheme_root[] = { +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &save_cons[0], +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &save_cons[1], +	}, +	{ +		.type = &ao_scheme_string_type, +		.addr = (void **) &save_string[0], +	}, +	{ +		.type = &ao_scheme_string_type, +		.addr = (void **) &save_string[1], +	}, +	{ +		.type = &ao_scheme_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_scheme_atom_type, +		.addr = (void **) &ao_scheme_atoms +	}, +	{ +		.type = &ao_scheme_frame_type, +		.addr = (void **) &ao_scheme_frame_global, +	}, +	{ +		.type = &ao_scheme_frame_type, +		.addr = (void **) &ao_scheme_frame_current, +	}, +	{ +		.type = &ao_scheme_stack_type, +		.addr = (void **) &ao_scheme_stack, +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &ao_scheme_v, +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &ao_scheme_read_cons, +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &ao_scheme_read_cons_tail, +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &ao_scheme_read_stack, +	}, +#ifdef AO_SCHEME_MAKE_CONST +	{ +		.type = &ao_scheme_bool_type, +		.addr = (void **) &ao_scheme_false, +	}, +	{ +		.type = &ao_scheme_bool_type, +		.addr = (void **) &ao_scheme_true, +	}, +#endif +}; + +#define AO_SCHEME_ROOT	(sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) + +static const void ** const ao_scheme_cache[] = { +	(const void **) &ao_scheme_cons_free_list, +	(const void **) &ao_scheme_stack_free_list, +	(const void **) &ao_scheme_frame_free_list[0], +	(const void **) &ao_scheme_frame_free_list[1], +	(const void **) &ao_scheme_frame_free_list[2], +	(const void **) &ao_scheme_frame_free_list[3], +	(const void **) &ao_scheme_frame_free_list[4], +	(const void **) &ao_scheme_frame_free_list[5], +}; + +#if AO_SCHEME_FRAME_FREE != 6 +#error Unexpected AO_SCHEME_FRAME_FREE value +#endif + +#define AO_SCHEME_CACHE	(sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) + +#define AO_SCHEME_BUSY_SIZE	((AO_SCHEME_POOL + 31) / 32) + +static uint8_t	ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; +static uint8_t	ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; +static uint8_t	ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; +static uint8_t	ao_scheme_cons_noted; + +uint16_t	ao_scheme_top; + +struct ao_scheme_chunk { +	uint16_t		old_offset; +	union { +		uint16_t	size; +		uint16_t	new_offset; +	}; +}; + +#define AO_SCHEME_NCHUNK	64 + +static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM +	if (!AO_SCHEME_IS_POOL(addr)) +		ao_scheme_abort(); +#endif +	return ((uint8_t *) addr) - ao_scheme_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_SCHEME_POOL, max(offset, 0)); +} + +static void +note_cons(uint16_t offset) +{ +	MDBG_MOVE("note cons %d\n", offset); +	ao_scheme_cons_noted = 1; +	mark(ao_scheme_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_scheme_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_SCHEME_NCHUNK) +		ao_scheme_abort(); + +	/* Off the left side */ +	if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) +		ao_scheme_abort(); +#endif + +	/* Shuffle existing entries right */ +	int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + +	memmove(&ao_scheme_chunk[l+1], +		&ao_scheme_chunk[l], +		(end - (l+1)) * sizeof (struct ao_scheme_chunk)); + +	/* Add new entry */ +	ao_scheme_chunk[l].old_offset = offset; +	ao_scheme_chunk[l].size = size; + +	/* Increment the number of elements up to the size of the array */ +	if (chunk_last < AO_SCHEME_NCHUNK) +		chunk_last++; + +	/* Set the top address if the array is full */ +	if (chunk_last == AO_SCHEME_NCHUNK) +		chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + +			ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; +} + +static void +reset_chunks(void) +{ +	chunk_high = ao_scheme_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_scheme_type *type, void **addr), +     int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) +{ +	int i; + +	ao_scheme_record_reset(); +	memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); +	memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); +	ao_scheme_cons_noted = 0; +	for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { +		if (ao_scheme_root[i].type) { +			void **a = ao_scheme_root[i].addr, *v; +			if (a && (v = *a)) { +				MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); +				visit_addr(ao_scheme_root[i].type, a); +			} +		} else { +			ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; +			if (a && (p = *a)) { +				MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); +				visit_poly(a, 0); +			} +		} +	} +	while (ao_scheme_cons_noted) { +		memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); +		memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); +		ao_scheme_cons_noted = 0; +		for (i = 0; i < AO_SCHEME_POOL; i += 4) { +			if (busy(ao_scheme_cons_last, i)) { +				void *v = ao_scheme_pool + i; +				MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); +				visit_addr(&ao_scheme_cons_type, &v); +			} +		} +	} +} + +#if MDBG_DUMP +static void +dump_busy(void) +{ +	int	i; +	MDBG_MOVE("busy:"); +	for (i = 0; i < ao_scheme_top; i += 4) { +		if ((i & 0xff) == 0) { +			MDBG_MORE("\n"); +			MDBG_MOVE("%s", ""); +		} +		else if ((i & 0x1f) == 0) +			MDBG_MORE(" "); +		if (busy(ao_scheme_busy, i)) +			MDBG_MORE("*"); +		else +			MDBG_MORE("-"); +	} +	MDBG_MORE ("\n"); +} +#define DUMP_BUSY()	dump_busy() +#else +#define DUMP_BUSY() +#endif + +static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { +	[AO_SCHEME_CONS] = &ao_scheme_cons_type, +	[AO_SCHEME_INT] = NULL, +	[AO_SCHEME_STRING] = &ao_scheme_string_type, +	[AO_SCHEME_OTHER] = (void *) 0x1, +	[AO_SCHEME_ATOM] = &ao_scheme_atom_type, +	[AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, +	[AO_SCHEME_FRAME] = &ao_scheme_frame_type, +	[AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, +	[AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, +	[AO_SCHEME_STACK] = &ao_scheme_stack_type, +	[AO_SCHEME_BOOL] = &ao_scheme_bool_type, +	[AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, +	[AO_SCHEME_FLOAT] = &ao_scheme_float_type, +}; + +static int +ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) +{ +	return ao_scheme_mark(type, *ref); +} + +static int +ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) +{ +	return ao_scheme_poly_mark(*p, do_note_cons); +} + +#if DBG_MEM_STATS +int ao_scheme_collects[2]; +int ao_scheme_freed[2]; +int ao_scheme_loops[2]; +#endif + +int ao_scheme_last_top; + +int +ao_scheme_collect(uint8_t style) +{ +	int	i; +	int	top; +#if DBG_MEM_STATS +	int	loops = 0; +#endif +#if DBG_MEM +	struct ao_scheme_record	*mark_record = NULL, *move_record = NULL; + +	MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); +#endif +	MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + +	/* The first time through, we're doing a full collect */ +	if (ao_scheme_last_top == 0) +		style = AO_SCHEME_COLLECT_FULL; + +	/* Clear references to all caches */ +	for (i = 0; i < (int) AO_SCHEME_CACHE; i++) +		*ao_scheme_cache[i] = NULL; +	if (style == AO_SCHEME_COLLECT_FULL) { +		chunk_low = top = 0; +	} else { +		chunk_low = top = ao_scheme_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_scheme_mark_ref, ao_scheme_poly_mark_ref); +#if DBG_MEM + +		ao_scheme_record_free(mark_record); +		mark_record = ao_scheme_record_save(); +		if (mark_record && move_record) +			ao_scheme_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_scheme_chunk[i].size; + +#if DBG_MEM +			if (!size) +				ao_scheme_abort(); +#endif + +			if (ao_scheme_chunk[i].old_offset > top) +				break; + +			MDBG_MOVE("chunk %d %d not moving\n", +				  ao_scheme_chunk[i].old_offset, +				  ao_scheme_chunk[i].size); +#if DBG_MEM +			if (ao_scheme_chunk[i].old_offset != top) +				ao_scheme_abort(); +#endif +			top += size; +		} + +		/* +		 * Limit amount of chunk array used in mapping moves +		 * to the active region +		 */ +		chunk_first = i; +		chunk_low = ao_scheme_chunk[i].old_offset; + +		/* Copy all of the objects */ +		for (; i < chunk_last; i++) { +			uint16_t	size = ao_scheme_chunk[i].size; + +#if DBG_MEM +			if (!size) +				ao_scheme_abort(); +#endif + +			MDBG_MOVE("chunk %d %d -> %d\n", +				  ao_scheme_chunk[i].old_offset, +				  size, +				  top); +			ao_scheme_chunk[i].new_offset = top; + +			memmove(&ao_scheme_pool[top], +				&ao_scheme_pool[ao_scheme_chunk[i].old_offset], +				size); + +			top += size; +		} + +		if (chunk_first < chunk_last) { +			/* Relocate all references to the objects */ +			walk(ao_scheme_move, ao_scheme_poly_move); + +#if DBG_MEM +			ao_scheme_record_free(move_record); +			move_record = ao_scheme_record_save(); +			if (mark_record && move_record) +				ao_scheme_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_SCHEME_NCHUNK) +			break; + +		/* Next loop starts right above this loop */ +		chunk_low = chunk_high; +	} + +#if DBG_MEM_STATS +	/* Collect stats */ +	++ao_scheme_collects[style]; +	ao_scheme_freed[style] += ao_scheme_top - top; +	ao_scheme_loops[style] += loops; +#endif + +	ao_scheme_top = top; +	if (style == AO_SCHEME_COLLECT_FULL) +		ao_scheme_last_top = top; + +	MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); +		walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); + +	return AO_SCHEME_POOL - ao_scheme_top; +} + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons) +{ +	ao_poly	cdr; +	int offset; + +	chunk_low = 0; +	reset_chunks(); +	walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +	while (cons) { +		if (!AO_SCHEME_IS_POOL(cons)) +			break; +		offset = pool_offset(cons); +		if (busy(ao_scheme_busy, offset)) { +			ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); +			abort(); +		} +		cdr = cons->cdr; +		if (!ao_scheme_is_pair(cdr)) +			break; +		cons = ao_scheme_poly_cons(cdr); +	} +} +#endif + +/* + * Mark interfaces for objects + */ + + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_scheme_mark_block(void *addr, int size) +{ +	int offset; +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	offset = pool_offset(addr); +	MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); +	if (busy(ao_scheme_busy, offset)) { +		MDBG_MOVE("already marked\n"); +		return 1; +	} +	mark(ao_scheme_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_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) +{ +	int offset; +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	offset = pool_offset(addr); +	MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); +	if (busy(ao_scheme_busy, offset)) { +		MDBG_MOVE("already marked\n"); +		return 1; +	} +	mark(ao_scheme_busy, offset); +	note_chunk(offset, ao_scheme_size(type, addr)); +	return 0; +} + +/* + * Mark an object and all that it refereces + */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr) +{ +	int ret; +	MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); +	MDBG_MOVE_IN(); +	ret = ao_scheme_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_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) +{ +	uint8_t type; +	void	*addr; + +	type = ao_scheme_poly_base_type(p); + +	if (type == AO_SCHEME_INT) +		return 1; + +	addr = ao_scheme_ref(p); +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	if (type == AO_SCHEME_CONS && do_note_cons) { +		note_cons(pool_offset(addr)); +		return 1; +	} else { +		if (type == AO_SCHEME_OTHER) +			type = ao_scheme_other_type(addr); + +		const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM +		if (!lisp_type) +			ao_scheme_abort(); +#endif + +		return ao_scheme_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_scheme_chunk[l].old_offset != offset) +		ao_scheme_abort(); +#endif +	return ao_scheme_chunk[l].new_offset; +} + +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) +{ +	void		*addr = *ref; +	uint16_t	offset, orig_offset; + +	if (!AO_SCHEME_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_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, +			  orig_offset, offset); +		*ref = ao_scheme_pool + offset; +	} +	if (busy(ao_scheme_busy, offset)) { +		MDBG_MOVE("already moved\n"); +		return 1; +	} +	mark(ao_scheme_busy, offset); +	MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); +	return 0; +} + +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref) +{ +	int ret; +	MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); +	MDBG_MOVE_IN(); +	ret = ao_scheme_move_memory(type, ref); +	if (!ret) { +		MDBG_MOVE("move recurse\n"); +		type->move(*ref); +	} +	MDBG_MOVE_OUT(); +	return ret; +} + +int +ao_scheme_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_scheme_poly_base_type(p); + +	if (type == AO_SCHEME_INT) +		return 1; + +	addr = ao_scheme_ref(p); +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	orig_offset = pool_offset(addr); +	offset = move_map(orig_offset); + +	if (type == AO_SCHEME_CONS && do_note_cons) { +		note_cons(orig_offset); +		ret = 1; +	} else { +		if (type == AO_SCHEME_OTHER) +			type = ao_scheme_other_type(ao_scheme_pool + offset); + +		const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM +		if (!lisp_type) +			ao_scheme_abort(); +#endif + +		ret = ao_scheme_move(lisp_type, &addr); +	} + +	/* Re-write the poly value */ +	if (offset != orig_offset) { +		ao_poly np = ao_scheme_poly(ao_scheme_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_scheme_validate(void) +{ +	chunk_low = 0; +	memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); +	walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +} + +int dbg_allocs; + +#endif + +void * +ao_scheme_alloc(int size) +{ +	void	*addr; + +	MDBG_DO(++dbg_allocs); +	MDBG_DO(if (dbg_validate) ao_scheme_validate()); +	size = ao_scheme_size_round(size); +	if (AO_SCHEME_POOL - ao_scheme_top < size && +	    ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && +	    ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) +	{ +		ao_scheme_error(AO_SCHEME_OOM, "out of memory"); +		return NULL; +	} +	addr = ao_scheme_pool + ao_scheme_top; +	ao_scheme_top += size; +	MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); +	return addr; +} + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons) +{ +	assert(save_cons[id] == 0); +	save_cons[id] = cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id) +{ +	struct ao_scheme_cons *cons = save_cons[id]; +	save_cons[id] = NULL; +	return cons; +} + +void +ao_scheme_poly_stash(int id, ao_poly poly) +{ +	assert(save_poly[id] == AO_SCHEME_NIL); +	save_poly[id] = poly; +} + +ao_poly +ao_scheme_poly_fetch(int id) +{ +	ao_poly poly = save_poly[id]; +	save_poly[id] = AO_SCHEME_NIL; +	return poly; +} + +void +ao_scheme_string_stash(int id, char *string) +{ +	assert(save_string[id] == NULL); +	save_string[id] = string; +} + +char * +ao_scheme_string_fetch(int id) +{ +	char *string = save_string[id]; +	save_string[id] = NULL; +	return string; +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) +{ +	assert(save_frame[id] == NULL); +	save_frame[id] = frame; +} + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id) +{ +	struct ao_scheme_frame *frame = save_frame[id]; +	save_frame[id] = NULL; +	return frame; +} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c new file mode 100644 index 00000000..d726321c --- /dev/null +++ b/src/scheme/ao_scheme_poly.c @@ -0,0 +1,118 @@ +/* + * 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_scheme.h" + +struct ao_scheme_funcs { +	void (*write)(ao_poly); +	void (*display)(ao_poly); +}; + +static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { +	[AO_SCHEME_CONS] = { +		.write = ao_scheme_cons_write, +		.display = ao_scheme_cons_display, +	}, +	[AO_SCHEME_STRING] = { +		.write = ao_scheme_string_write, +		.display = ao_scheme_string_display, +	}, +	[AO_SCHEME_INT] = { +		.write = ao_scheme_int_write, +		.display = ao_scheme_int_write, +	}, +	[AO_SCHEME_ATOM] = { +		.write = ao_scheme_atom_write, +		.display = ao_scheme_atom_write, +	}, +	[AO_SCHEME_BUILTIN] = { +		.write = ao_scheme_builtin_write, +		.display = ao_scheme_builtin_write, +	}, +	[AO_SCHEME_FRAME] = { +		.write = ao_scheme_frame_write, +		.display = ao_scheme_frame_write, +	}, +	[AO_SCHEME_FRAME_VALS] = { +		.write = NULL, +		.display = NULL, +	}, +	[AO_SCHEME_LAMBDA] = { +		.write = ao_scheme_lambda_write, +		.display = ao_scheme_lambda_write, +	}, +	[AO_SCHEME_STACK] = { +		.write = ao_scheme_stack_write, +		.display = ao_scheme_stack_write, +	}, +	[AO_SCHEME_BOOL] = { +		.write = ao_scheme_bool_write, +		.display = ao_scheme_bool_write, +	}, +	[AO_SCHEME_BIGINT] = { +		.write = ao_scheme_bigint_write, +		.display = ao_scheme_bigint_write, +	}, +	[AO_SCHEME_FLOAT] = { +		.write = ao_scheme_float_write, +		.display = ao_scheme_float_write, +	}, +}; + +static const struct ao_scheme_funcs * +funcs(ao_poly p) +{ +	uint8_t	type = ao_scheme_poly_type(p); + +	if (type < AO_SCHEME_NUM_TYPE) +		return &ao_scheme_funcs[type]; +	return NULL; +} + +void +ao_scheme_poly_write(ao_poly p) +{ +	const struct ao_scheme_funcs *f = funcs(p); + +	if (f && f->write) +		f->write(p); +} + +void +ao_scheme_poly_display(ao_poly p) +{ +	const struct ao_scheme_funcs *f = funcs(p); + +	if (f && f->display) +		f->display(p); +} + +void * +ao_scheme_ref(ao_poly poly) { +	if (poly == AO_SCHEME_NIL) +		return NULL; +	if (poly & AO_SCHEME_CONST) +		return (void *) (ao_scheme_const + (poly & AO_SCHEME_REF_MASK) - 4); +	return (void *) (ao_scheme_pool + (poly & AO_SCHEME_REF_MASK) - 4); +} + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type) { +	const uint8_t	*a = addr; +	if (a == NULL) +		return AO_SCHEME_NIL; +	if (AO_SCHEME_IS_CONST(a)) +		return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; +	return (a - ao_scheme_pool + 4) | type; +} diff --git a/src/lisp/ao_lisp_read.c b/src/scheme/ao_scheme_read.c index 0ca12a81..6b1e9d66 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/scheme/ao_scheme_read.c @@ -12,8 +12,8 @@   * General Public License for more details.   */ -#include "ao_lisp.h" -#include "ao_lisp_read.h" +#include "ao_scheme.h" +#include "ao_scheme_read.h"  #include <math.h>  #include <stdlib.h> @@ -158,7 +158,7 @@ lex_get()  		c = lex_unget_c;  		lex_unget_c = 0;  	} else { -		c = ao_lisp_getc(); +		c = ao_scheme_getc();  	}  	return c;  } @@ -244,15 +244,15 @@ lex_quoted(void)  	}  } -#define AO_LISP_TOKEN_MAX	32 +#define AO_SCHEME_TOKEN_MAX	32 -static char	token_string[AO_LISP_TOKEN_MAX]; +static char	token_string[AO_SCHEME_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) +	if (c && token_len < AO_SCHEME_TOKEN_MAX - 1)  		token_string[token_len++] = c;  } @@ -372,7 +372,7 @@ _lex(void)  				else if (!strcmp(token_string, "formfeed"))  					token_int = '\f';  				else { -					ao_lisp_error(AO_LISP_INVALID, "invalid character token #\\%s", token_string); +					ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string);  					continue;  				}  				return NUM; @@ -470,9 +470,9 @@ static inline int lex(void)  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; +struct ao_scheme_cons	*ao_scheme_read_cons; +struct ao_scheme_cons	*ao_scheme_read_cons_tail; +struct ao_scheme_cons	*ao_scheme_read_stack;  #define READ_IN_QUOTE	0x01  #define READ_SAW_DOT	0x02 @@ -481,17 +481,17 @@ struct ao_lisp_cons	*ao_lisp_read_stack;  static int  push_read_stack(int cons, int read_state)  { -	RDBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); +	RDBGI("push read stack %p 0x%x\n", ao_scheme_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) +		ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), +						       ao_scheme__cons(ao_scheme_int_poly(read_state), +								     ao_scheme_cons_poly(ao_scheme_read_stack))); +		if (!ao_scheme_read_stack)  			return 0;  	} -	ao_lisp_read_cons = NULL; -	ao_lisp_read_cons_tail = NULL; +	ao_scheme_read_cons = NULL; +	ao_scheme_read_cons_tail = NULL;  	return 1;  } @@ -500,41 +500,41 @@ 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)) +		ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); +		ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); +		read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); +		ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); +		for (ao_scheme_read_cons_tail = ao_scheme_read_cons; +		     ao_scheme_read_cons_tail && ao_scheme_read_cons_tail->cdr; +		     ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr))  			;  	} else { -		ao_lisp_read_cons = 0; -		ao_lisp_read_cons_tail = 0; -		ao_lisp_read_stack = 0; +		ao_scheme_read_cons = 0; +		ao_scheme_read_cons_tail = 0; +		ao_scheme_read_stack = 0;  	}  	RDBG_OUT(); -	RDBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); +	RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state);  	return read_state;  }  ao_poly -ao_lisp_read(void) +ao_scheme_read(void)  { -	struct ao_lisp_atom	*atom; +	struct ao_scheme_atom	*atom;  	char			*string;  	int			cons;  	int			read_state; -	ao_poly			v = AO_LISP_NIL; +	ao_poly			v = AO_SCHEME_NIL;  	cons = 0;  	read_state = 0; -	ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; +	ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0;  	for (;;) {  		parse_token = lex();  		while (parse_token == OPEN) {  			if (!push_read_stack(cons, read_state)) -				return AO_LISP_NIL; +				return AO_SCHEME_NIL;  			cons++;  			read_state = 0;  			parse_token = lex(); @@ -544,75 +544,75 @@ ao_lisp_read(void)  		case END:  		default:  			if (cons) -				ao_lisp_error(AO_LISP_EOF, "unexpected end of file"); -			return _ao_lisp_atom_eof; +				ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); +			return _ao_scheme_atom_eof;  			break;  		case NAME: -			atom = ao_lisp_atom_intern(token_string); +			atom = ao_scheme_atom_intern(token_string);  			if (atom) -				v = ao_lisp_atom_poly(atom); +				v = ao_scheme_atom_poly(atom);  			else -				v = AO_LISP_NIL; +				v = AO_SCHEME_NIL;  			break;  		case NUM: -			v = ao_lisp_integer_poly(token_int); +			v = ao_scheme_integer_poly(token_int);  			break;  		case FLOAT: -			v = ao_lisp_float_get(token_float); +			v = ao_scheme_float_get(token_float);  			break;  		case BOOL:  			if (token_string[0] == 't') -				v = _ao_lisp_bool_true; +				v = _ao_scheme_bool_true;  			else -				v = _ao_lisp_bool_false; +				v = _ao_scheme_bool_false;  			break;  		case STRING: -			string = ao_lisp_string_copy(token_string); +			string = ao_scheme_string_copy(token_string);  			if (string) -				v = ao_lisp_string_poly(string); +				v = ao_scheme_string_poly(string);  			else -				v = AO_LISP_NIL; +				v = AO_SCHEME_NIL;  			break;  		case QUOTE:  		case QUASIQUOTE:  		case UNQUOTE:  		case UNQUOTE_SPLICING:  			if (!push_read_stack(cons, read_state)) -				return AO_LISP_NIL; +				return AO_SCHEME_NIL;  			cons++;  			read_state = READ_IN_QUOTE;  			switch (parse_token) {  			case QUOTE: -				v = _ao_lisp_atom_quote; +				v = _ao_scheme_atom_quote;  				break;  			case QUASIQUOTE: -				v = _ao_lisp_atom_quasiquote; +				v = _ao_scheme_atom_quasiquote;  				break;  			case UNQUOTE: -				v = _ao_lisp_atom_unquote; +				v = _ao_scheme_atom_unquote;  				break;  			case UNQUOTE_SPLICING: -				v = _ao_lisp_atom_unquote2dsplicing; +				v = _ao_scheme_atom_unquote2dsplicing;  				break;  			}  			break;  		case CLOSE:  			if (!cons) { -				v = AO_LISP_NIL; +				v = AO_SCHEME_NIL;  				break;  			} -			v = ao_lisp_cons_poly(ao_lisp_read_cons); +			v = ao_scheme_cons_poly(ao_scheme_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; +				ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); +				return AO_SCHEME_NIL;  			} -			if (!ao_lisp_read_cons) { -				ao_lisp_error(AO_LISP_INVALID, ". first in cons"); -				return AO_LISP_NIL; +			if (!ao_scheme_read_cons) { +				ao_scheme_error(AO_SCHEME_INVALID, ". first in cons"); +				return AO_SCHEME_NIL;  			}  			read_state |= READ_SAW_DOT;  			continue; @@ -624,29 +624,29 @@ ao_lisp_read(void)  				return v;  			if (read_state & READ_DONE_DOT) { -				ao_lisp_error(AO_LISP_INVALID, ". not last in cons"); -				return AO_LISP_NIL; +				ao_scheme_error(AO_SCHEME_INVALID, ". not last in cons"); +				return AO_SCHEME_NIL;  			}  			if (read_state & READ_SAW_DOT) {  				read_state |= READ_DONE_DOT; -				ao_lisp_read_cons_tail->cdr = v; +				ao_scheme_read_cons_tail->cdr = v;  			} else { -				struct ao_lisp_cons	*read = ao_lisp_cons_cons(v, AO_LISP_NIL); +				struct ao_scheme_cons	*read = ao_scheme_cons_cons(v, AO_SCHEME_NIL);  				if (!read) -					return AO_LISP_NIL; +					return AO_SCHEME_NIL; -				if (ao_lisp_read_cons_tail) -					ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); +				if (ao_scheme_read_cons_tail) +					ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read);  				else -					ao_lisp_read_cons = read; -				ao_lisp_read_cons_tail = read; +					ao_scheme_read_cons = read; +				ao_scheme_read_cons_tail = read;  			} -			if (!(read_state & READ_IN_QUOTE) || !ao_lisp_read_cons->cdr) +			if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr)  				break; -			v = ao_lisp_cons_poly(ao_lisp_read_cons); +			v = ao_scheme_cons_poly(ao_scheme_read_cons);  			--cons;  			read_state = pop_read_stack(cons);  		} diff --git a/src/lisp/ao_lisp_read.h b/src/scheme/ao_scheme_read.h index 8f6bf130..e9508835 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/scheme/ao_scheme_read.h @@ -12,8 +12,8 @@   * General Public License for more details.   */ -#ifndef _AO_LISP_READ_H_ -#define _AO_LISP_READ_H_ +#ifndef _AO_SCHEME_READ_H_ +#define _AO_SCHEME_READ_H_  /*   * token classes @@ -55,4 +55,4 @@  # define INTEGER	(DIGIT|SIGN)  # define NUMBER		(INTEGER|FLOATC) -#endif /* _AO_LISP_READ_H_ */ +#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/scheme/ao_scheme_rep.c index 43cc387f..9dbce5f2 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/scheme/ao_scheme_rep.c @@ -12,23 +12,23 @@   * General Public License for more details.   */ -#include "ao_lisp.h" +#include "ao_scheme.h"  ao_poly -ao_lisp_read_eval_print(void) +ao_scheme_read_eval_print(void)  { -	ao_poly	in, out = AO_LISP_NIL; +	ao_poly	in, out = AO_SCHEME_NIL;  	for(;;) { -		in = ao_lisp_read(); -		if (in == _ao_lisp_atom_eof) +		in = ao_scheme_read(); +		if (in == _ao_scheme_atom_eof)  			break; -		out = ao_lisp_eval(in); -		if (ao_lisp_exception) { -			if (ao_lisp_exception & AO_LISP_EXIT) +		out = ao_scheme_eval(in); +		if (ao_scheme_exception) { +			if (ao_scheme_exception & AO_SCHEME_EXIT)  				break; -			ao_lisp_exception = 0; +			ao_scheme_exception = 0;  		} else { -			ao_lisp_poly_write(out); +			ao_scheme_poly_write(out);  			putchar ('\n');  		}  	} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c new file mode 100644 index 00000000..af9345b8 --- /dev/null +++ b/src/scheme/ao_scheme_save.c @@ -0,0 +1,77 @@ +/* + * 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_scheme.h" + +ao_poly +ao_scheme_do_save(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) +		return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE +	struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + +	ao_scheme_collect(AO_SCHEME_COLLECT_FULL); +	os->atoms = ao_scheme_atom_poly(ao_scheme_atoms); +	os->globals = ao_scheme_frame_poly(ao_scheme_frame_global); +	os->const_checksum = ao_scheme_const_checksum; +	os->const_checksum_inv = (uint16_t) ~ao_scheme_const_checksum; + +	if (ao_scheme_os_save()) +		return _ao_scheme_bool_true; +#endif +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_restore(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) +		return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE +	struct ao_scheme_os_save save; +	struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + +	if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) +		return ao_scheme_error(AO_SCHEME_INVALID, "header restore failed"); + +	if (save.const_checksum != ao_scheme_const_checksum || +	    save.const_checksum_inv != (uint16_t) ~ao_scheme_const_checksum) +	{ +		return ao_scheme_error(AO_SCHEME_INVALID, "image is corrupted or stale"); +	} + +	if (ao_scheme_os_restore()) { + +		ao_scheme_atoms = ao_scheme_poly_atom(os->atoms); +		ao_scheme_frame_global = ao_scheme_poly_frame(os->globals); + +		/* Clear the eval global variabls */ +		ao_scheme_eval_clear_globals(); + +		/* Reset the allocator */ +		ao_scheme_top = AO_SCHEME_POOL; +		ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + +		/* Re-create the evaluator stack */ +		if (!ao_scheme_eval_restart()) +			return _ao_scheme_bool_false; + +		return _ao_scheme_bool_true; +	} +#endif +	return _ao_scheme_bool_false; +} diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c new file mode 100644 index 00000000..d19dd6d6 --- /dev/null +++ b/src/scheme/ao_scheme_stack.c @@ -0,0 +1,280 @@ +/* + * 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_scheme.h" + +const struct ao_scheme_type ao_scheme_stack_type; + +static int +stack_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_stack); +} + +static void +stack_mark(void *addr) +{ +	struct ao_scheme_stack	*stack = addr; +	for (;;) { +		ao_scheme_poly_mark(stack->sexprs, 0); +		ao_scheme_poly_mark(stack->values, 0); +		/* no need to mark values_tail */ +		ao_scheme_poly_mark(stack->frame, 0); +		ao_scheme_poly_mark(stack->list, 0); +		stack = ao_scheme_poly_stack(stack->prev); +		if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) +			break; +	} +} + +static void +stack_move(void *addr) +{ +	struct ao_scheme_stack	*stack = addr; + +	while (stack) { +		struct ao_scheme_stack	*prev; +		int			ret; +		(void) ao_scheme_poly_move(&stack->sexprs, 0); +		(void) ao_scheme_poly_move(&stack->values, 0); +		(void) ao_scheme_poly_move(&stack->values_tail, 0); +		(void) ao_scheme_poly_move(&stack->frame, 0); +		(void) ao_scheme_poly_move(&stack->list, 0); +		prev = ao_scheme_poly_stack(stack->prev); +		if (!prev) +			break; +		ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); +		if (prev != ao_scheme_poly_stack(stack->prev)) +			stack->prev = ao_scheme_stack_poly(prev); +		if (ret) +			break; +		stack = prev; +	} +} + +const struct ao_scheme_type ao_scheme_stack_type = { +	.size = stack_size, +	.mark = stack_mark, +	.move = stack_move, +	.name = "stack" +}; + +struct ao_scheme_stack		*ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack) +{ +	stack->state = eval_sexpr; +	stack->sexprs = AO_SCHEME_NIL; +	stack->values = AO_SCHEME_NIL; +	stack->values_tail = AO_SCHEME_NIL; +} + +static struct ao_scheme_stack * +ao_scheme_stack_new(void) +{ +	struct ao_scheme_stack *stack; + +	if (ao_scheme_stack_free_list) { +		stack = ao_scheme_stack_free_list; +		ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); +	} else { +		stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); +		if (!stack) +			return 0; +		stack->type = AO_SCHEME_STACK; +	} +	ao_scheme_stack_reset(stack); +	return stack; +} + +int +ao_scheme_stack_push(void) +{ +	struct ao_scheme_stack	*stack; + +	stack = ao_scheme_stack_new(); + +	if (!stack) +		return 0; + +	stack->prev = ao_scheme_stack_poly(ao_scheme_stack); +	stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); +	stack->list = AO_SCHEME_NIL; + +	ao_scheme_stack = stack; + +	DBGI("stack push\n"); +	DBG_FRAMES(); +	DBG_IN(); +	return 1; +} + +void +ao_scheme_stack_pop(void) +{ +	ao_poly			prev; +	struct ao_scheme_frame	*prev_frame; + +	if (!ao_scheme_stack) +		return; +	prev = ao_scheme_stack->prev; +	if (!ao_scheme_stack_marked(ao_scheme_stack)) { +		ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); +		ao_scheme_stack_free_list = ao_scheme_stack; +	} + +	ao_scheme_stack = ao_scheme_poly_stack(prev); +	prev_frame = ao_scheme_frame_current; +	if (ao_scheme_stack) +		ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); +	else +		ao_scheme_frame_current = NULL; +	if (ao_scheme_frame_current != prev_frame) +		ao_scheme_frame_free(prev_frame); +	DBG_OUT(); +	DBGI("stack pop\n"); +	DBG_FRAMES(); +} + +void +ao_scheme_stack_clear(void) +{ +	ao_scheme_stack = NULL; +	ao_scheme_frame_current = NULL; +	ao_scheme_v = AO_SCHEME_NIL; +} + +void +ao_scheme_stack_write(ao_poly poly) +{ +	struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + +	while (s) { +		if (s->type & AO_SCHEME_STACK_PRINT) { +			printf("[recurse...]"); +			return; +		} +		s->type |= AO_SCHEME_STACK_PRINT; +		printf("\t[\n"); +		printf("\t\texpr:   "); ao_scheme_poly_write(s->list); printf("\n"); +		printf("\t\tstate:  %s\n", ao_scheme_state_names[s->state]); +		ao_scheme_error_poly ("values: ", s->values, s->values_tail); +		ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); +		ao_scheme_error_frame(2, "frame:  ", ao_scheme_poly_frame(s->frame)); +		printf("\t]\n"); +		s->type &= ~AO_SCHEME_STACK_PRINT; +		s = ao_scheme_poly_stack(s->prev); +	} +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_scheme_stack * +ao_scheme_stack_copy(struct ao_scheme_stack *old) +{ +	struct ao_scheme_stack *new = NULL; +	struct ao_scheme_stack *n, *prev = NULL; + +	while (old) { +		ao_scheme_stack_stash(0, old); +		ao_scheme_stack_stash(1, new); +		ao_scheme_stack_stash(2, prev); +		n = ao_scheme_stack_new(); +		prev = ao_scheme_stack_fetch(2); +		new = ao_scheme_stack_fetch(1); +		old = ao_scheme_stack_fetch(0); +		if (!n) +			return NULL; + +		ao_scheme_stack_mark(old); +		ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); +		*n = *old; + +		if (prev) +			prev->prev = ao_scheme_stack_poly(n); +		else +			new = n; +		prev = n; + +		old = ao_scheme_poly_stack(old->prev); +	} +	return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_scheme_stack_eval(void) +{ +	struct ao_scheme_stack	*new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); +	if (!new) +		return AO_SCHEME_NIL; + +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_stack->values); + +	if (!cons || !cons->cdr) +		return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); + +	new->state = eval_val; + +	ao_scheme_stack = new; +	ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + +	return ao_scheme_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_scheme_do_call_cc(struct ao_scheme_cons *cons) +{ +	struct ao_scheme_stack	*new; +	ao_poly			v; + +	/* Make sure the single parameter is a lambda */ +	if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0)) +		return AO_SCHEME_NIL; + +	/* go get the lambda */ +	ao_scheme_v = ao_scheme_arg(cons, 0); + +	/* Note that the whole call chain now has +	 * a reference to it which may escape +	 */ +	new = ao_scheme_stack_copy(ao_scheme_stack); +	if (!new) +		return AO_SCHEME_NIL; + +	/* re-fetch cons after the allocation */ +	cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); + +	/* Reset the arg list to the current stack, +	 * and call the lambda +	 */ + +	cons->car = ao_scheme_stack_poly(new); +	cons->cdr = AO_SCHEME_NIL; +	v = ao_scheme_lambda_eval(); +	ao_scheme_stack->sexprs = v; +	ao_scheme_stack->state = eval_begin; +	return AO_SCHEME_NIL; +} diff --git a/src/lisp/ao_lisp_string.c b/src/scheme/ao_scheme_string.c index 1daa50ea..e25306cb 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/scheme/ao_scheme_string.c @@ -15,7 +15,7 @@   * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.   */ -#include "ao_lisp.h" +#include "ao_scheme.h"  static void string_mark(void *addr)  { @@ -34,7 +34,7 @@ static void string_move(void *addr)  	(void) addr;  } -const struct ao_lisp_type ao_lisp_string_type = { +const struct ao_scheme_type ao_scheme_string_type = {  	.mark = string_mark,  	.size = string_size,  	.move = string_move, @@ -42,13 +42,13 @@ const struct ao_lisp_type ao_lisp_string_type = {  };  char * -ao_lisp_string_copy(char *a) +ao_scheme_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); +	ao_scheme_string_stash(0, a); +	char	*r = ao_scheme_alloc(alen + 1); +	a = ao_scheme_string_fetch(0);  	if (!r)  		return NULL;  	strcpy(r, a); @@ -56,16 +56,16 @@ ao_lisp_string_copy(char *a)  }  char * -ao_lisp_string_cat(char *a, char *b) +ao_scheme_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); +	ao_scheme_string_stash(0, a); +	ao_scheme_string_stash(1, b); +	char	*r = ao_scheme_alloc(alen + blen + 1); +	a = ao_scheme_string_fetch(0); +	b = ao_scheme_string_fetch(1);  	if (!r)  		return NULL;  	strcpy(r, a); @@ -74,57 +74,57 @@ ao_lisp_string_cat(char *a, char *b)  }  ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons) +ao_scheme_string_pack(struct ao_scheme_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); +	int	len = ao_scheme_cons_length(cons); +	ao_scheme_cons_stash(0, cons); +	char	*r = ao_scheme_alloc(len + 1); +	cons = ao_scheme_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); +		if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) +			return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); +		*s++ = ao_scheme_poly_integer(cons->car); +		cons = ao_scheme_poly_cons(cons->cdr);  	}  	*s++ = 0; -	return ao_lisp_string_poly(r); +	return ao_scheme_string_poly(r);  }  ao_poly -ao_lisp_string_unpack(char *a) +ao_scheme_string_unpack(char *a)  { -	struct ao_lisp_cons	*cons = NULL, *tail = NULL; +	struct ao_scheme_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); +		ao_scheme_cons_stash(0, cons); +		ao_scheme_cons_stash(1, tail); +		ao_scheme_string_stash(0, a); +		struct ao_scheme_cons	*n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); +		a = ao_scheme_string_fetch(0); +		cons = ao_scheme_cons_fetch(0); +		tail = ao_scheme_cons_fetch(1);  		if (!n) {  			cons = NULL;  			break;  		}  		if (tail) -			tail->cdr = ao_lisp_cons_poly(n); +			tail->cdr = ao_scheme_cons_poly(n);  		else  			cons = n;  		tail = n;  	} -	return ao_lisp_cons_poly(cons); +	return ao_scheme_cons_poly(cons);  }  void -ao_lisp_string_write(ao_poly p) +ao_scheme_string_write(ao_poly p)  { -	char	*s = ao_lisp_poly_string(p); +	char	*s = ao_scheme_poly_string(p);  	char	c;  	putchar('"'); @@ -151,9 +151,9 @@ ao_lisp_string_write(ao_poly p)  }  void -ao_lisp_string_display(ao_poly p) +ao_scheme_string_display(ao_poly p)  { -	char	*s = ao_lisp_poly_string(p); +	char	*s = ao_scheme_poly_string(p);  	char	c;  	while ((c = *s++)) diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore new file mode 100644 index 00000000..bcd57242 --- /dev/null +++ b/src/scheme/make-const/.gitignore @@ -0,0 +1 @@ +ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile new file mode 100644 index 00000000..caf7acbe --- /dev/null +++ b/src/scheme/make-const/Makefile @@ -0,0 +1,26 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +SRCS=$(SCHEME_SRCS) ao_scheme_make_const.c +HDRS=$(SCHEME_HDRS) ao_scheme_os.h + +OBJS=$(SRCS:.c=.o) + +CC=cc +CFLAGS=-DAO_SCHEME_MAKE_CONST -O0 -g -I. -Wall -Wextra + +.c.o: +	$(CC) -c $(CFLAGS) $< -o $@ + +all: ao_scheme_make_const + +ao_scheme_make_const: $(OBJS) +	$(CC) $(CFLAGS) -o $@ $^ -lm + +clean: +	rm -f $(OBJS) ao_scheme_make_const + +$(OBJS): $(SCHEME_HDRS) diff --git a/src/lisp/ao_lisp_os.h b/src/scheme/make-const/ao_scheme_os.h index 4285cb8c..f06bbbb1 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/scheme/make-const/ao_scheme_os.h @@ -15,49 +15,49 @@   * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.   */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_  #include <stdio.h>  #include <stdlib.h>  #include <time.h> -extern int ao_lisp_getc(void); +extern int ao_scheme_getc(void);  static inline void -ao_lisp_os_flush(void) { +ao_scheme_os_flush(void) {  	fflush(stdout);  }  static inline void -ao_lisp_abort(void) +ao_scheme_abort(void)  {  	abort();  }  static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led)  {  	printf("leds set to 0x%x\n", led);  } -#define AO_LISP_JIFFIES_PER_SECOND	100 +#define AO_SCHEME_JIFFIES_PER_SECOND	100  static inline void -ao_lisp_os_delay(int jiffies) +ao_scheme_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) +		.tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, +		.tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)  	};  	nanosleep(&ts, NULL);  }  static inline int -ao_lisp_os_jiffy(void) +ao_scheme_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)); +	return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND));  }  #endif diff --git a/src/test/ao_lisp_os.h b/src/test/ao_scheme_os.h index ebd16bb4..ebd16bb4 100644 --- a/src/test/ao_lisp_os.h +++ b/src/test/ao_scheme_os.h diff --git a/src/test/ao_lisp_test.c b/src/test/ao_scheme_test.c index 68e3a202..68e3a202 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_scheme_test.c | 
