diff options
| author | Keith Packard <keithp@keithp.com> | 2018-01-10 23:11:40 -0800 | 
|---|---|---|
| committer | Keith Packard <keithp@keithp.com> | 2018-01-10 23:11:40 -0800 | 
| commit | f26cc1a677f577da533425a15485fcaa24626b23 (patch) | |
| tree | 2f1e96addf6af39a9013acc76409f9df74a5e561 /src | |
| parent | 4b52fc6eea9a478cb3dd42dcd32c92838df39734 (diff) | |
altos/scheme: Move ao-scheme to a separate repository
This way it can be incorporated into multiple operating systems more easily.
Signed-off-by: Keith Packard <keithp@keithp.com>
Diffstat (limited to 'src')
55 files changed, 8 insertions, 12315 deletions
| diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 9d30c521..33c68cf5 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -5,10 +5,9 @@  include ../stmf0/Makefile.defs -include ../scheme/Makefile-inc +aoschemelib=$(shell pkg-config --variable=aoschemelib ao-scheme) -vpath %.scheme ../scheme -vpath ao_scheme_make_const ../scheme/make-const +include $(aoschemelib)/Makefile-scheme  NEWLIB_FULL=-lm -lc -lgcc @@ -54,7 +53,7 @@ MAP=$(PROG).map  NEWLIB=/local/newlib-mini  MAPFILE=-Wl,-Map=$(MAP)  LDFLAGS=-L../stmf0 -L$(NEWLIB)/arm-none-eabi/lib/thumb/v6-m/ -Wl,-Tlambda.ld $(MAPFILE) -nostartfiles -AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB +AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I$(aoschemelib) -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB  PROGNAME=lambdakey-v1.0  PROG=$(PROGNAME)-$(VERSION).elf @@ -63,6 +62,9 @@ HEX=$(PROGNAME)-$(VERSION).ihx  SRC=$(ALTOS_SRC) ao_lambdakey.c  OBJ=$(SRC:.c=.o) +bletch: +	echo lib is $(aoschemelib) +  all: $(PROG) $(HEX)  $(PROG): Makefile $(OBJ) lambda.ld @@ -73,7 +75,7 @@ $(OBJ): $(INC)  ao_product.h: ao-make-product.5c ../Version  	$(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ -ao_scheme_const.h: ao_scheme_make_const ao_scheme_basic_syntax.scheme +ao_scheme_const.h: ao-scheme-make-const ao_scheme_basic_syntax.scheme  	$^ -o $@ -d FLOAT,VECTOR,QUASI,BIGINT,POSIX,PORT,SAVE,UNDEF  load: $(PROG) diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore deleted file mode 100644 index ee72cb9d..00000000 --- a/src/scheme/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -ao_scheme_const.h -ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile deleted file mode 100644 index be312754..00000000 --- a/src/scheme/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -all: ao_scheme_builtin.h make-const/ao_scheme_make_const test/ao-scheme tiny-test/ao-scheme-tiny - -clean: -	+cd make-const && make clean -	+cd test && make clean -	+cd tiny-test && make clean -	rm -f ao_scheme_builtin.h - -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 ao_scheme_builtin.h -	+cd make-const && make ao_scheme_make_const - -test/ao-scheme: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const -	+cd test && make - -tiny-test/ao-scheme-tiny: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const -	+cd tiny-test && make - -install: all -	+cd test && make install -	+cd tiny-test && make install - -FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc deleted file mode 100644 index ed3f7f5f..00000000 --- a/src/scheme/Makefile-inc +++ /dev/null @@ -1,35 +0,0 @@ -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 \ -	ao_scheme_vector.c \ -	ao_scheme_port.c - -SCHEME_HDRS=\ -	ao_scheme.h \ -	ao_scheme_os.h \ -	ao_scheme_read.h \ -	ao_scheme_builtin.h - -SCHEME_SCHEME=\ -	ao_scheme_basic_syntax.scheme \ -	ao_scheme_advanced_syntax.scheme \ -	ao_scheme_vector.scheme \ -	ao_scheme_string.scheme \ -	ao_scheme_char.scheme \ -	ao_scheme_port.scheme \ -	ao_scheme_finish.scheme diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme deleted file mode 100644 index b9018e19..00000000 --- a/src/scheme/Makefile-scheme +++ /dev/null @@ -1,4 +0,0 @@ -include ../scheme/Makefile-inc - -ao_scheme_const.h: $(SCHEME_SRCS) $(SCHEME_HDRS) -	+cd ../scheme && make $@ diff --git a/src/scheme/README b/src/scheme/README deleted file mode 100644 index a18457fd..00000000 --- a/src/scheme/README +++ /dev/null @@ -1,10 +0,0 @@ -This follows the R7RS with the following known exceptions: - -* No vectors or bytevectors -* Characters are just numbers -* No dynamic-wind or exceptions -* No environments -* No ports -* No syntax-rules -* No record types -* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h deleted file mode 100644 index 9ce239a6..00000000 --- a/src/scheme/ao_scheme.h +++ /dev/null @@ -1,1207 +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_SCHEME_H_ -#define _AO_SCHEME_H_ - -#ifndef DBG_MEM -#define DBG_MEM		0 -#endif -#ifndef DBG_EVAL -#define DBG_EVAL	0 -#endif -#ifndef DBG_READ -#define DBG_READ	0 -#endif -#ifndef DBG_FREE_CONS -#define DBG_FREE_CONS	0 -#endif -#define NDEBUG		1 - -#include <stdint.h> -#include <string.h> -#include <stdbool.h> -#include <ao_scheme_os.h> -#define AO_SCHEME_BUILTIN_FEATURES -#include "ao_scheme_builtin.h" -#undef AO_SCHEME_BUILTIN_FEATURES -#ifndef __BYTE_ORDER -#include <endian.h> -#endif - -typedef uint16_t	ao_poly; -typedef int16_t		ao_signed_poly; - -#ifdef AO_SCHEME_MAKE_CONST -#define AO_SCHEME_POOL_CONST	32764 -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((char *) 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" - -#ifdef AO_SCHEME_FEATURE_SAVE - -struct ao_scheme_os_save { -	ao_poly		atoms; -	ao_poly		globals; -	uint16_t	const_checksum; -	uint16_t	const_checksum_inv; -}; - -#ifndef AO_SCHEME_POOL_TOTAL -#error Must define AO_SCHEME_POOL_TOTAL for AO_SCHEME_FEATURE_SAVE -#endif - -#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 /* AO_SCHEME_FEATURE_SAVE */ - -#ifndef AO_SCHEME_POOL -#error Must define AO_SCHEME_POOL -#endif -#ifndef AO_SCHEME_POOL_EXTRA -#define AO_SCHEME_POOL_EXTRA 0 -#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_BIGINT	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_STRING	11 -#ifdef AO_SCHEME_FEATURE_FLOAT -#define AO_SCHEME_FLOAT		12 -#define _AO_SCHEME_FLOAT	AO_SCHEME_FLOAT -#else -#define _AO_SCHEME_FLOAT	12 -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR -#define AO_SCHEME_VECTOR	13 -#define _AO_SCHEME_VECTOR	AO_SCHEME_VECTOR -#else -#define _AO_SCHEME_VECTOR	_AO_SCHEME_FLOAT -#endif -#ifdef AO_SCHEME_FEATURE_PORT -#define AO_SCHEME_PORT		14 -#define _AO_SCHEME_PORT		AO_SCHEME_PORT -#else -#define _AO_SCHEME_PORT		_AO_SCHEME_VECTOR -#endif -#define AO_SCHEME_NUM_TYPE	(_AO_SCHEME_PORT+1) - -/* 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_FILEERROR		0x40 -#define AO_SCHEME_EXIT			0x80 - -extern uint8_t		ao_scheme_exception; - -static inline int -ao_scheme_is_const(ao_poly poly) { -	return poly & AO_SCHEME_CONST; -} - -static inline int -ao_scheme_is_const_addr(const void *addr) { -	const uint8_t *a = addr; -	return (ao_scheme_const <= a) && (a < ao_scheme_const + AO_SCHEME_POOL_CONST); -} - -static inline int -ao_scheme_is_pool_addr(const void *addr) { -	const uint8_t *a = addr; -	return (ao_scheme_pool <= a) && (a < ao_scheme_pool + AO_SCHEME_POOL); -} - -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_string { -	uint8_t		type; -	char		val[]; -}; - -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; -}; - - -#ifdef AO_SCHEME_FEATURE_FLOAT -struct ao_scheme_float { -	uint8_t			type; -	uint8_t			pad1; -	uint16_t		pad2; -	float			value; -}; -#endif - -#ifdef AO_SCHEME_FEATURE_VECTOR -struct ao_scheme_vector { -	uint8_t			type; -	uint8_t			pad1; -	uint16_t		length; -	ao_poly			vals[]; -}; -#endif - -#ifdef AO_SCHEME_FEATURE_PORT -struct ao_scheme_port { -	uint8_t			type; -	uint8_t			stayopen; -	ao_poly			next; -	FILE			*file; -}; -#endif - -#define AO_SCHEME_MIN_INT	(-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) -#define AO_SCHEME_MAX_INT	((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) - -#ifdef AO_SCHEME_FEATURE_BIGINT - -struct ao_scheme_bigint { -	uint32_t		value; -}; - -#define AO_SCHEME_MIN_BIGINT	INT32_MIN -#define AO_SCHEME_MAX_BIGINT	INT32_MAX - -#endif	/* AO_SCHEME_FEATURE_BIGINT */ - -/* Set on type when the frame escapes the lambda */ -#define AO_SCHEME_FRAME_MARK	0x80 - -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 */ - -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; -} - -#ifdef AO_SCHEME_FEATURE_BIGINT -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_BIGINT); -} -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -static inline struct ao_scheme_string * -ao_scheme_poly_string(ao_poly poly) -{ -	return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_string_poly(struct ao_scheme_string *s) -{ -	return ao_scheme_poly(s, AO_SCHEME_OTHER); -} - -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); -} - -#ifdef AO_SCHEME_FEATURE_FLOAT -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); -#endif - -#ifdef AO_SCHEME_FEATURE_VECTOR -static inline ao_poly -ao_scheme_vector_poly(struct ao_scheme_vector *v) -{ -	return ao_scheme_poly(v, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_vector * -ao_scheme_poly_vector(ao_poly poly) -{ -	return ao_scheme_ref(poly); -} -#endif - -#ifdef AO_SCHEME_FEATURE_PORT -static inline ao_poly -ao_scheme_port_poly(struct ao_scheme_port *v) -{ -	return ao_scheme_poly(v, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_port * -ao_scheme_poly_port(ao_poly poly) -{ -	return ao_scheme_ref(poly); -} - -extern ao_poly	ao_scheme_stdin, ao_scheme_stdout, ao_scheme_stderr; - -#endif - -/* memory functions */ - -extern uint64_t ao_scheme_collects[2]; -extern uint64_t ao_scheme_freed[2]; -extern uint64_t ao_scheme_loops[2]; - -/* returns 1 if the object was already marked */ -int -ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); - -/* returns 1 if the object is marked */ -int -ao_scheme_marked(void *addr); - -/* 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); - -/* Marks an object as being printed, returns 1 if it was already marked */ -int -ao_scheme_print_mark_addr(void *addr); - -void -ao_scheme_print_clear_addr(void *addr); - -/* Notes that printing has started */ -void -ao_scheme_print_start(void); - -/* Notes that printing has ended, returns 1 if printing is still happening */ -int -ao_scheme_print_stop(void); - -#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_poly_stash(ao_poly poly); - -ao_poly -ao_scheme_poly_fetch(void); - -static inline void -ao_scheme_cons_stash(struct ao_scheme_cons *cons) { -	ao_scheme_poly_stash(ao_scheme_cons_poly(cons)); -} - -static inline struct ao_scheme_cons * -ao_scheme_cons_fetch(void) { -	return ao_scheme_poly_cons(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_atom_stash(struct ao_scheme_atom *atom) { -	ao_scheme_poly_stash(ao_scheme_atom_poly(atom)); -} - -static inline struct ao_scheme_atom * -ao_scheme_atom_fetch(void) { -	return ao_scheme_poly_atom(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_string_stash(struct ao_scheme_string *string) { -	ao_scheme_poly_stash(ao_scheme_string_poly(string)); -} - -static inline struct ao_scheme_string * -ao_scheme_string_fetch(void) { -	return ao_scheme_poly_string(ao_scheme_poly_fetch()); -} - -#ifdef AO_SCHEME_FEATURE_VECTOR -static inline void -ao_scheme_vector_stash(struct ao_scheme_vector *vector) { -	ao_scheme_poly_stash(ao_scheme_vector_poly(vector)); -} - -static inline struct ao_scheme_vector * -ao_scheme_vector_fetch(void) { -	return ao_scheme_poly_vector(ao_scheme_poly_fetch()); -} -#endif - -#ifdef AO_SCHEME_FEATURE_PORT -static inline void -ao_scheme_port_stash(struct ao_scheme_port *port) { -	ao_scheme_poly_stash(ao_scheme_port_poly(port)); -} - -static inline struct ao_scheme_port * -ao_scheme_port_fetch(void) { -	return ao_scheme_poly_port(ao_scheme_poly_fetch()); -} -#endif - -static inline void -ao_scheme_stack_stash(struct ao_scheme_stack *stack) { -	ao_scheme_poly_stash(ao_scheme_stack_poly(stack)); -} - -static inline struct ao_scheme_stack * -ao_scheme_stack_fetch(void) { -	return ao_scheme_poly_stack(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_frame_stash(struct ao_scheme_frame *frame) { -	ao_scheme_poly_stash(ao_scheme_frame_poly(frame)); -} - -static inline struct ao_scheme_frame * -ao_scheme_frame_fetch(void) { -	return ao_scheme_poly_frame(ao_scheme_poly_fetch()); -} - -/* bool */ - -extern const struct ao_scheme_type ao_scheme_bool_type; - -void -ao_scheme_bool_write(FILE *out, ao_poly v, bool write); - -#ifdef AO_SCHEME_MAKE_CONST -extern 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(FILE *out, ao_poly, bool write); - -int -ao_scheme_cons_length(struct ao_scheme_cons *cons); - -/* string */ -extern const struct ao_scheme_type ao_scheme_string_type; - -struct ao_scheme_string * -ao_scheme_string_new(char *a); - -struct ao_scheme_string * -ao_scheme_atom_to_string(struct ao_scheme_atom *a); - -struct ao_scheme_string * -ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b); - -void -ao_scheme_string_write(FILE *out, ao_poly s, bool write); - -/* 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(FILE *out, ao_poly a, bool write); - -struct ao_scheme_atom * -ao_scheme_string_to_atom(struct ao_scheme_string *string); - -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name); - -void -ao_scheme_atom_check_references(void); - -void -ao_scheme_atom_move(void); - -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_def(ao_poly atom, ao_poly val); - -/* int */ -void -ao_scheme_int_write(FILE *out, ao_poly i, bool write); - -#ifdef AO_SCHEME_FEATURE_BIGINT -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(FILE *out, ao_poly i, bool write); - -extern const struct ao_scheme_type	ao_scheme_bigint_type; - -#else - -static inline int32_t ao_scheme_poly_integer(ao_poly poly) { -	return ao_scheme_poly_int(poly); -} - -static inline ao_poly ao_scheme_integer_poly(int32_t i) { -	return ao_scheme_int_poly(i); -} - -static inline int -ao_scheme_integer_typep(uint8_t t) -{ -	return (t == AO_SCHEME_INT); -} - -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -/* vector */ - -#ifdef AO_SCHEME_FEATURE_VECTOR - -void -ao_scheme_vector_write(FILE *OUT, ao_poly v, bool write); - -struct ao_scheme_vector * -ao_scheme_vector_alloc(uint16_t length, ao_poly fill); - -struct ao_scheme_vector * -ao_scheme_list_to_vector(struct ao_scheme_cons *cons); - -struct ao_scheme_cons * -ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end); - -extern const struct ao_scheme_type	ao_scheme_vector_type; - -#endif /* AO_SCHEME_FEATURE_VECTOR */ - -/* port */ - -#ifdef AO_SCHEME_FEATURE_PORT - -void -ao_scheme_port_write(FILE *out, ao_poly v, bool write); - -struct ao_scheme_port * -ao_scheme_port_alloc(FILE *file, bool stayopen); - -void -ao_scheme_port_close(struct ao_scheme_port *port); - -void -ao_scheme_port_check_references(void); - -extern ao_poly ao_scheme_open_ports; - -static inline int -ao_scheme_port_getc(struct ao_scheme_port *port) -{ -	if (port->file) -		return getc(port->file); -	return EOF; -} - -static inline int -ao_scheme_port_putc(struct ao_scheme_port *port, char c) -{ -	if (port->file) -		return putc(c, port->file); -	return EOF; -} - -static inline int -ao_scheme_port_ungetc(struct ao_scheme_port *port, char c) -{ -	if (port->file) -		return ungetc(c, port->file); -	return EOF; -} - -extern const struct ao_scheme_type	ao_scheme_port_type; - -#endif /* AO_SCHEME_FEATURE_PORT */ - -#ifdef AO_SCHEME_FEATURE_POSIX - -void -ao_scheme_set_argv(char **argv); - -#endif - -/* prim */ -void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write); - -static inline void -ao_scheme_poly_write(FILE *out, ao_poly p, bool write) { (*ao_scheme_poly_write_func(p))(out, p, write); } - -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 */ - -#ifdef AO_SCHEME_FEATURE_SAVE -void -ao_scheme_eval_clear_globals(void); - -int -ao_scheme_eval_restart(void); -#endif - -ao_poly -ao_scheme_eval(ao_poly p); - -ao_poly -ao_scheme_set_cond(struct ao_scheme_cons *cons); - -/* float */ -#ifdef AO_SCHEME_FEATURE_FLOAT -extern const struct ao_scheme_type ao_scheme_float_type; - -void -ao_scheme_float_write(FILE *out, ao_poly p, bool write); - -ao_poly -ao_scheme_float_get(float value); -#endif - -#ifdef AO_SCHEME_FEATURE_FLOAT -static inline bool -ao_scheme_number_typep(uint8_t t) -{ -	return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); -} -#else -#define ao_scheme_number_typep ao_scheme_integer_typep -#endif - -static inline bool -ao_scheme_is_integer(ao_poly poly) { -	return ao_scheme_integer_typep(ao_scheme_poly_base_type(poly)); -} - -static inline bool -ao_scheme_is_number(ao_poly poly) { -	return ao_scheme_number_typep(ao_scheme_poly_type(poly)); -} - -/* builtin */ -void -ao_scheme_builtin_write(FILE *out, ao_poly b, bool write); - -ao_poly -ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons); - -extern const struct ao_scheme_type ao_scheme_builtin_type; - -#define AO_SCHEME_ARG_OPTIONAL	0x100 -#define AO_SCHEME_ARG_NIL_OK	0x200 -#define AO_SCHEME_ARG_RET_POLY	0x400 -#define AO_SCHEME_ARG_END	-1 -#define AO_SCHEME_POLY		0xff -#define AO_SCHEME_ARG_MASK	0xff - -int -ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...); - -/* 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 int			ao_scheme_read_list; -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(FILE *in); - -/* rep */ -ao_poly -ao_scheme_read_eval_print(FILE *read_file, FILE *write_file, bool interactive); - -/* 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); - -#ifdef AO_SCHEME_FEATURE_UNDEF -ao_poly -ao_scheme_frame_del(struct ao_scheme_frame *frame, ao_poly atom); -#endif - -void -ao_scheme_frame_write(FILE *out, ao_poly p, bool write); - -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(FILE *out, ao_poly lambda, bool write); - -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; - -extern int			ao_scheme_frame_print_indent; - -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_write(FILE *out, ao_poly stack, bool write); - -ao_poly -ao_scheme_stack_eval(void); - -/* error */ - -void -ao_scheme_vfprintf(FILE *out, const char *format, va_list args); - -void -ao_scheme_fprintf(FILE *out, const char *format, ...); - -ao_poly -ao_scheme_error(int error, const char *format, ...); - -/* builtins */ - -#define AO_SCHEME_BUILTIN_DECLS -#include "ao_scheme_builtin.h" - -/* debugging macros */ - -#if DBG_EVAL || DBG_READ -int ao_scheme_stack_depth; -#endif - -#if DBG_EVAL -#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_fprintf(stdout, __VA_ARGS__) -#define DBGI(...)	do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a)	ao_scheme_cons_write(stdout, ao_scheme_cons_poly(a), true) -#define DBG_POLY(a)	ao_scheme_poly_write(stdout, a, true) -#define OFFSET(a)	((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) -#define DBG_STACK()	ao_scheme_stack_write(stdout, ao_scheme_stack_poly(ao_scheme_stack), true) -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(...)	do { printf("%4d: ", __LINE__); DBG_INDENT(); ao_scheme_printf(__VA_ARGS__); } while (0) -#define RDBG_IN()	(++ao_scheme_stack_depth) -#define RDBG_OUT()	(--ao_scheme_stack_depth) -#else -#define RDBGI(...) -#define RDBG_IN() -#define RDBG_OUT() -#endif - -static inline int -ao_scheme_mdbg_offset(void *a) -{ -	uint8_t		*u = a; - -	if (u == 0) -		return -1; - -	if (ao_scheme_pool <= u && u < ao_scheme_pool + AO_SCHEME_POOL) -		return u - ao_scheme_pool; - -#ifndef AO_SCHEME_MAKE_CONST -	if (ao_scheme_const <= u && u < ao_scheme_const + AO_SCHEME_POOL_CONST) -		return - (int) (u - ao_scheme_const); -#endif -	return -2; -} - -#define MDBG_OFFSET(a)	ao_scheme_mdbg_offset(a) - -#if DBG_MEM - -#define DBG_MEM_START	1 - -#include <assert.h> -extern int dbg_move_depth; -#define MDBG_DUMP 1 - -extern int dbg_mem; - -#define MDBG_DO(a)	a -#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf ("  "); printf(__VA_ARGS__); } } while (0) -#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) -#define MDBG_MOVE_IN()	(dbg_move_depth++) -#define MDBG_MOVE_OUT()	(--dbg_move_depth) - -#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_advanced_syntax.scheme b/src/scheme/ao_scheme_advanced_syntax.scheme deleted file mode 100644 index 4cddc803..00000000 --- a/src/scheme/ao_scheme_advanced_syntax.scheme +++ /dev/null @@ -1,388 +0,0 @@ -; -; Copyright © 2018 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. -; -; Advanced syntax, including vectors and floats - -(begin -  (def! equal? -    (lambda (a b) -      (cond ((eq? a b) #t) -	    ((and (pair? a) (pair? b)) -	     (and (equal? (car a) (car b)) -		  (equal? (cdr a) (cdr b))) -	     ) -	    ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b))) -	     ((lambda (i l) -		(while (and (< i l) -			    (equal? (vector-ref a i) -				    (vector-ref b i))) -		       (set! i (+ i 1))) -		(eq? i l) -		) -	      0 -	      (vector-length a) -	      ) -	     ) -	    (else #f) -	    ) -      ) -    ) -  'equal? -  ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) -(equal? #(1 2 3) #(1 2 3)) -(equal? #(1 2 3) #(4 5 6)) - -(define quasiquote -  (macro (x) -    (define (constant? exp) -					; A constant value is either a pair starting with quote, -					; or anything which is neither a pair nor a symbol - -      (cond ((pair? exp) -	     (eq? (car exp) 'quote) -	     ) -	    (else -	     (not (symbol? exp)) -	     ) -	    ) -      ) - -    (define (combine-skeletons left right exp) -      (cond -       ((and (constant? left) (constant? right))  -	(cond ((and (eqv? (eval left) (car exp)) -		    (eqv? (eval right) (cdr exp))) -	       (list 'quote exp) -	       ) -	      (else -	       (list 'quote (cons (eval left) (eval right))) -	       ) -	      ) -	) -       ((null? right) -	(list 'list left) -	) -       ((and (pair? right) (eq? (car right) 'list)) -	(cons 'list (cons left (cdr right))) -	) -       (else -	(list 'cons left right) -	) -       ) -      ) - -    (define (expand-quasiquote exp nesting) -      (cond - -					; non cons -- constants -					; themselves, others are -					; quoted - -       ((not (pair? exp))  -	(cond ((constant? exp) -	       exp -	       ) -	      (else -	       (list 'quote exp) -	       ) -	      ) -	) - -					; check for an unquote exp and -					; add the param unquoted - -       ((and (eq? (car exp) 'unquote) (= (length exp) 2)) -	(cond ((= nesting 0) -	       (car (cdr exp)) -	       ) -	      (else -	       (combine-skeletons ''unquote  -				  (expand-quasiquote (cdr exp) (- nesting 1)) -				  exp)) -	      ) -	) - -					; nested quasi-quote -- -					; construct the right -					; expression - -       ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) -	(combine-skeletons ''quasiquote  -			   (expand-quasiquote (cdr exp) (+ nesting 1)) -			   exp)) - -					; check for an -					; unquote-splicing member, -					; compute the expansion of the -					; value and append the rest of -					; the quasiquote result to it - -       ((and (pair? (car exp)) -	     (eq? (car (car exp)) 'unquote-splicing) -	     (= (length (car exp)) 2)) -	(cond ((= nesting 0) -	       (list 'append (car (cdr (car exp))) -		     (expand-quasiquote (cdr exp) nesting)) -	       ) -	      (else -	       (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) -				  (expand-quasiquote (cdr exp) nesting) -				  exp)) -	      ) -	) - -					; for other lists, just glue -					; the expansion of the first -					; element to the expansion of -					; the rest of the list - -       (else (combine-skeletons (expand-quasiquote (car exp) nesting) -				(expand-quasiquote (cdr exp) nesting) -				exp) -	     ) -       ) -      ) -    (expand-quasiquote x 0) -    ) -  ) - -					; `q -> (quote q) -					; `(q) -> (append (quote (q))) -					; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) -					; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) - -					; define a set of local -					; variables all at once and -					; then evaluate a list of -					; sexprs -					; -					; (let (var-defines) sexprs) -					; -					; where var-defines are either -					; -					; (name value) -					; -					; or -					; -					; (name) -					; -					; e.g. -					; -					; (let ((x 1) (y)) (set! y (+ x 1)) y) - -(define let -  (macro (vars . exprs) -	 (define (make-names vars) -	   (cond ((not (null? vars)) -		  (cons (car (car vars)) -			(make-names (cdr vars)))) -		 (else ()) -		 ) -	   ) - -					; the parameters to the lambda is a list -					; of nils of the right length - -	 (define (make-vals vars) -	   (cond ((not (null? vars)) -		  (cons (cond ((null? (cdr (car vars))) ()) -			      (else -			       (car (cdr (car vars)))) -			      ) -			(make-vals (cdr vars)))) -		 (else ()) -		 ) -	   ) -					; prepend the set operations -					; to the expressions - -					; build the lambda. - -	 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) -	 ) -     ) -		    - -(let ((x 1) (y)) (set! y 2) (+ x y)) - -(define assv assq) - -(assv 'b '((a 1) (b 2) (c 3))) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(when #t (+ 1 2)) -(when #f (+ 1 2)) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(unless #f (+ 2 3)) -(unless #t (+ 2 3)) - -(define (cdar l) (cdr (car l))) - -(cdar '((1 2) (3 4))) - -(define (cddr l) (cdr (cdr l))) - -(cddr '(1 2 3)) - -(define (caddr l) (car (cdr (cdr l)))) - -(caddr '(1 2 3 4)) - -(define (reverse list) -  (define (_r old new) -    (if (null? old) -	new -	(_r (cdr old) (cons (car old) new)) -	) -    ) -  (_r list ()) -  ) - -(reverse '(1 2 3)) - -(define make-list -  (lambda (a . b) -    (define (_m a x) -      (if (zero? a) -	  x -	  (_m (- a 1) (cons b x)) -	  ) -      ) -    (if (null? b) -	(set! b #f) -	(set! b (car b)) -	) -    (_m a '()) -    ) -  ) -     -(make-list 10 'a) - -(make-list 10) - -(define for-each -  (lambda (proc . lists) -    (define (_f lists) -      (cond ((null? (car lists)) #t) -	    (else -	     (apply proc (map car lists)) -	     (_f (map cdr lists)) -	     ) -	    ) -      ) -    (_f lists) -    ) -  ) - -(let ((a 0)) -  (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) -  a -  ) -       -(call-with-current-continuation -       (lambda (exit) -	 (for-each (lambda (x) -		     (if (negative? x) -			 (exit x))) -		   '(54 0 37 -3 245 19)) -	 #t)) - -(define case -  (macro (test . l) -					; construct the body of the -					; case, dealing with the -					; lambda version ( => lambda) - -	 (define (_unarrow l) -	   (cond ((null? l) l) -		 ((eq? (car l) '=>) `(( ,(cadr l) __key__))) -		 (else l)) -	   ) - -					; Build the case elements, which is -					; simply a list of cond clauses - -	 (define (_case l) - -	   (cond ((null? l) ()) - -					; else case - -		 ((eq? (caar l) 'else) -		  `((else ,@(_unarrow (cdr (car l)))))) - -					; regular case -		  -		 (else -		  (cons -		   `((eqv? ,(caar l) __key__) -		     ,@(_unarrow (cdr (car l)))) -		   (_case (cdr l))) -		  ) -		 ) -	   ) - -					; now construct the overall -					; expression, using a lambda -					; to hold the computed value -					; of the test expression - -	 `((lambda (__key__) -	     (cond ,@(_case l))) ,test) -	 ) -  ) - -(case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) -(case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) -(case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) -(case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) - -(define do -  (macro (vars test . cmds) -    (define (_step v) -      (if (null? v) -	  '() -	  (if (null? (cddr (car v))) -	      (_step (cdr v)) -	      (cons `(set! ,(caar v) ,(caddr (car v))) -		    (_step (cdr v)) -		    ) -	      ) -	  ) -      ) -    `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) -       (while (not ,(car test)) -	      ,@cmds -	      ,@(_step vars) -	      ) -       ,@(cdr test) -       ) -    ) -  ) - -(do ((x 1 (+ x 1)) -     (y 0) -     ) -    ((= x 10) y) -  (set! y (+ y x)) -  ) diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c deleted file mode 100644 index 2a568ed9..00000000 --- a/src/scheme/ao_scheme_atom.c +++ /dev/null @@ -1,298 +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_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) -{ -	MDBG_MOVE("mark atom %s\n", ((struct ao_scheme_atom *) addr)->name); -	(void) addr; -} - -static void atom_move(void *addr) -{ -	(void) addr; -} - -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; - -static struct ao_scheme_atom * -ao_scheme_atom_find(const char *name) -{ -	struct ao_scheme_atom	*atom; - -#ifdef ao_builtin_atoms -	if (!ao_scheme_atoms) -		ao_scheme_atoms = ao_scheme_poly_atom(ao_builtin_atoms); -#endif -	for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { -		if (!strcmp(atom->name, name)) -			return atom; -	} -	return NULL; -} - -#ifdef AO_SCHEME_MAKE_CONST - -#define AO_SCHEME_BUILTIN_SYNTAX_ATOMS -#include "ao_scheme_builtin.h" -#undef AO_SCHEME_BUILTIN_SYNTAX_ATOMS - -static void -ao_scheme_atom_mark_syntax(void) -{ -	unsigned	a; -	for (a = 0; a < sizeof(syntax_atoms)/sizeof(syntax_atoms[0]); a++) { -		struct ao_scheme_atom *atom = ao_scheme_atom_find(syntax_atoms[a]); -		if (atom) -			ao_scheme_mark_memory(&ao_scheme_atom_type, atom); -	} -} - -#else -#define ao_scheme_atom_mark_syntax() -#endif - -void -ao_scheme_atom_move(void) -{ -	struct ao_scheme_atom	*atom; -	ao_scheme_move_memory(&ao_scheme_atom_type, (void **) (void *) &ao_scheme_atoms); -	for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { -		if (!ao_scheme_is_pool_addr(atom)) { -			MDBG_DO(printf("atom out of pool %s\n", atom->name)); -			break; -		} -		MDBG_DO(printf("move atom %s\n", atom->name)); -		ao_scheme_poly_move(&atom->next, 0); -	} -} - -void -ao_scheme_atom_check_references(void) -{ -	struct ao_scheme_atom	*atom; -	ao_poly			*prev = NULL; - -	ao_scheme_atom_mark_syntax(); -	for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { -		if (!ao_scheme_marked(atom)) { -			MDBG_DO(printf("unreferenced atom %s\n", atom->name)); -			if (prev) -				*prev = atom->next; -			else -				ao_scheme_atoms = ao_scheme_poly_atom(atom->next); -		} else -			prev = &atom->next; -	} -} - -static void -ao_scheme_atom_init(struct ao_scheme_atom *atom, char *name) -{ -	if (atom) { -		atom->type = AO_SCHEME_ATOM; -		strcpy(atom->name, name); -		atom->next = ao_scheme_atom_poly(ao_scheme_atoms); -		ao_scheme_atoms = atom; -	} -} - -struct ao_scheme_atom * -ao_scheme_string_to_atom(struct ao_scheme_string *string) -{ -	struct ao_scheme_atom	*atom = ao_scheme_atom_find(string->val); - -	if (atom) -		return atom; -	ao_scheme_string_stash(string); -	atom = ao_scheme_alloc(name_size(string->val)); -	string = ao_scheme_string_fetch(); -	ao_scheme_atom_init(atom, string->val); -	return atom; -} - -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name) -{ -	struct ao_scheme_atom	*atom = ao_scheme_atom_find(name); -	if (atom) -		return atom; - -	atom = ao_scheme_alloc(name_size(name)); -	ao_scheme_atom_init(atom, 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_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(FILE *out, ao_poly a, bool write) -{ -	struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); -	(void) write; -	fprintf(out, "%s", atom->name); -} - -ao_poly -ao_scheme_do_symbolp(struct ao_scheme_cons *cons) -{ -	return ao_scheme_do_typep(_ao_scheme_atom_symbol3f, AO_SCHEME_ATOM, cons); -} - -ao_poly -ao_scheme_do_set(struct ao_scheme_cons *cons) -{ -	ao_poly	atom; -	ao_poly val; -	ao_poly *ref; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, -				  AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; - -	ref = ao_scheme_atom_ref(atom, NULL); - -	if (!ref) -		return ao_scheme_error(AO_SCHEME_UNDEFINED, "%v: undefined atom %v", -				       _ao_scheme_atom_set, atom); -	*ref = val; -	return val; -} - -ao_poly -ao_scheme_do_def(struct ao_scheme_cons *cons) -{ -	ao_poly	atom; -	ao_poly	val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, -				  AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_atom_def(atom, val); -} - -ao_poly -ao_scheme_do_setq(struct ao_scheme_cons *cons) -{ -	ao_poly	atom; -	ao_poly	val; -	ao_poly	p; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_set21, cons, -				  AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (!ao_scheme_atom_ref(atom, NULL)) -		return ao_scheme_error(AO_SCHEME_INVALID, "%v: symbol %v not defined", -				       _ao_scheme_atom_set21, atom); -	/* -	 * Build the macro return -- `(set (quote ,atom) ,val) -	 */ -	ao_scheme_poly_stash(cons->cdr); -	p = ao_scheme_cons(atom, AO_SCHEME_NIL); -	p = ao_scheme_cons(_ao_scheme_atom_quote, p); -	p = ao_scheme_cons(p, ao_scheme_poly_fetch()); -	return ao_scheme_cons(_ao_scheme_atom_set, p); -} - -#ifdef AO_SCHEME_FEATURE_UNDEF -ao_poly -ao_scheme_do_undef(struct ao_scheme_cons *cons) -{ -	ao_poly	atom; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, -				  AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_frame_del(ao_scheme_frame_global, atom); -} -#endif diff --git a/src/scheme/ao_scheme_basic_syntax.scheme b/src/scheme/ao_scheme_basic_syntax.scheme deleted file mode 100644 index 4cd3e167..00000000 --- a/src/scheme/ao_scheme_basic_syntax.scheme +++ /dev/null @@ -1,414 +0,0 @@ -; -; Copyright © 2018 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. -; -; Basic syntax placed in ROM - -(def (quote list) (lambda l l)) - -(def (quote def!) -     (macro (a b) -	    (list -	     def -	     (list quote a) -	     b) -	    ) -     ) - -(begin - (def! append -   (lambda a -	  (def! _a -	    (lambda (a b) -	      (cond ((null? a) b) -		    (else (cons (car a) (_a (cdr a) b))) -		    ) -	      ) -	    ) -	     -	  (def! _b -	    (lambda (l) -	      (cond ((null? l) l) -		    ((null? (cdr l)) (car l)) -		    (else (_a (car l) (_b (cdr l)))) -		    ) -	      ) -	    ) -	  (_b a) -	  ) -   ) - 'append) - -(append '(a) '(b)) - - -					; -					; Define a variable without returning the value -					; Useful when defining functions to avoid -					; having lots of output generated. -					; -					; Also accepts the alternate -					; form for defining lambdas of -					; (define (name x y z) sexprs ...)  -					; - -(begin - (def! define -   (macro (a . b) -					; check for alternate lambda definition form - -	  (cond ((pair? a) -		 (set! b -		       (cons -			lambda -			(cons (cdr a) b))) -		 (set! a (car a)) -		 ) -		(else -		 (set! b (car b)) -		 ) -		) -	  (cons begin -		(cons -		 (cons def -		       (cons (cons quote (cons a '())) -			     (cons b '()) -			     ) -		       ) -		 (cons -		  (cons quote (cons a '())) -		  '()) -		 ) -		) -	  ) -   ) - 'define - ) -					; boolean operators - -(define or -  (macro a -    (def! b -      (lambda (a) -	(cond ((null? a) #f) -	      ((null? (cdr a)) -	       (car a)) -	      (else -	       (list -		cond -		(list -		 (car a)) -		(list -		 'else -		 (b (cdr a)) -		 ) -		) -	       ) -	      ) -	) -      ) -    (b a))) - -					; execute to resolve macros - -(or #f #t) - -(define and -  (macro a -    (def! b -      (lambda (a) -	(cond ((null? a) #t) -	      ((null? (cdr a)) -	       (car a)) -	      (else -	       (list -		cond -		(list -		 (car a) -		 (b (cdr a)) -		 ) -		) -	       ) -	      ) -	) -      ) -    (b a) -    ) -  ) - -					; execute to resolve macros - -(and #t #f) - -					; (if <condition> <if-true>) -					; (if <condition> <if-true> <if-false) - -(define if -  (macro (a . b) -    (cond ((null? (cdr b)) -	   (list cond (list a (car b))) -		) -	  (else -	   (list cond -		 (list a (car b)) -		 (list 'else (car (cdr b))) -		 ) -	   ) -	  ) -    ) -  ) - -(if (> 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - -(define letrec -  (macro (a . b) - -					; -					; make the list of names in the let -					; - -	 (define (_a a) -	   (cond ((not (null? a)) -		  (cons (car (car a)) -			(_a (cdr a)))) -		 (else ()) -		 ) -	   ) - -					; the set of expressions is -					; the list of set expressions -					; pre-pended to the -					; expressions to evaluate - -	 (define (_b a b) -	   (cond ((null? a) b) -		 (else -		  (cons -		   (list set -			 (list quote -			       (car (car a)) -			       ) -			 (cond ((null? (cdr (car a))) -				() -				) -			       (else -				(car (cdr (car a))) -				) -			       ) -			 ) -		   (_b (cdr a) b) -		   ) -		  ) -		 ) -	   ) - -					; the parameters to the lambda is a list -					; of nils of the right length - -	 (define (_c a) -	   (cond ((null? a) ()) -		 (else (cons () (_c (cdr a)))) -		 ) -	   ) -					; build the lambda. - -	 (cons (cons lambda (cons (_a a) (_b a b))) (_c a)) -	 ) -     ) - -(letrec ((a 1) (b a)) (+ a b)) - -					; letrec is sufficient for let* - -(define let* letrec) - -					; use letrec for let in basic -					; syntax - -(define let letrec) - -					; Basic recursive -					; equality. Replaced with -					; vector-capable version in -					; advanced syntax - -(define (equal? a b) -  (cond ((eq? a b) #t) -	((pair? a) -	 (cond ((pair? b) -		(cond ((equal? (car a) (car b)) -		       (equal? (cdr a) (cdr b))) -		      ) -		) -	       ) -	 ) -	) -  ) - -(equal? '(a b c) '(a b c)) - -					; basic list accessors - -(define (caar a) (car (car a))) - -(define (cadr a) (car (cdr a))) - -(define (list-ref a b) -  (car (list-tail a b)) -  ) - -(list-ref '(1 2 3) 2) - -(define (member a b . t?) -  (cond ((null? b) -	 #f -	 ) -	(else -	 (if (null? t?) (set! t? equal?) (set! t? (car t?))) -	 (if (t? a (car b)) -	     b -	     (member a (cdr b) t?)) -	 ) -	) -  ) - -(member '(2) '((1) (2) (3))) -(member '(4) '((1) (2) (3))) - -(define (memq a b) (member a b eq?)) - -(memq 2 '(1 2 3)) -(memq 4 '(1 2 3)) -(memq '(2) '((1) (2) (3))) - -(define (assoc a b . t?) -  (if (null? t?) -      (set! t? equal?) -      (set! t? (car t?)) -      ) -  (if (null? b) -      #f -    (if (t? a (caar b)) -	(car b) -      (assoc a (cdr b) t?) -      ) -    ) -  ) - -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define (assq a b) (assoc a b eq?)) - -(assq 'a '((a 1) (b 2) (c 3))) - -(define map -  (lambda (proc . lists) -	 (define (_a lists) -	   (cond ((null? lists) ()) -		 (else -		  (cons (caar lists) (_a (cdr lists))) -		  ) -		 ) -	   ) -	 (define (_n lists) -	   (cond ((null? lists) ()) -		 (else -		  (cons (cdr (car lists)) (_n (cdr lists))) -		  ) -		 ) -	   ) -	 (define (_m lists) -	   (cond ((null? (car lists)) ()) -		 (else -		  (cons (apply proc (_a lists)) (_m (_n lists))) -		  ) -		 ) -	   ) -	 (_m lists) -	 ) -  ) - -(map cadr '((a b) (d e) (g h))) - -					; use map as for-each in basic -					; mode - -(define for-each map) -					; simple math operators - -(define zero? (macro (value) (list eq? value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) (list > value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) (list < value 0))) - -(negative? 12) -(negative? -12) - -(define (abs a) (if (>= a 0) a (- a))) - -(abs 12) -(abs -12) - -(define max (lambda (a . b) -		   (while (not (null? b)) -		     (cond ((< a (car b)) -			    (set! a (car b))) -			   ) -		     (set! b (cdr b)) -		     ) -		   a) -  ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (a . b) -		   (while (not (null? b)) -		     (cond ((> a (car b)) -			    (set! a (car b))) -			   ) -		     (set! b (cdr b)) -		     ) -		   a) -  ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? a) (zero? (% a 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? a) (not (even? a))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - -(define (newline) (write-char #\newline)) - -(newline) diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c deleted file mode 100644 index 05109fb9..00000000 --- a/src/scheme/ao_scheme_bool.c +++ /dev/null @@ -1,80 +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_scheme.h" - -static void bool_mark(void *addr) -{ -	(void) addr; -} - -static int bool_size(void *addr) -{ -	(void) addr; -	return sizeof (struct ao_scheme_bool); -} - -static void bool_move(void *addr) -{ -	(void) addr; -} - -const struct ao_scheme_type ao_scheme_bool_type = { -	.mark = bool_mark, -	.size = bool_size, -	.move = bool_move, -	.name = "bool" -}; - -void -ao_scheme_bool_write(FILE *out, ao_poly v, bool write) -{ -	struct ao_scheme_bool	*b = ao_scheme_poly_bool(v); - -	(void) write; -	if (b->value) -		fprintf(out, "#t"); -	else -		fprintf(out, "#f"); -} - -ao_poly -ao_scheme_do_booleanp(struct ao_scheme_cons *cons) -{ -	return ao_scheme_do_typep(_ao_scheme_atom_boolean3f, AO_SCHEME_BOOL, cons); -} - -#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) -{ -	struct ao_scheme_bool	**b; - -	if (value) -		b = &ao_scheme_true; -	else -		b = &ao_scheme_false; - -	if (!*b) { -		*b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); -		(*b)->type = AO_SCHEME_BOOL; -		(*b)->value = value; -	} -	return *b; -} - -#endif diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c deleted file mode 100644 index 2b0c394b..00000000 --- a/src/scheme/ao_scheme_builtin.c +++ /dev/null @@ -1,1008 +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 _GNU_SOURCE -#include "ao_scheme.h" -#include <limits.h> -#include <math.h> -#include <stdarg.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 (char *) "???"; -	} -} -#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 (char *) "???"; -} - -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 (char *) "(unknown)"; -} -#endif - -void -ao_scheme_builtin_write(FILE *out, ao_poly b, bool write) -{ -	struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); -	(void) write; -	fputs(ao_scheme_builtin_name(builtin->func), out); -} - -static bool -ao_scheme_typecheck(ao_poly actual, int formal_type) { -	int	actual_type; - -	if ((formal_type & AO_SCHEME_ARG_MASK) == AO_SCHEME_POLY) -		return true; - -	/* allow nil? */ -	if (actual == AO_SCHEME_NIL) -		return (formal_type & AO_SCHEME_ARG_NIL_OK) != 0; - -	actual_type = ao_scheme_poly_type(actual); -	formal_type &= AO_SCHEME_ARG_MASK; - -	if (actual_type == formal_type) -		return true; -	if (actual_type == AO_SCHEME_BUILTIN && formal_type == AO_SCHEME_LAMBDA) -		return true; - -#ifdef AO_SCHEME_FEATURE_BIGINT -	if (ao_scheme_integer_typep(actual_type) && formal_type == AO_SCHEME_INT) -		return true; -#endif -#ifdef AO_SCHEME_FEATURE_FLOAT -	if (ao_scheme_number_typep(actual_type) && formal_type == AO_SCHEME_FLOAT) -		return true; -#endif -	return false; -} - -int -ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...) -{ -	va_list	ap; -	int formal; -	int argc = 0; -	ao_poly car; - -	va_start(ap, cons); -	while ((formal = va_arg(ap, int)) != AO_SCHEME_ARG_END) { -		if (formal & AO_SCHEME_ARG_OPTIONAL) -			car = (ao_poly) va_arg(ap, int); -		if (cons) { -			car = cons->car; -			cons = ao_scheme_cons_cdr(cons); -			if (!ao_scheme_typecheck(car, formal)) { -				ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); -				return 0; -			} -		} else if (!(formal & AO_SCHEME_ARG_OPTIONAL)) { -			goto bad_args; -		} -		if (formal & AO_SCHEME_ARG_RET_POLY) -			formal = AO_SCHEME_POLY; - -		switch (formal & AO_SCHEME_ARG_MASK) { -		case AO_SCHEME_INT: -#ifdef AO_SCHEME_FEATURE_BIGINT -		case AO_SCHEME_BIGINT: -#endif -			*(va_arg(ap, int32_t *)) = ao_scheme_poly_integer(car); -			break; -#ifdef AO_SCHEME_FEATURE_FLOAT -		case AO_SCHEME_FLOAT: -			*(va_arg(ap, float *)) = ao_scheme_poly_number(car); -			break; -#endif -		case AO_SCHEME_POLY: -			*(va_arg(ap, ao_poly *)) = car; -			break; -		default: -			*(va_arg(ap, void **)) = ao_scheme_ref(car); -			break; -		} -		argc++; -	} -	if (cons) { -	bad_args: -		ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid arg count", name); -		return 0; -	} -	return 1; -} - -ao_poly -ao_scheme_arg(struct ao_scheme_cons *cons, int argc) -{ -	for (;;) { -		if (!cons) -			return AO_SCHEME_NIL; -		if (argc == 0) -			return cons->car; -		cons = ao_scheme_cons_cdr(cons); -		argc--; -	} -} - -ao_poly -ao_scheme_do_quote(struct ao_scheme_cons *cons) -{ -	ao_poly	val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_quote, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return val; -} - -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; -} - -static ao_poly -ao_scheme_do_display_or_write(ao_poly proc, struct ao_scheme_cons *cons, bool write) -{ -#ifndef AO_SCHEME_FEATURE_PORT -	ao_poly	val; -	ao_poly	port; - -	if (!ao_scheme_parse_args(proc, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_POLY | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	ao_scheme_poly_write(stdout, val, write); -#else -	ao_poly			val; -	struct ao_scheme_port	*port; -	FILE			*file = stdout; - -	if (!ao_scheme_parse_args(proc, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_PORT | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (port) { -		file = port->file; -		if (!file) -			return _ao_scheme_bool_true; -	} -	ao_scheme_poly_write(file, val, write); -#endif -	return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_write(struct ao_scheme_cons *cons) -{ -	return ao_scheme_do_display_or_write(_ao_scheme_atom_write, cons, true); -} - -ao_poly -ao_scheme_do_display(struct ao_scheme_cons *cons) -{ -	return ao_scheme_do_display_or_write(_ao_scheme_atom_display, cons, false); -} - -static ao_poly -ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) -{ -	struct ao_scheme_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; -			ao_scheme_cons_stash(cons); -			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)); -#ifdef AO_SCHEME_FEATURE_FLOAT -					else if (ct == AO_SCHEME_FLOAT) -						ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); -#endif -					break; -				case builtin_divide: -					if (ao_scheme_poly_integer(ret) == 1) { -					} else { -#ifdef AO_SCHEME_FEATURE_FLOAT -						if (ao_scheme_number_typep(ct)) { -							float	v = ao_scheme_poly_number(ret); -							ret = ao_scheme_float_get(1/v); -						} -#else -						ret = ao_scheme_integer_poly(0); -#endif -					} -					break; -				default: -					break; -				} -			} -			cons = ao_scheme_cons_fetch(); -		} 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); -#ifdef AO_SCHEME_FEATURE_FLOAT -			int64_t t; -#endif - -			switch(op) { -			case builtin_plus: -				r += c; -			check_overflow: -#ifdef AO_SCHEME_FEATURE_FLOAT -				if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) -					goto inexact; -#endif -				break; -			case builtin_minus: -				r -= c; -				goto check_overflow; -				break; -			case builtin_times: -#ifdef AO_SCHEME_FEATURE_FLOAT -				t = (int64_t) r * (int64_t) c; -				if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) -					goto inexact; -				r = (int32_t) t; -#else -				r = r * c; -#endif -				break; -			case builtin_divide: -#ifdef AO_SCHEME_FEATURE_FLOAT -				if (c != 0 && (r % c) == 0) -					r /= c; -				else -					goto inexact; -#else -				r /= c; -#endif -				break; -			case builtin_quotient: -				if (c == 0) -					return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); -				r = r / c; -				break; -			case builtin_floor_quotient: -				if (c == 0) -					return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "floor-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; -			} -			ao_scheme_cons_stash(cons); -			ret = ao_scheme_integer_poly(r); -			cons = ao_scheme_cons_fetch(); -#ifdef AO_SCHEME_FEATURE_FLOAT -		} 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_floor_quotient: -			case builtin_remainder: -			case builtin_modulo: -				return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); -			default: -				break; -			} -			ao_scheme_cons_stash(cons); -			ret = ao_scheme_float_get(r); -			cons = ao_scheme_cons_fetch(); -#endif -		} -		else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { -			ao_scheme_cons_stash(cons); -			ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), -									 ao_scheme_poly_string(car))); -			cons = ao_scheme_cons_fetch(); -			if (!ret) -				return ret; -		} -		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_floor_quotient(struct ao_scheme_cons *cons) -{ -	return ao_scheme_math(cons, builtin_floor_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); -} - -static 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 && left == right) { -			; -		} 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; -				case builtin_equal: -					if (!(l == r)) -						return _ao_scheme_bool_false; -				default: -					break; -				} -#ifdef AO_SCHEME_FEATURE_FLOAT -			} else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) { -				float l, r; - -				l = ao_scheme_poly_number(left); -				r = ao_scheme_poly_number(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; -				case builtin_equal: -					if (!(l == r)) -						return _ao_scheme_bool_false; -				default: -					break; -				} -#endif /* AO_SCHEME_FEATURE_FLOAT */ -			} else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { -				int c = strcmp(ao_scheme_poly_string(left)->val, -					       ao_scheme_poly_string(right)->val); -				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; -				case builtin_equal: -					if (!(c == 0)) -						return _ao_scheme_bool_false; -					break; -				default: -					break; -				} -			} else -				return _ao_scheme_bool_false; -		} -		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_flush_output(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_FEATURE_PORT -	ao_poly	port; -	if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, -				  AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	fflush(stdout); -#else -	struct ao_scheme_port	*port; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, -				  AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	fflush(stdout); -	if (port) { -		if (port->file) -			fflush(port->file); -	} else -		fflush(stdout); -#endif -	return _ao_scheme_bool_true; -} - -#ifdef AO_SCHEME_FEATURE_GPIO - -ao_poly -ao_scheme_do_led(struct ao_scheme_cons *cons) -{ -	int32_t led; -	if (!ao_scheme_parse_args(_ao_scheme_atom_led, cons, -				  AO_SCHEME_INT, &led, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	ao_scheme_os_led(led); -	return _ao_scheme_bool_true; -} - -#endif - -ao_poly -ao_scheme_do_eval(struct ao_scheme_cons *cons) -{ -	ao_poly	expr; -	ao_poly	env; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_eval, cons, -				  AO_SCHEME_POLY, &expr, -				  AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &env, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	ao_scheme_stack->state = eval_sexpr; -	ao_scheme_stack->frame = AO_SCHEME_NIL; -	ao_scheme_frame_current = NULL; -	return expr; -} - -ao_poly -ao_scheme_do_apply(struct ao_scheme_cons *cons) -{ -	ao_scheme_stack->state = eval_apply; -	return ao_scheme_cons_poly(cons); -} - -ao_poly -ao_scheme_do_read(struct ao_scheme_cons *cons) -{ -	FILE	*file = stdin; -#ifndef AO_SCHEME_FEATURE_PORT -	ao_poly	port; -	if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, -				  AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -#else -	struct ao_scheme_port	*port; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, -				  AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (port) { -		file = port->file; -		if (!file) -			return _ao_scheme_atom_eof; -	} -#endif -	return ao_scheme_read(file); -} - -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_integer_poly(free); -} - -ao_poly -ao_scheme_do_nullp(struct ao_scheme_cons *cons) -{ -	ao_poly	val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (val == 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) -{ -	ao_poly	val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (val == _ao_scheme_bool_false) -		return _ao_scheme_bool_true; -	else -		return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons) -{ -	ao_poly val; - -	if (!ao_scheme_parse_args(proc, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (ao_scheme_poly_type(val) == type) -		return _ao_scheme_bool_true; -	return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_procedurep(struct ao_scheme_cons *cons) -{ -	ao_poly val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	switch (ao_scheme_poly_type(val)) { -	case AO_SCHEME_BUILTIN: -	case AO_SCHEME_LAMBDA: -		return _ao_scheme_bool_true; -	default: -		return _ao_scheme_bool_false; -	} -} - -ao_poly -ao_scheme_do_read_char(struct ao_scheme_cons *cons) -{ -	int	c; -#ifndef AO_SCHEME_FEATURE_PORT -	ao_poly	port; -	if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, -				  AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	c = getchar(); -#else -	struct ao_scheme_port	*port; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, -				  AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (port) -		c = ao_scheme_port_getc(port); -	else -		c = getchar(); -#endif -	if (c == EOF) -		return _ao_scheme_atom_eof; -	return ao_scheme_integer_poly(c); -} - -ao_poly -ao_scheme_do_write_char(struct ao_scheme_cons *cons) -{ -	int32_t c; -#ifndef AO_SCHEME_FEATURE_PORT -	ao_poly	port; -	if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, -				  AO_SCHEME_INT, &c, -				  AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	putchar(c); -#else -	struct ao_scheme_port	*port; -	if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, -				  AO_SCHEME_INT, &c, -				  AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (port) -		ao_scheme_port_putc(port, c); -	else -		putchar(c); -#endif -	return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_exit(struct ao_scheme_cons *cons) -{ -	ao_poly	val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_exit, cons, -				  AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_true, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	ao_scheme_exception |= AO_SCHEME_EXIT; -	return val; -} - -#ifdef AO_SCHEME_FEATURE_TIME - -ao_poly -ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) -{ -	if (!ao_scheme_parse_args(_ao_scheme_atom_current2djiffy, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_integer_poly(ao_scheme_os_jiffy()); -} - -ao_poly -ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) -{ -	if (!ao_scheme_parse_args(_ao_scheme_atom_jiffies2dper2dsecond, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_integer_poly(AO_SCHEME_JIFFIES_PER_SECOND); -} - -ao_poly -ao_scheme_do_delay(struct ao_scheme_cons *cons) -{ -	int32_t delay; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_delay, cons, -				  AO_SCHEME_INT, &delay, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	ao_scheme_os_delay(delay); -	return cons->car; -} -#endif - -#ifdef AO_SCHEME_FEATURE_POSIX - -#include <unistd.h> - -static char	**ao_scheme_argv; - -void -ao_scheme_set_argv(char **argv) -{ -	ao_scheme_argv = argv; -} - -ao_poly -ao_scheme_do_command_line(struct ao_scheme_cons *cons) -{ -	ao_poly	args = AO_SCHEME_NIL; -	ao_poly	arg; -	int	i; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_command2dline, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; - -	for (i = 0; ao_scheme_argv[i]; i++); - -	while (--i >= 0) { -		ao_scheme_poly_stash(args); -		arg = ao_scheme_string_poly(ao_scheme_string_new(ao_scheme_argv[i])); -		args = ao_scheme_poly_fetch(); -		if (!arg) -			return AO_SCHEME_NIL; -		args = ao_scheme_cons(arg, args); -		if (!args) -			return AO_SCHEME_NIL; -	} -	return args; -} - -ao_poly -ao_scheme_do_get_environment_variables(struct ao_scheme_cons *cons) -{ -	ao_poly	envs = AO_SCHEME_NIL; -	ao_poly	env; -	int	i; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariables, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	for (i = 0; environ[i]; i++); - -	while (--i >= 0) { -		ao_scheme_poly_stash(envs); -		env = ao_scheme_string_poly(ao_scheme_string_new(environ[i])); -		envs = ao_scheme_poly_fetch(); -		if (!env) -			return AO_SCHEME_NIL; -		envs = ao_scheme_cons(env, envs); -		if (!envs) -			return AO_SCHEME_NIL; -	} -	return envs; -} - -ao_poly -ao_scheme_do_get_environment_variable(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_string	*name; -	char			*val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariable, cons, -				  AO_SCHEME_STRING, &name, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	val = secure_getenv(name->val); -	if (!val) -		return _ao_scheme_bool_false; -	return ao_scheme_string_poly(ao_scheme_string_new(val)); -} - -ao_poly -ao_scheme_do_file_existsp(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_string	*name; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_file2dexists3f, cons, -				  AO_SCHEME_STRING, &name, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (access(name->val, F_OK) == 0) -		return _ao_scheme_bool_true; -	return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_delete_file(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_string	*name; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_delete2dfile, cons, -				  AO_SCHEME_STRING, &name, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (unlink(name->val) == 0) -		return _ao_scheme_bool_true; -	return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_current_second(struct ao_scheme_cons *cons) -{ -	int32_t	second; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_current2dsecond, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	second = (int32_t) time(NULL); -	return ao_scheme_integer_poly(second); -} - -#endif /* AO_SCHEME_FEATURE_POSIX */ - -#define AO_SCHEME_BUILTIN_FUNCS -#include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt deleted file mode 100644 index fd29d607..00000000 --- a/src/scheme/ao_scheme_builtin.txt +++ /dev/null @@ -1,100 +0,0 @@ -BIGINT	feature		bigint -all	atom		eof -all	atom		else -all	f_lambda	eval -all	f_lambda	read -all	nlambda		lambda -all	nlambda		nlambda -all	nlambda		macro -all	f_lambda	car -all	f_lambda	cdr -all	f_lambda	cons -all	f_lambda	last -all	f_lambda	length -all	f_lambda	list_copy	list-copy -all	f_lambda	list_tail	list-tail -all	nlambda		quote -QUASI	atom		quasiquote -QUASI	atom		unquote -QUASI	atom		unquote_splicing	unquote-splicing -all	f_lambda	set -all	macro		setq		set! -all	f_lambda	def -all	nlambda		cond -all	nlambda		begin -all	nlambda		while -all	f_lambda	write -all	f_lambda	display -all	f_lambda	plus		+	string-append -all	f_lambda	minus		- -all	f_lambda	times		* -all	f_lambda	divide		/ -all	f_lambda	modulo		modulo	% -all	f_lambda	remainder -all	f_lambda	quotient -all	f_lambda	floor_quotient	floor-quotient -all	f_lambda	equal		=	eq?	eqv? -all	f_lambda	less		<	string<? -all	f_lambda	greater		>	string>? -all	f_lambda	less_equal	<=	string<=? -all	f_lambda	greater_equal	>=	string>=? -all	f_lambda	flush_output		flush-output -TIME	f_lambda	delay -GPIO	f_lambda	led -SAVE	f_lambda	save -SAVE	f_lambda	restore -all	f_lambda	call_cc		call-with-current-continuation	call/cc -all	f_lambda	collect -all	f_lambda	nullp		null? -all	f_lambda	not -all	f_lambda	listp		list? -all	f_lambda	pairp		pair? -all	f_lambda	integerp	integer? exact?@BIGINT exact-integer?@BIGINT -all	f_lambda	numberp		number? real?@FLOAT -all	f_lambda	booleanp	boolean? -all	f_lambda	set_car		set-car! -all	f_lambda	set_cdr		set-cdr! -all	f_lambda	symbolp		symbol? -all	f_lambda	list_to_string		list->string -all	f_lambda	string_to_list		string->list -all	f_lambda	symbol_to_string	symbol->string -all	f_lambda	string_to_symbol	string->symbol -all	f_lambda	stringp		string? -all	f_lambda	string_ref	string-ref -all	f_lambda	string_set	string-set! -all	f_lambda	string_length	string-length -all	f_lambda	make_string	make-string -all	f_lambda	procedurep	procedure? -all	lambda		apply -all	f_lambda	read_char	read-char -all	f_lambda	write_char	write-char -all	f_lambda	exit -TIME	f_lambda	current_jiffy	current-jiffy -TIME	f_lambda	jiffies_per_second	jiffies-per-second -FLOAT	f_lambda	finitep		finite? -FLOAT	f_lambda	infinitep	infinite? -FLOAT	f_lambda	inexactp	inexact? -FLOAT	f_lambda	sqrt -VECTOR	f_lambda	vector_ref	vector-ref -VECTOR	f_lambda	vector_set	vector-set! -VECTOR	f_lambda	vector -VECTOR	f_lambda	make_vector	make-vector -VECTOR	f_lambda	list_to_vector	list->vector -VECTOR	f_lambda	vector_to_list	vector->list -VECTOR	f_lambda	vector_length	vector-length -VECTOR	f_lambda	vectorp		vector? -PORT	f_lambda	portp		port? -PORT	f_lambda	port_openp	port-open? -PORT	f_lambda	open_input_file	open-input-file -PORT	f_lambda	open_output_file	open-output-file -PORT	f_lambda	close_port	close-port -PORT	f_lambda	current_input_port	current-input-port -PORT	f_lambda	current_output_port	current-output-port -PORT	f_lambda	current_error_port	current-error-port -POSIX	f_lambda	command_line	command-line -POSIX	f_lambda	get_environment_variables	get-environment-variables -POSIX	f_lambda	get_environment_variable	get-environment-variable -POSIX	f_lambda	file_existsp			file-exists? -POSIX	f_lambda	delete_file	delete-file -POSIX	f_lambda	current_second	current-second -UNDEF	f_lambda	undef diff --git a/src/scheme/ao_scheme_char.scheme b/src/scheme/ao_scheme_char.scheme deleted file mode 100644 index fdb7fa64..00000000 --- a/src/scheme/ao_scheme_char.scheme +++ /dev/null @@ -1,80 +0,0 @@ -; -; Copyright © 2018 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. -; -; Char primitives placed in ROM - -(define char? integer?) - -(char? #\q) -(char? "h") - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(char-lower-case? #\a) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(char-alphabetic? #\a) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(char-numeric? #\a) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(char-whitespace? #\a) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) - -(define char->integer (macro (v) v)) -(define integer->char char->integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(char-upcase #\a) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(char-downcase #\a) -(char-downcase #\B) -(char-downcase #\0) -(char-downcase #\space) - -(define (digit-value c) -  (if (char-numeric? c) -      (- c #\0) -      #f) -  ) - -(digit-value #\1) -(digit-value #\a) diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c deleted file mode 100644 index a6e697b2..00000000 --- a/src/scheme/ao_scheme_cons.c +++ /dev/null @@ -1,402 +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_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_is_cons(cdr)) { -			ao_scheme_poly_mark(cdr, 0); -			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_is_cons(cdr)) { -			(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(car); -		ao_scheme_poly_stash(cdr); -		cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); -		cdr = ao_scheme_poly_fetch(); -		car = ao_scheme_poly_fetch(); -		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_is_cons(cdr)) { -		(void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); -		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)); -} - -static struct ao_scheme_cons * -ao_scheme_cons_copy(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons	*head = NULL; -	struct ao_scheme_cons	*tail = NULL; - -	while (cons) { -		struct ao_scheme_cons	*new; -		ao_poly cdr; - -		ao_scheme_cons_stash(cons); -		ao_scheme_cons_stash(head); -		ao_scheme_cons_stash(tail); -		new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); -		tail = ao_scheme_cons_fetch(); -		head = ao_scheme_cons_fetch(); -		cons = ao_scheme_cons_fetch(); -		if (!new) -			return AO_SCHEME_NIL; -		new->car = cons->car; -		new->cdr = AO_SCHEME_NIL; -		if (!head) -			head = new; -		else -			tail->cdr = ao_scheme_cons_poly(new); -		tail = new; -		cdr = cons->cdr; -		if (!ao_scheme_is_cons(cdr)) { -			tail->cdr = cdr; -			break; -		} -		cons = ao_scheme_poly_cons(cdr); -	} -	return head; -} - -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(FILE *out, ao_poly c, bool write) -{ -	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(c); -	struct ao_scheme_cons	*clear = cons; -	ao_poly			cdr; -	int			written = 0; - -	ao_scheme_print_start(); -	fprintf(out, "("); -	while (cons) { -		if (written != 0) -			fprintf(out, " "); - -		/* Note if there's recursion in printing. Not -		 * as good as actual references, but at least -		 * we don't infinite loop... -		 */ -		if (ao_scheme_print_mark_addr(cons)) { -			fprintf(out, "..."); -			break; -		} - -		ao_scheme_poly_write(out, cons->car, write); - -		/* keep track of how many pairs have been printed */ -		written++; - -		cdr = cons->cdr; -		if (!ao_scheme_is_cons(cdr)) { -			fprintf(out, " . "); -			ao_scheme_poly_write(out, cdr, write); -			break; -		} -		cons = ao_scheme_poly_cons(cdr); -	} -	fprintf(out, ")"); - -	if (ao_scheme_print_stop()) { - -		/* If we're still printing, clear the print marks on -		 * all printed pairs -		 */ -		while (written--) { -			ao_scheme_print_clear_addr(clear); -			clear = ao_scheme_poly_cons(clear->cdr); -		} -	} -} - -int -ao_scheme_cons_length(struct ao_scheme_cons *cons) -{ -	int	len = 0; -	while (cons) { -		len++; -		cons = ao_scheme_cons_cdr(cons); -	} -	return len; -} - -ao_poly -ao_scheme_do_car(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons *pair; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_car, cons, -				  AO_SCHEME_CONS, &pair, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return pair->car; -} - -ao_poly -ao_scheme_do_cdr(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons *pair; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_cdr, cons, -				  AO_SCHEME_CONS, &pair, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return pair->cdr; -} - -ao_poly -ao_scheme_do_cons(struct ao_scheme_cons *cons) -{ -	ao_poly	car, cdr; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_cons, cons, -				  AO_SCHEME_POLY, &car, -				  AO_SCHEME_POLY, &cdr, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_cons(car, cdr); -} - -ao_poly -ao_scheme_do_last(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons	*pair; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_last, cons, -				  AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	while (pair) { -		if (!pair->cdr) -			return pair->car; -		pair = ao_scheme_cons_cdr(pair); -	} -	return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_length(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons	*pair; -	if (!ao_scheme_parse_args(_ao_scheme_atom_length, cons, -				  AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_integer_poly(ao_scheme_cons_length(pair)); -} - -ao_poly -ao_scheme_do_list_copy(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons	*pair; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_list2dcopy, cons, -				  AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_cons_poly(ao_scheme_cons_copy(pair)); -} - -ao_poly -ao_scheme_do_list_tail(struct ao_scheme_cons *cons) -{ -	ao_poly			list; -	int32_t			v; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_list2dtail, cons, -				  AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK | AO_SCHEME_ARG_RET_POLY, &list, -				  AO_SCHEME_INT, &v, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; - -	while (v > 0) { -		if (!list) -			return ao_scheme_error(AO_SCHEME_INVALID, "%v: ran off end", _ao_scheme_atom_list2dtail); -		if (!ao_scheme_is_cons(list)) -			return ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid list", _ao_scheme_atom_list2dtail); -		list = ao_scheme_poly_cons(list)->cdr; -		v--; -	} -	return list; -} - -ao_poly -ao_scheme_do_pairp(struct ao_scheme_cons *cons) -{ -	ao_poly val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (ao_scheme_is_pair(val)) -		return _ao_scheme_bool_true; -	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 val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	for (;;) { -		if (val == AO_SCHEME_NIL) -			return _ao_scheme_bool_true; -		if (!ao_scheme_is_cons(val)) -			return _ao_scheme_bool_false; -		val = ao_scheme_poly_cons(val)->cdr; -	} -} - -ao_poly -ao_scheme_do_set_car(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons	*pair; -	ao_poly			val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons, -				  AO_SCHEME_CONS, &pair, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	pair->car = val; -	return val; -} - -ao_poly -ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons	*pair; -	ao_poly			val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons, -				  AO_SCHEME_CONS, &pair, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	pair->cdr = val; -	return val; -} - diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme deleted file mode 100644 index 17dc51a9..00000000 --- a/src/scheme/ao_scheme_const.scheme +++ /dev/null @@ -1,916 +0,0 @@ -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - -(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1))))) - -					; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) -     (macro (name value) -	    (list -	     def -	     (list quote name) -	     value) -	    ) -     ) - -(begin - (def! append -   (lambda args -	  (def! append-list -	    (lambda (a b) -	      (cond ((null? a) b) -		    (else (cons (car a) (append-list (cdr a) b))) -		    ) -	      ) -	    ) -	     -	  (def! append-lists -	    (lambda (lists) -	      (cond ((null? lists) lists) -		    ((null? (cdr lists)) (car lists)) -		    (else (append-list (car lists) (append-lists (cdr lists)))) -		    ) -	      ) -	    ) -	  (append-lists args) -	  ) -   ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - -					; boolean operators - -(begin - (def! or -   (macro l -	  (def! _or -	    (lambda (l) -	      (cond ((null? l) #f) -		    ((null? (cdr l)) -		     (car l)) -		    (else -		     (list -		      cond -		      (list -		       (car l)) -		      (list -		       'else -		       (_or (cdr l)) -		       ) -		      ) -		     ) -		    ) -	      ) -	    ) -	  (_or l))) - 'or) - -					; execute to resolve macros - -(_?_ (or #f #t) #t) - -(begin - (def! and -   (macro l -	  (def! _and -	    (lambda (l) -	      (cond ((null? l) #t) -		    ((null? (cdr l)) -		     (car l)) -		    (else -		     (list -		      cond -		      (list -		       (car l) -		       (_and (cdr l)) -		       ) -		      ) -		     ) -		    ) -	      ) -	    ) -	  (_and l) -	  ) -   ) - 'and) - -					; execute to resolve macros - -(_?_ (and #t #f) #f) - -					; recursive equality - -(begin -  (def! equal? -    (lambda (a b) -      (cond ((eq? a b) #t) -	    ((and (pair? a) (pair? b)) -	     (and (equal? (car a) (car b)) -		  (equal? (cdr a) (cdr b))) -	     ) -	    ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b))) -	     ((lambda (i l) -		(while (and (< i l) -			    (equal? (vector-ref a i) -				    (vector-ref b i))) -		       (set! i (+ i 1))) -		(eq? i l) -		) -	      0 -	      (vector-length a) -	      ) -	     ) -	    (else #f) -	    ) -      ) -    ) -  'equal? -  ) - -(_?_ (equal? '(a b c) '(a b c)) #t) -(_?_ (equal? '(a b c) '(a b b)) #f) -(_?_ (equal? #(1 2 3) #(1 2 3)) #t) -(_?_ (equal? #(1 2 3) #(4 5 6)) #f) - -(def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit))))) - -(begin - (def! quasiquote -   (macro (x) -	  (def! constant? -					; A constant value is either a pair starting with quote, -					; or anything which is neither a pair nor a symbol - -	    (lambda (exp) -	      (cond ((pair? exp) -		     (eq? (car exp) 'quote) -		     ) -		    (else -		     (not (symbol? exp)) -		     ) -		    ) -	      ) -	    ) -	  (def! combine-skeletons -	    (lambda (left right exp) -	      (cond -	       ((and (constant? left) (constant? right))  -		(cond ((and (eqv? (eval left) (car exp)) -			    (eqv? (eval right) (cdr exp))) -		       (list 'quote exp) -		       ) -		      (else -		       (list 'quote (cons (eval left) (eval right))) -		       ) -		      ) -		) -	       ((null? right) -		(list 'list left) -		) -	       ((and (pair? right) (eq? (car right) 'list)) -		(cons 'list (cons left (cdr right))) -		) -	       (else -		(list 'cons left right) -		) -	       ) -	      ) -	    ) - -	  (def! expand-quasiquote -	    (lambda (exp nesting) -	      (cond - -					; non cons -- constants -					; themselves, others are -					; quoted - -	       ((not (pair? exp))  -		(cond ((constant? exp) -		       exp -		       ) -		      (else -		       (list 'quote exp) -		       ) -		      ) -		) - -					; check for an unquote exp and -					; add the param unquoted - -	       ((and (eq? (car exp) 'unquote) (= (length exp) 2)) -		(cond ((= nesting 0) -		       (car (cdr exp)) -		       ) -		      (else -		       (combine-skeletons ''unquote  -					  (expand-quasiquote (cdr exp) (- nesting 1)) -					  exp)) -		      ) -		) - -					; nested quasi-quote -- -					; construct the right -					; expression - -	       ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) -		(combine-skeletons ''quasiquote  -				   (expand-quasiquote (cdr exp) (+ nesting 1)) -				   exp)) - -					; check for an -					; unquote-splicing member, -					; compute the expansion of the -					; value and append the rest of -					; the quasiquote result to it - -	       ((and (pair? (car exp)) -		     (eq? (car (car exp)) 'unquote-splicing) -		     (= (length (car exp)) 2)) -		(cond ((= nesting 0) -		       (list 'append (car (cdr (car exp))) -			     (expand-quasiquote (cdr exp) nesting)) -		       ) -		      (else -		       (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) -					  (expand-quasiquote (cdr exp) nesting) -					  exp)) -		      ) -		) - -					; for other lists, just glue -					; the expansion of the first -					; element to the expansion of -					; the rest of the list - -	       (else (combine-skeletons (expand-quasiquote (car exp) nesting) -					(expand-quasiquote (cdr exp) nesting) -					exp) -		     ) -	       ) -	      ) -	    ) -	  (def! result (expand-quasiquote x 0)) -	  result -	  ) -   ) - 'quasiquote) - -					; -					; Define a variable without returning the value -					; Useful when defining functions to avoid -					; having lots of output generated. -					; -					; Also accepts the alternate -					; form for defining lambdas of -					; (define (name x y z) sexprs ...)  -					; - -(begin - (def! define -   (macro (first . rest) -					; check for alternate lambda definition form - -	  (cond ((pair? first) -		 (set! rest -		       (append -			(list -			 'lambda -			 (cdr first)) -			rest)) -		 (set! first (car first)) -		 ) -		(else -		 (set! rest (car rest)) -		 ) -		) -	  (def! result `(,begin -			 (,def (,quote ,first) ,rest) -			 (,quote ,first)) -	    ) -	  result -	  ) -   ) - 'define - ) - -					; basic list accessors - -(define (caar l) (car (car l))) - -(_??_ (caar '((1 2 3) (4 5 6))) 1) - -(define (cadr l) (car (cdr l))) - -(_??_ (cadr '(1 2 3 4 5 6)) 2) - -(define (cdar l) (cdr (car l))) - -(_??_ (cdar '((1 2) (3 4))) '(2)) - -(define (cddr l) (cdr (cdr l))) - -(_??_ (cddr '(1 2 3)) '(3)) - -(define (caddr l) (car (cdr (cdr l)))) - -(_??_ (caddr '(1 2 3 4)) 3) - -					; (if <condition> <if-true>) -					; (if <condition> <if-true> <if-false) - -(define if -  (macro (test . args) -	 (cond ((null? (cdr args)) -		`(cond (,test ,(car args))) -		) -	       (else -		`(cond (,test ,(car args)) -		       (else ,(cadr args))) -		) -	       ) -	 ) -  ) - -(_??_ (if (> 3 2) 'yes) 'yes) -(_??_ (if (> 3 2) 'yes 'no) 'yes) -(_??_ (if (> 2 3) 'no 'yes) 'yes) -(_??_ (if (> 2 3) 'no) #f) - -					; simple math operators - -(define zero? (macro (value) `(eq? ,value 0))) - -(_??_ (zero? 1) #f) -(_??_ (zero? 0) #t) -(_??_ (zero? "hello") #f) - -(define positive? (macro (value) `(> ,value 0))) - -(_??_ (positive? 12) #t) -(_??_ (positive? -12) #f) - -(define negative? (macro (value) `(< ,value 0))) - -(_??_ (negative? 12) #f) -(_??_ (negative? -12) #t) - -(define (abs x) (if (>= x 0) x (- x))) - -(_??_ (abs 12) 12) -(_??_ (abs -12) 12) - -(define max (lambda (first . rest) -		   (while (not (null? rest)) -		     (cond ((< first (car rest)) -			    (set! first (car rest))) -			   ) -		     (set! rest (cdr rest)) -		     ) -		   first) -  ) - -(_??_ (max 1 2 3) 3) -(_??_ (max 3 2 1) 3) - -(define min (lambda (first . rest) -		   (while (not (null? rest)) -		     (cond ((> first (car rest)) -			    (set! first (car rest))) -			   ) -		     (set! rest (cdr rest)) -		     ) -		   first) -  ) - -(_??_ (min 1 2 3) 1) -(_??_ (min 3 2 1) 1) - -(define (even? x) (zero? (% x 2))) - -(_??_ (even? 2) #t) -(_??_ (even? -2) #t) -(_??_ (even? 3) #f) -(_??_ (even? -1) #f) - -(define (odd? x) (not (even? x))) - -(_??_ (odd? 2) #f) -(_??_ (odd? -2) #f) -(_??_ (odd? 3) #t) -(_??_ (odd? -1) #t) - -(_??_ (list-tail '(1 2 3 . 4) 3) 4) - -(define (list-ref x k) -  (car (list-tail x k)) -  ) - -(_??_ (list-ref '(1 2 3 4) 3) 4) - -(define (list-set! x k v) -  (set-car! (list-tail x k) v) -  x) - -(list-set! (list 1 2 3) 1 4) - -					; define a set of local -					; variables all at once and -					; then evaluate a list of -					; sexprs -					; -					; (let (var-defines) sexprs) -					; -					; where var-defines are either -					; -					; (name value) -					; -					; or -					; -					; (name) -					; -					; e.g. -					; -					; (let ((x 1) (y)) (set! y (+ x 1)) y) - -(define let -  (macro (vars . exprs) -	 (define (make-names vars) -	   (cond ((not (null? vars)) -		  (cons (car (car vars)) -			(make-names (cdr vars)))) -		 (else ()) -		 ) -	   ) - -					; the parameters to the lambda is a list -					; of nils of the right length - -	 (define (make-vals vars) -	   (cond ((not (null? vars)) -		  (cons (cond ((null? (cdr (car vars))) ()) -			      (else -			       (car (cdr (car vars)))) -			      ) -			(make-vals (cdr vars)))) -		 (else ()) -		 ) -	   ) -					; prepend the set operations -					; to the expressions - -					; build the lambda. - -	 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) -	 ) -     ) -		    - -(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) - -					; define a set of local -					; variables one at a time and -					; then evaluate a list of -					; sexprs -					; -					; (let* (var-defines) sexprs) -					; -					; where var-defines are either -					; -					; (name value) -					; -					; or -					; -					; (name) -					; -					; e.g. -					; -					; (let* ((x 1) (y)) (set! y (+ x 1)) y) - -(define letrec -  (macro (vars . exprs) - -					; -					; make the list of names in the let -					; - -	 (define (make-names vars) -	   (cond ((not (null? vars)) -		  (cons (car (car vars)) -			(make-names (cdr vars)))) -		 (else ()) -		 ) -	   ) - -					; the set of expressions is -					; the list of set expressions -					; pre-pended to the -					; expressions to evaluate - -	 (define (make-exprs vars exprs) -	   (cond ((null? vars) exprs) -		 (else -		  (cons -		   (list set -			 (list quote -			       (car (car vars)) -			       ) -			 (cond ((null? (cdr (car vars))) ()) -			       (else (cadr (car vars)))) -			 ) -		   (make-exprs (cdr vars) exprs) -		   ) -		  ) -		 ) -	   ) - -					; the parameters to the lambda is a list -					; of nils of the right length - -	 (define (make-nils vars) -	   (cond ((null? vars) ()) -		 (else (cons () (make-nils (cdr vars)))) -		 ) -	   ) -					; build the lambda. - -	 `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) -	 ) -     ) - -(_??_ (letrec ((x 1) (y x)) (+ x y)) 2) - -					; letrec is sufficient for let* - -(define let* letrec) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(_??_ (when #t (+ 1 2)) 3) -(_??_ (when #f (+ 1 2)) #f) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(_??_ (unless #f (+ 2 3)) 5) -(_??_ (unless #t (+ 2 3)) #f) - -(define (reverse list) -  (define (_r old new) -    (if (null? old) -	new -	(_r (cdr old) (cons (car old) new)) -	) -    ) -  (_r list ()) -  ) - -(_??_ (reverse '(1 2 3)) '(3 2 1)) - -(define make-list -  (lambda (a . b) -    (define (_m a x) -      (if (zero? a) -	  x -	  (_m (- a 1) (cons b x)) -	  ) -      ) -    (if (null? b) -	(set! b #f) -	(set! b (car b)) -	) -    (_m a '()) -    ) -  ) -     -(_??_ (make-list 10 'a) '(a a a a a a a a a a)) - -(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) - -(define member (lambda (obj list . test?) -		      (cond ((null? list) -			     #f -			     ) -			    (else -			     (if (null? test?) (set! test? equal?) (set! test? (car test?))) -			     (if (test? obj (car list)) -				 list -			       (member obj (cdr list) test?)) -			     ) -			    ) -		      ) -  ) - -(_??_ (member '(2) '((1) (2) (3)))  '((2) (3))) - -(_??_ (member '(4) '((1) (2) (3))) #f) - -(define (memq obj list) (member obj list eq?)) - -(_??_ (memq 2 '(1 2 3)) '(2 3)) - -(_??_ (memq 4 '(1 2 3)) #f) - -(_??_ (memq '(2) '((1) (2) (3))) #f) - -(define (memv obj list) (member obj list eqv?)) - -(_??_ (memv 2 '(1 2 3)) '(2 3)) - -(_??_ (memv 4 '(1 2 3)) #f) - -(_??_ (memv '(2) '((1) (2) (3))) #f) - -(define (assoc obj list . compare) -  (if (null? compare) -      (set! compare equal?) -      (set! compare (car compare)) -      ) -  (if (null? list) -      #f -    (if (compare obj (caar list)) -	(car list) -	(assoc obj (cdr list) compare) -	) -    ) -  ) - -(define (assq obj list) (assoc obj list eq?)) -(define (assv obj list) (assoc obj list eqv?)) - -(_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2)) -(_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(define char? integer?) - -(_??_ (char? #\q) #t) -(_??_ (char? "h") #f) - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(_??_ (char-upper-case? #\a) #f) -(_??_ (char-upper-case? #\B) #t) -(_??_ (char-upper-case? #\0) #f) -(_??_ (char-upper-case? #\space) #f) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(_??_ (char-lower-case? #\a) #t) -(_??_ (char-lower-case? #\B) #f) -(_??_ (char-lower-case? #\0) #f) -(_??_ (char-lower-case? #\space) #f) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(_??_ (char-alphabetic? #\a) #t) -(_??_ (char-alphabetic? #\B) #t) -(_??_ (char-alphabetic? #\0) #f) -(_??_ (char-alphabetic? #\space) #f) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(_??_ (char-numeric? #\a) #f) -(_??_ (char-numeric? #\B) #f) -(_??_ (char-numeric? #\0) #t) -(_??_ (char-numeric? #\space) #f) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(_??_ (char-whitespace? #\a) #f) -(_??_ (char-whitespace? #\B) #f) -(_??_ (char-whitespace? #\0) #f) -(_??_ (char-whitespace? #\space) #t) - -(define char->integer (macro (v) v)) -(define integer->char char->integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(_??_ (char-upcase #\a) #\A) -(_??_ (char-upcase #\B) #\B) -(_??_ (char-upcase #\0) #\0) -(_??_ (char-upcase #\space) #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(_??_ (char-downcase #\a) #\a) -(_??_ (char-downcase #\B) #\b) -(_??_ (char-downcase #\0) #\0) -(_??_ (char-downcase #\space) #\space) - -(define (digit-value c) -  (if (char-numeric? c) -      (- c #\0) -      #f) -  ) - -(_??_ (digit-value #\1) 1) -(_??_ (digit-value #\a) #f) - -(define string (lambda chars (list->string chars))) - -(_??_ (string #\a #\b #\c) "abc") - -(_??_ (apply cons '(a b)) '(a . b)) - -(define map -  (lambda (proc . lists) -	 (define (_a lists) -	   (cond ((null? lists) ()) -		 (else -		  (cons (caar lists) (_a (cdr lists))) -		  ) -		 ) -	   ) -	 (define (_n lists) -	   (cond ((null? lists) ()) -		 (else -		  (cons (cdr (car lists)) (_n (cdr lists))) -		  ) -		 ) -	   ) -	 (define (_m lists) -	   (cond ((null? (car lists)) ()) -		 (else -		  (cons (apply proc (_a lists)) (_m (_n lists))) -		  ) -		 ) -	   ) -	 (_m lists) -	 ) -  ) - -(_??_ (map cadr '((a b) (d e) (g h))) '(b e h)) - -(define for-each -  (lambda (proc . lists) -    (define (_f lists) -      (cond ((null? (car lists)) #t) -	    (else -	     (apply proc (map car lists)) -	     (_f (map cdr lists)) -	     ) -	    ) -      ) -    (_f lists) -    ) -  ) - -(_??_ (let ((a 0)) -	(for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) -	a -	) -      6) -       - -(define (newline) (write-char #\newline)) - -(newline) - -(_??_ (call-with-current-continuation -       (lambda (exit) -	 (for-each (lambda (x) -		     (if (negative? x) -			 (exit x))) -		   '(54 0 37 -3 245 19)) -	 #t)) -      -3) - - -					; `q -> (quote q) -					; `(q) -> (append (quote (q))) -					; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) -					; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - - -(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) - - -(define repeat -  (macro (count . rest) -	 (define counter '__count__) -	 (cond ((pair? count) -		(set! counter (car count)) -		(set! count (cadr count)) -		) -	       ) -	 `(let ((,counter 0) -		(__max__ ,count) -		) -	    (while (< ,counter __max__) -	      ,@rest -	      (set! ,counter (+ ,counter 1)) -	      ) -	    ) -	 ) -  ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write (list 'goodbye x))) - -(define case -  (macro (test . l) -					; construct the body of the -					; case, dealing with the -					; lambda version ( => lambda) - -	 (define (_unarrow l) -	   (cond ((null? l) l) -		 ((eq? (car l) '=>) `(( ,(cadr l) __key__))) -		 (else l)) -	   ) - -					; Build the case elements, which is -					; simply a list of cond clauses - -	 (define (_case l) - -	   (cond ((null? l) ()) - -					; else case - -		 ((eq? (caar l) 'else) -		  `((else ,@(_unarrow (cdr (car l)))))) - -					; regular case -		  -		 (else -		  (cons -		   `((eqv? ,(caar l) __key__) -		     ,@(_unarrow (cdr (car l)))) -		   (_case (cdr l))) -		  ) -		 ) -	   ) - -					; now construct the overall -					; expression, using a lambda -					; to hold the computed value -					; of the test expression - -	 `((lambda (__key__) -	     (cond ,@(_case l))) ,test) -	 ) -  ) - -(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "one") -(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "two") -(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) "three") -(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "else") -(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "twelve") - -(define do -  (macro (vars test . cmds) -    (define (_step v) -      (if (null? v) -	  '() -	  (if (null? (cddr (car v))) -	      (_step (cdr v)) -	      (cons `(set! ,(caar v) ,(caddr (car v))) -		    (_step (cdr v)) -		    ) -	      ) -	  ) -      ) -    `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) -       (while (not ,(car test)) -	      ,@cmds -	      ,@(_step vars) -	      ) -       ,@(cdr test) -       ) -    ) -  ) - -(define (eof-object? a) -  (equal? a 'eof) -  ) - -(_??_ (do ((x 1 (+ x 1)) -	   (y 0) -	   ) -	  ((= x 10) y) -	(set! y (+ y x)) -	) -      45) - -(_??_ (do ((vec (make-vector 5)) -	   (i 0 (+ i 1))) -	  ((= i 5) vec) -	(vector-set! vec i i)) #(0 1 2 3 4)) diff --git a/src/scheme/ao_scheme_do.scheme b/src/scheme/ao_scheme_do.scheme deleted file mode 100644 index 063e4a38..00000000 --- a/src/scheme/ao_scheme_do.scheme +++ /dev/null @@ -1,34 +0,0 @@ -(define do -  (macro (vars test . cmds) -    (define (_step v) -      (if (null? v) -	  '() -	  (if (null? (cddr (car v))) -	      (_step (cdr v)) -	      (cons `(set! ,(caar v) ,(caddr (car v))) -		    (_step (cdr v)) -		    ) -	      ) -	  ) -      ) -    `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) -       (while (not ,(car test)) -	      ,@cmds -	      ,@(_step vars) -	      ) -       ,@(cdr test) -       ) -    ) -  ) - -(do ((x 1 (+ x 1))) -    ((= x 10) "done") -  (display "x: ") -  (write x) -  (newline) -  ) - -(do ((vec (make-vector 5)) -     (i 0 (+ i 1))) -    ((= i 5) vec) -  (vector-set! vec i i)) diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c deleted file mode 100644 index f97eb003..00000000 --- a/src/scheme/ao_scheme_error.c +++ /dev/null @@ -1,78 +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_scheme.h" -#include <stdarg.h> - -void -ao_scheme_vfprintf(FILE *out, const char *format, va_list args) -{ -	char c; - -	while ((c = *format++) != '\0') { -		if (c == '%') { -			switch (c = *format++) { -			case 'v': -				ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), true); -				break; -			case 'V': -				ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), false); -				break; -			case 'p': -				fprintf(out, "%p", va_arg(args, void *)); -				break; -			case 'd': -				fprintf(out, "%d", va_arg(args, int)); -				break; -			case 'x': -				fprintf(out, "%x", va_arg(args, int)); -				break; -			case 's': -				fprintf(out, "%s", va_arg(args, char *)); -				break; -			default: -				putc(c, out); -				break; -			} -		} else -			putc(c, out); -	} -} - -void -ao_scheme_fprintf(FILE *out, const char *format, ...) -{ -	va_list args; -	va_start(args, format); -	ao_scheme_vfprintf(out, format, args); -	va_end(args); -} - -ao_poly -ao_scheme_error(int error, const char *format, ...) -{ -	va_list	args; - -	ao_scheme_exception |= error; -	va_start(args, format); -	ao_scheme_vfprintf(stdout, format, args); -	putchar('\n'); -	va_end(args); -	ao_scheme_fprintf(stdout, "Value:  %v\n", ao_scheme_v); -	ao_scheme_fprintf(stdout, "Frame:  %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); -	printf("Stack:\n"); -	ao_scheme_stack_write(stdout, ao_scheme_stack_poly(ao_scheme_stack), true); -	ao_scheme_fprintf(stdout, "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 deleted file mode 100644 index 9536cb91..00000000 --- a/src/scheme/ao_scheme_eval.c +++ /dev/null @@ -1,573 +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_scheme.h" -#include <assert.h> - -struct ao_scheme_stack		*ao_scheme_stack; -ao_poly				ao_scheme_v; - -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 */ -	default: -		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)) { -			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; -		if (ao_scheme_stack->state != eval_exec) { -			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; -	} -	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_stack_mark(ao_scheme_stack); -	return 1; -} - -/* - * Start evaluating the next cond clause - * - * If the list of clauses is empty, then - * the result of the cond is nil. - * - * Otherwise, set the current stack state to 'cond_test' and create a - * new stack context to evaluate the test s-expression. Once that's - * complete, we'll land in 'cond_test' to finish the clause. - */ -static int -ao_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_is_pair(ao_scheme_v)) { -			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_is_cons(ao_scheme_v)) { -		*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", -}; - -#ifdef AO_SCHEME_FEATURE_SAVE -/* - * 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(); -} -#endif /* AO_SCHEME_FEATURE_SAVE */ - -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) -			break; -	} -	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_stack = NULL; -	ao_scheme_frame_current = NULL; -	return ao_scheme_v; -} diff --git a/src/scheme/ao_scheme_finish.scheme b/src/scheme/ao_scheme_finish.scheme deleted file mode 100644 index fde04fb3..00000000 --- a/src/scheme/ao_scheme_finish.scheme +++ /dev/null @@ -1,17 +0,0 @@ -; -; Copyright © 2018 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. -; -; Finish setting up ROM lisp code - -(undef '_?_) -(undef '_??_) diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c deleted file mode 100644 index 483035f9..00000000 --- a/src/scheme/ao_scheme_float.c +++ /dev/null @@ -1,161 +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_scheme.h" -#include <math.h> - -#ifdef AO_SCHEME_FEATURE_FLOAT - -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", -}; - -#ifndef FLOAT_FORMAT -#define FLOAT_FORMAT "%g" -#endif - -void -ao_scheme_float_write(FILE *out, ao_poly p, bool write) -{ -	struct ao_scheme_float *f = ao_scheme_poly_float(p); -	float	v = f->value; - -	(void) write; -	if (isnanf(v)) -		fputs("+nan.0", out); -	else if (isinff(v)) { -		if (v < 0) -			putc('-', out); -		else -			putc('+', out); -		fputs("inf.0", out); -	} else -		fprintf(out, FLOAT_FORMAT, v); -} - -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_BIGINT: -		return ao_scheme_poly_bigint(p)->value; -	case AO_SCHEME_OTHER: -		switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { -		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) -{ -	ao_poly	val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (ao_scheme_poly_type(val) == 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	val; -	float	f; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	switch (ao_scheme_poly_type(val)) { -	case AO_SCHEME_INT: -	case AO_SCHEME_BIGINT: -		return _ao_scheme_bool_true; -	case AO_SCHEME_FLOAT: -		f = ao_scheme_poly_float(val)->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	val; -	float	f; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	switch (ao_scheme_poly_type(val)) { -	case AO_SCHEME_FLOAT: -		f = ao_scheme_poly_float(val)->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) -{ -	float	f; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_sqrt, cons, -				  AO_SCHEME_FLOAT, &f, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_float_get(sqrtf(f)); -} -#endif diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c deleted file mode 100644 index e4da279b..00000000 --- a/src/scheme/ao_scheme_frame.c +++ /dev/null @@ -1,391 +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_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->atom, 0); -		ao_scheme_poly_mark(v->val, 0); -		MDBG_MOVE("frame mark 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); -	} -} - -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 (;;) { -		struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); - -		MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); -		if (!ao_scheme_mark_memory(&ao_scheme_frame_vals_type, vals)) -			frame_vals_mark(vals); -		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; -		struct ao_scheme_frame_vals	*vals; -		int				ret; - -		MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); -		vals = ao_scheme_poly_frame_vals(frame->vals); -		if (!ao_scheme_move_memory(&ao_scheme_frame_vals_type, (void **) &vals)) -			frame_vals_move(vals); -		if (vals != ao_scheme_poly_frame_vals(frame->vals)) -			frame->vals = ao_scheme_frame_vals_poly(vals); - -		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", -}; - -int ao_scheme_frame_print_indent; - -static void -ao_scheme_frame_indent(FILE *out, int extra) -{ -	int				i; -	putc('\n', out); -	for (i = 0; i < ao_scheme_frame_print_indent+extra; i++) -		putc('\t', out); -} - -void -ao_scheme_frame_write(FILE *out, ao_poly p, bool write) -{ -	struct ao_scheme_frame		*frame = ao_scheme_poly_frame(p); -	struct ao_scheme_frame		*clear = frame; -	int				f; -	int				written = 0; - -	ao_scheme_print_start(); -	while (frame) { -		struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); - -		if (written != 0) -			fputs(", ", out); -		if (ao_scheme_print_mark_addr(frame)) { -			fputs("recurse...", out); -			break; -		} - -		putc('{', out); -		written++; -		for (f = 0; f < frame->num; f++) { -			ao_scheme_frame_indent(out, 1); -			ao_scheme_poly_write(out, vals->vals[f].atom, write); -			fputs(" = ", out); -			ao_scheme_poly_write(out, vals->vals[f].val, write); -		} -		frame = ao_scheme_poly_frame(frame->prev); -		ao_scheme_frame_indent(out, 0); -		putc('}', out); -	} -	if (ao_scheme_print_stop()) { -		while (written--) { -			ao_scheme_print_clear_addr(clear); -			clear = ao_scheme_poly_frame(clear->prev); -		} -	} -} - -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(frame); -		vals = ao_scheme_frame_vals_new(num); -		frame = ao_scheme_frame_fetch(); -		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(frame); -	new_vals = ao_scheme_frame_vals_new(new_num); -	frame = ao_scheme_frame_fetch(); -	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(atom); -		ao_scheme_poly_stash(val); -		frame = ao_scheme_frame_realloc(frame, f + 1); -		val = ao_scheme_poly_fetch(); -		atom = ao_scheme_poly_fetch(); -		if (!frame) -			return AO_SCHEME_NIL; -		ao_scheme_frame_bind(frame, frame->num - 1, atom, val); -	} else -		*ref = val; -	return val; -} - -#ifdef AO_SCHEME_FEATURE_UNDEF -ao_poly -ao_scheme_frame_del(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); -	int				f = frame->num; -	struct ao_scheme_frame		*moved_frame; - -	if (l >= frame->num) -		return _ao_scheme_bool_false; - -	if (vals->vals[l].atom != atom) -		return _ao_scheme_bool_false; - -	/* squash the deleted entry */ -	memmove(&vals->vals[l], -		&vals->vals[l+1], -		(f - l) * sizeof (struct ao_scheme_val)); - -	/* allocate a smaller vals array */ -	ao_scheme_frame_stash(frame); -	moved_frame = ao_scheme_frame_realloc(frame, f - 1); -	frame = ao_scheme_frame_fetch(); - -	/* -	 * We couldn't allocate a smaller frame, so just -	 * ignore the last value in the array -	 */ -	if (!moved_frame) -		frame->num = f - 1; -	return _ao_scheme_bool_true; -} -#endif - -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 deleted file mode 100644 index 2c9e45a0..00000000 --- a/src/scheme/ao_scheme_int.c +++ /dev/null @@ -1,132 +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_scheme.h" - -void -ao_scheme_int_write(FILE *out, ao_poly p, bool write) -{ -	int i = ao_scheme_poly_int(p); -	(void) write; -	fprintf(out, "%d", i); -} - -ao_poly -ao_scheme_do_integerp(struct ao_scheme_cons *cons) -{ -#ifdef AO_SCHEME_FEATURE_BIGINT -	ao_poly val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	switch (ao_scheme_poly_type(val)) { -	case AO_SCHEME_INT: -	case AO_SCHEME_BIGINT: -		return _ao_scheme_bool_true; -	default: -		return _ao_scheme_bool_false; -	} -#else -	return ao_scheme_do_typep(_ao_scheme_atom_integer3f, AO_SCHEME_INT, cons); -#endif -} - -ao_poly -ao_scheme_do_numberp(struct ao_scheme_cons *cons) -{ -#if defined(AO_SCHEME_FEATURE_BIGINT) || defined(AO_SCHEME_FEATURE_FLOAT) -	ao_poly val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	switch (ao_scheme_poly_type(val)) { -	case AO_SCHEME_INT: -#ifdef AO_SCHEME_FEATURE_BIGINT -	case AO_SCHEME_BIGINT: -#endif -#ifdef AO_SCHEME_FEATURE_FLOAT -	case AO_SCHEME_FLOAT: -#endif -		return _ao_scheme_bool_true; -	default: -		return _ao_scheme_bool_false; -	} -#else -	return ao_scheme_do_integerp(cons); -#endif -} - -#ifdef AO_SCHEME_FEATURE_BIGINT - -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_BIGINT: -		return ao_scheme_poly_bigint(p)->value; -	} -	return 0; -} - -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 = 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(FILE *out, ao_poly p, bool write) -{ -	struct ao_scheme_bigint	*bi = ao_scheme_poly_bigint(p); - -	(void) write; -	fprintf(out, "%d", bi->value); -} -#endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c deleted file mode 100644 index 18470efe..00000000 --- a/src/scheme/ao_scheme_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_scheme.h" - -static int -lambda_size(void *addr) -{ -	(void) addr; -	return sizeof (struct ao_scheme_lambda); -} - -static 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); -} - -static 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(FILE *out, ao_poly poly, bool write) -{ -	struct ao_scheme_lambda	*lambda = ao_scheme_poly_lambda(poly); -	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(lambda->code); - -	putc('(', out); -	fputs(ao_scheme_args_name(lambda->args), out); -	while (cons) { -		putc(' ', out); -		ao_scheme_poly_write(out, cons->car, write); -		cons = ao_scheme_poly_cons(cons->cdr); -	} -	putc(')', out); -} - -static 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(code); -	lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); -	code = ao_scheme_cons_fetch(); -	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(varargs); -	next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); -	varargs = ao_scheme_poly_fetch(); -	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/scheme/ao_scheme_lex.c b/src/scheme/ao_scheme_lex.c deleted file mode 100644 index 266b1fc0..00000000 --- a/src/scheme/ao_scheme_lex.c +++ /dev/null @@ -1,16 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin deleted file mode 100644 index a34affce..00000000 --- a/src/scheme/ao_scheme_make_builtin +++ /dev/null @@ -1,318 +0,0 @@ -#!/usr/bin/nickle - -typedef struct { -	string	name; -	string	feature; -} lisp_name_t; - -typedef struct { -	string	feature; -	string	type; -	string	c_name; -	lisp_name_t[*]	lisp_names; -} builtin_t; - -string[string] type_map = { -	"lambda" => "LAMBDA", -	"nlambda" => "NLAMBDA", -	"macro" => "MACRO", -	"f_lambda" => "F_LAMBDA", -	"atom" => "atom", -	"feature" => "feature", -}; - -lisp_name_t -make_one_lisp(string token) -{ -	string[*] bits = String::split(token, "@"); -	string	name = bits[0]; -	string	feature = "all"; - -	if (dim(bits) > 1) -		feature = bits[1]; -	return (lisp_name_t) {.name = name, .feature = feature }; -} - -lisp_name_t[*] -make_lisp(string[*] tokens) -{ -	lisp_name_t[...] lisp = {}; - -	if (dim(tokens) < 4) -		return (lisp_name_t[1]) { make_one_lisp(tokens[dim(tokens) - 1]) }; -	return (lisp_name_t[dim(tokens)-3]) { [i] = make_one_lisp(tokens[i+3]) }; -} - -builtin_t -read_builtin(file f) { -	string	line = File::fgets(f); -	string[*]	tokens = String::wordsplit(line, " \t"); - -	return (builtin_t) { -		.feature = dim(tokens) > 0 ? tokens[0] : "#", -		.type = dim(tokens) > 1 ? type_map[tokens[1]] : "#", -		.c_name = dim(tokens) > 2 ? tokens[2] : "#", -		.lisp_names = make_lisp(tokens), -	}; -} - -builtin_t[*] -read_builtins(file f) { -	builtin_t[...] builtins = {}; - -	while (!File::end(f)) { -		builtin_t	b = read_builtin(f); - -		if (b.type[0] != '#') -			builtins[dim(builtins)] = b; -	} -	return builtins; -} - -void -dump_ifdef(builtin_t builtin) -{ -	if (builtin.feature != "all") -		printf("#ifdef AO_SCHEME_FEATURE_%s\n", builtin.feature); -} - -void -dump_endif(builtin_t builtin) -{ -	if (builtin.feature != "all") -		printf("#endif /* AO_SCHEME_FEATURE_%s */\n", builtin.feature); -} - -bool is_atom(builtin_t b) = b.type == "atom"; - -bool is_func(builtin_t b) = b.type != "atom" && b.type != "feature"; - -bool is_feature(builtin_t b) = b.type == "feature"; - -void -dump_ids(builtin_t[*] builtins) { -	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_func(builtins[i])) { -			dump_ifdef(builtins[i]); -			printf("\tbuiltin_%s,\n", builtins[i].c_name); -			dump_endif(builtins[i]); -		} -	printf("\t_builtin_last\n"); -	printf("};\n"); -	printf("#endif /* AO_SCHEME_BUILTIN_ID */\n"); -} - -void -dump_casename(builtin_t[*] builtins) { -	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_func(builtins[i])) { -			dump_ifdef(builtins[i]); -			printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", -			       builtins[i].c_name, builtins[i].lisp_names[0].name); -			dump_endif(builtins[i]); -		} -	printf("\tdefault: return (char *) \"???\";\n"); -	printf("\t}\n"); -	printf("}\n"); -	printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); -} - -void -cify_lisp(string l) { -	for (int j = 0; j < String::length(l); j++) { -		int c= l[j]; -		if (Ctype::isalnum(c) || c == '_') -			printf("%c", c); -		else -			printf("%02x", c); -	} -} - -void -dump_arrayname(builtin_t[*] builtins) { -	printf("#ifdef AO_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_func(builtins[i])) { -			dump_ifdef(builtins[i]); -			printf("\t[builtin_%s] = _ao_scheme_atom_", -			       builtins[i].c_name); -			cify_lisp(builtins[i].lisp_names[0].name); -			printf(",\n"); -			dump_endif(builtins[i]); -		} -	} -	printf("};\n"); -	printf("#endif /* AO_SCHEME_BUILTIN_ARRAYNAME */\n"); -} - -void -dump_funcs(builtin_t[*] builtins) { -	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_func(builtins[i])) { -			dump_ifdef(builtins[i]); -			printf("\t[builtin_%s] = ao_scheme_do_%s,\n", -			       builtins[i].c_name, -			       builtins[i].c_name); -			dump_endif(builtins[i]); -		} -	} -	printf("};\n"); -	printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n"); -} - -void -dump_decls(builtin_t[*] builtins) { -	printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); -	printf("#undef AO_SCHEME_BUILTIN_DECLS\n"); -	for (int i = 0; i < dim(builtins); i++) { -		if (is_func(builtins[i])) { -			dump_ifdef(builtins[i]); -			printf("ao_poly\n"); -			printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", -			       builtins[i].c_name); -			dump_endif(builtins[i]); -		} -	} -	printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n"); -} - -void -dump_consts(builtin_t[*] builtins) { -	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_func(builtins[i])) { -			dump_ifdef(builtins[i]); -			for (int j = 0; j < dim(builtins[i].lisp_names); j++) { -				string feature = builtins[i].feature; -				if (builtins[i].lisp_names[j].feature != "all") -					feature = builtins[i].lisp_names[j].feature; -				printf ("\t{ .feature = \"%s\", .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", -					feature, -					builtins[i].lisp_names[j].name, -					builtins[i].type, -					builtins[i].c_name); -			} -			dump_endif(builtins[i]); -		} -	} -	printf("};\n"); -	printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n"); -} - -void -dump_atoms(builtin_t[*] builtins) { -	printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); -	printf("#undef AO_SCHEME_BUILTIN_ATOMS\n"); -	for (int i = 0; i < dim(builtins); i++) { -		if (!is_feature(builtins[i])) { -			for (int j = 0; j < dim(builtins[i].lisp_names); j++) { -				printf("#define _ao_scheme_atom_"); -				cify_lisp(builtins[i].lisp_names[j].name); -				printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j].name); -			} -		} -	} -	printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); -} - -void -dump_atom_names(builtin_t[*] builtins) { -	printf("#ifdef AO_SCHEME_BUILTIN_ATOM_NAMES\n"); -	printf("#undef AO_SCHEME_BUILTIN_ATOM_NAMES\n"); -	printf("static struct builtin_atom atoms[] = {\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++) { -				string feature = builtins[i].feature; -				if (builtins[i].lisp_names[j].feature != "all") -					feature = builtins[i].lisp_names[j].feature; -				printf("\t{ .feature = \"%s\", .name = \"%s\" },\n", -				       feature, -				       builtins[i].lisp_names[j].name); -			} -		} -	} -	printf("};\n"); -	printf("#endif /* AO_SCHEME_BUILTIN_ATOM_NAMES */\n"); -} - -void -dump_syntax_atoms(builtin_t[*] builtins) { -	printf("#ifdef AO_SCHEME_BUILTIN_SYNTAX_ATOMS\n"); -	printf("#undef AO_SCHEME_BUILTIN_SYNTAX_ATOMS\n"); -	printf("static const char *syntax_atoms[] = {\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\"%s\",\n", builtins[i].lisp_names[j].name); -			} -		} -	} -	printf("};\n"); -	printf("#endif /* AO_SCHEME_BUILTIN_SYNTAX_ATOMS */\n"); -} - -bool -has_feature(string[*] features, string feature) -{ -	for (int i = 0; i < dim(features); i++) -		if (features[i] == feature) -			return true; -	return false; -} - -void -dump_features(builtin_t[*] builtins) { -	string[...] features = {}; -	printf("#ifdef AO_SCHEME_BUILTIN_FEATURES\n"); -	for (int i = 0; i < dim(builtins); i++) { -		if (builtins[i].feature != "all") { -			string feature = builtins[i].feature; -			if (!has_feature(features, feature)) { -				features[dim(features)] = feature; -				printf("#ifndef AO_SCHEME_NO_FEATURE_%s\n", feature); -				printf("#define AO_SCHEME_FEATURE_%s\n", feature); -				printf("#endif /* AO_SCHEME_NO_FEATURE_%s */\n", feature); -			} -		} -	} -	printf("#endif /* AO_SCHEME_BUILTIN_FEATURES */\n"); -} - -void main() { -	if (dim(argv) < 2) { -		File::fprintf(stderr, "usage: %s <file>\n", argv[0]); -		exit(1); -	} -	twixt(file f = File::open(argv[1], "r"); File::close(f)) { -		builtin_t[*]	builtins = read_builtins(f); - -		printf("/* %d builtins */\n", dim(builtins)); -		dump_ids(builtins); -		dump_casename(builtins); -		dump_arrayname(builtins); -		dump_funcs(builtins); -		dump_decls(builtins); -		dump_consts(builtins); -		dump_atoms(builtins); -		dump_atom_names(builtins); -		dump_syntax_atoms(builtins); -		dump_features(builtins); -	} -} - -main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c deleted file mode 100644 index 8561bf0b..00000000 --- a/src/scheme/ao_scheme_make_const.c +++ /dev/null @@ -1,543 +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_scheme.h" -#include <stdlib.h> -#include <ctype.h> -#include <unistd.h> -#include <getopt.h> -#include <stdbool.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 { -	const char	*feature; -	const char	*name; -	int		args; -	enum ao_scheme_builtin_id	func; -}; - -struct builtin_atom { -	const char	*feature; -	const char	*name; -}; - -#define AO_SCHEME_BUILTIN_CONSTS -#define AO_SCHEME_BUILTIN_ATOM_NAMES - -#include "ao_scheme_builtin.h" - -#define N_FUNC		(sizeof funcs / sizeof funcs[0]) - -#define N_ATOM		(sizeof atoms / sizeof atoms[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; -} - -static 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; - -static 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; -} - -static 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 -static int macro_scan_depth; - -static 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); - -static 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; -} - -static ao_poly -ao_is_macro(ao_poly p) -{ -	struct ao_scheme_builtin	*builtin; -	struct ao_scheme_lambda	*lambda; -	ao_poly ret; - -	MACRO_DEBUG(indent(); ao_scheme_printf ("is macro %v\n", p); ++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(); ao_scheme_printf ("... %v\n", ret);); -	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(); ao_scheme_printf("has macro %v\n", p); ++macro_scan_depth); -	switch (ao_scheme_poly_type(p)) { -	case AO_SCHEME_LAMBDA: -		lambda = ao_scheme_poly_lambda(p); -		p = ao_has_macro(ao_scheme_poly_cons(lambda->code)->cdr); -		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 (ao_scheme_is_pair(list)) { -			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(); ao_scheme_printf("... %v\n", p)); -	return p; -} - -static struct ao_scheme_builtin * -ao_scheme_get_builtin(ao_poly p) -{ -	if (ao_scheme_poly_type(p) == AO_SCHEME_BUILTIN) -		return ao_scheme_poly_builtin(p); -	return NULL; -} - -struct seen_builtin { -	struct seen_builtin 		*next; -	struct ao_scheme_builtin	*builtin; -}; - -static struct seen_builtin *seen_builtins; - -static int -ao_scheme_seen_builtin(struct ao_scheme_builtin *b) -{ -	struct seen_builtin	*s; - -	for (s = seen_builtins; s; s = s->next) -		if (s->builtin == b) -			return 1; -	s = malloc (sizeof (struct seen_builtin)); -	s->builtin = b; -	s->next = seen_builtins; -	seen_builtins = s; -	return 0; -} - -static int -ao_scheme_read_eval_abort(FILE *read_file) -{ -	ao_poly	in; - -	for(;;) { -		in = ao_scheme_read(read_file); -		if (in == _ao_scheme_atom_eof) -			break; -		(void) ao_scheme_eval(in); -		if (ao_scheme_exception) { -			ao_scheme_fprintf(stderr, "make_const failed on %v\n", in); -			return 0; -		} -	} -	return 1; -} - -static FILE	*in; -static FILE	*out; - -struct feature { -	struct feature	*next; -	char		name[]; -}; - -static struct feature *enable; -static struct feature *disable; - -static void -ao_scheme_add_feature(struct feature **list, char *name) -{ -	struct feature *feature = malloc (sizeof (struct feature) + strlen(name) + 1); -	strcpy(feature->name, name); -	feature->next = *list; -	*list = feature; -} - -static bool -_ao_scheme_has_feature(struct feature *list, const char *name, bool skip_undef) -{ -	if (skip_undef && !strcmp(name, "UNDEF")) -		return false; - -	while (list) { -		if (!strcmp(list->name, name)) -			return true; -		list = list->next; -	} -	return false; -} - -static bool -ao_scheme_has_undef(struct feature *list) -{ -	return _ao_scheme_has_feature(list, "UNDEF", false); -} - -static bool -ao_scheme_has_feature(struct feature *list, const char *name) -{ -	return _ao_scheme_has_feature(list, name, true); -} - -static void -ao_scheme_add_features(struct feature **list, const char *names) -{ -	char	*saveptr = NULL; -	char	*name; -	char	*copy = strdup(names); -	char	*save = copy; - -	while ((name = strtok_r(copy, ",", &saveptr)) != NULL) { -		copy = NULL; -		if (!ao_scheme_has_feature(*list, name)) -			ao_scheme_add_feature(list, name); -	} -	free(save); -} - -int -ao_scheme_getc(void) -{ -	return getc(in); -} - -static const struct option options[] = { -	{ .name = "out", .has_arg = 1, .val = 'o' }, -	{ .name = "disable", .has_arg = 1, .val = 'd' }, -	{ .name = "enable", .has_arg = 1, .val = 'e' }, -	{ 0, 0, 0, 0 } -}; - -static void usage(char *program) -{ -	fprintf(stderr, "usage: %s [--out=<output>] [--disable={feature,...}] [--enable={feature,...} [input]\n", program); -	exit(1); -} - -int -main(int argc, char **argv) -{ -	int	f, o, an; -	ao_poly	val; -	struct ao_scheme_atom	*a; -	struct ao_scheme_builtin	*b; -	struct feature			*d; -	int	in_atom = 0; -	char	*out_name = NULL; -	int	c; -	enum ao_scheme_builtin_id	prev_func; -	enum ao_scheme_builtin_id	target_func; -	enum ao_scheme_builtin_id	func_map[_builtin_last]; - -	in = stdin; -	out = stdout; - -	while ((c = getopt_long(argc, argv, "o:d:e:", options, NULL)) != -1) { -		switch (c) { -		case 'o': -			out_name = optarg; -			break; -		case 'd': -			ao_scheme_add_features(&disable, optarg); -			break; -		case 'e': -			ao_scheme_add_features(&enable, 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; -	target_func = 0; -	b = NULL; -	for (f = 0; f < (int) N_FUNC; f++) { -		if (ao_scheme_has_feature(enable, funcs[f].feature) || !ao_scheme_has_feature(disable, funcs[f].feature)) { -			if (funcs[f].func != prev_func) { -				prev_func = funcs[f].func; -				b = ao_scheme_make_builtin(prev_func, funcs[f].args); - -				/* Target may have only a subset of -				 * the enum values; record what those -				 * values will be here. This obviously -				 * depends on the functions in the -				 * array being in the same order as -				 * the enumeration; which -				 * ao_scheme_make_builtin ensures. -				 */ -				func_map[prev_func] = target_func++; -			} -			a = ao_scheme_atom_intern((char *) funcs[f].name); -			ao_scheme_atom_def(ao_scheme_atom_poly(a), -					   ao_scheme_builtin_poly(b)); -		} -	} - -	/* atoms */ -	for (an = 0; an < (int) N_ATOM; an++) { -		if (ao_scheme_has_feature(enable, atoms[an].feature) || !ao_scheme_has_feature(disable, atoms[an].feature)) -			a = ao_scheme_atom_intern((char *) atoms[an].name); -	} - -	while (argv[optind]) { -		in = fopen(argv[optind], "r"); -		if (!in) { -			perror(argv[optind]); -			exit(1); -		} -		if (!ao_scheme_read_eval_abort(in)) { -			fprintf(stderr, "eval failed\n"); -			exit(1); -		} -		fclose(in); -		optind++; -	} - -	if (!ao_scheme_has_undef(enable) && ao_scheme_has_undef(disable)) { -		struct ao_scheme_cons cons; - -		cons.car = _ao_scheme_atom_undef; -		cons.cdr = AO_SCHEME_NIL; -		ao_scheme_do_undef(&cons); -	} - -	/* 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) { -			fprintf(stderr, "error: function %s contains unresolved macro: ", -				ao_scheme_poly_atom(vals->vals[f].atom)->name); -			ao_scheme_poly_write(stderr, val, true); -			fprintf(stderr, "\n"); -			exit(1); -		} - -		/* Remap builtin enum values to match target set */ -		b = ao_scheme_get_builtin(vals->vals[f].val); -		if (b != NULL) { -			if (!ao_scheme_seen_builtin(b)) -				b->func = func_map[b->func]; -		} -	} - -	if (out_name) { -		out = fopen(out_name, "w"); -		if (!out) { -			perror(out_name); -			exit(1); -		} -	} - -	fprintf(out, "/* Generated file, do not edit */\n\n"); - -	for (d = disable; d; d = d->next) -		fprintf(out, "#undef AO_SCHEME_FEATURE_%s\n", d->name); - -	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)) { -		const char	*n = a->name; -		char		ch; -		fprintf(out, "#define _ao_scheme_atom_"); -		while ((ch = *n++)) { -			if (isalnum(ch)) -				fprintf(out, "%c", ch); -			else -				fprintf(out, "%02x", ch); -		} -		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	ch; -		if ((o & 0xf) == 0) -			fprintf(out, "\n\t"); -		else -			fprintf(out, " "); -		ch = ao_scheme_const[o]; -		if (!in_atom) -			in_atom = is_atom(o); -		if (in_atom) { -			fprintf(out, " '%c',", ch); -			in_atom--; -		} else { -			fprintf(out, "0x%02x,", ch); -		} -	} -	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 deleted file mode 100644 index 94cbdfc1..00000000 --- a/src/scheme/ao_scheme_mem.c +++ /dev/null @@ -1,1117 +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_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 - -#define DBG_MEM_STACK	0 -#if DBG_MEM_STACK -char	*mem_collect_stack; -int64_t	mem_collect_max_depth; - -static void -ao_scheme_check_stack(void) -{ -	char	x; -	int64_t	depth; - -	depth = mem_collect_stack - &x; -	if (depth > mem_collect_max_depth) -		mem_collect_max_depth = depth; -} - -static void -_ao_scheme_reset_stack(char *x) -{ -	mem_collect_stack = x; -//	mem_collect_max_depth = 0; -} -#define ao_scheme_declare_stack	char x; -#define ao_scheme_reset_stack() _ao_scheme_reset_stack(&x) -#else -#define ao_scheme_check_stack() -#define ao_scheme_declare_stack -#define ao_scheme_reset_stack() -#endif - -#if DBG_MEM -#define DBG_MEM_RECORD	1 -#endif - -#if DBG_MEM -int dbg_move_depth; -int dbg_mem = DBG_MEM_START; -int dbg_validate = 0; -#endif - -#if DBG_MEM_RECORD -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(const 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() -#define ao_scheme_record(t,a,s) -#endif - -uint8_t	ao_scheme_exception; - -struct ao_scheme_root { -	const struct ao_scheme_type	*type; -	void				**addr; -}; - -#define AO_SCHEME_NUM_STASH	6 -static ao_poly			stash_poly[AO_SCHEME_NUM_STASH]; -static int			stash_poly_ptr; - -static const struct ao_scheme_root	ao_scheme_root[] = { -	{ -		.type = NULL, -		.addr = (void **) (void *) &stash_poly[0] -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &stash_poly[1] -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &stash_poly[2] -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &stash_poly[3] -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &stash_poly[4] -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &stash_poly[5] -	}, -	{ -		.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_FEATURE_PORT -	{ -		.type = NULL, -		.addr = (void **) (void *) &ao_scheme_stdin, -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &ao_scheme_stdout, -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &ao_scheme_stderr, -	}, -#endif -#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 int	ao_scheme_printing, ao_scheme_print_cleared; -#if DBG_MEM -static int	ao_scheme_collecting; -#endif -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	(AO_SCHEME_POOL / 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(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; -	ao_scheme_check_stack(); -	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 inline 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; -	int end; - -	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(); - -	if (l < chunk_last && ao_scheme_chunk[l].old_offset == offset) -		ao_scheme_abort(); -#endif - -	/* Shuffle existing entries right */ -	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; -	printf("busy:"); -	for (i = 0; i < ao_scheme_top; i += 4) { -		if ((i & 0xff) == 0) { -			printf("\n\t"); -		} -		else if ((i & 0x1f) == 0) -			printf(" "); -		if (busy(ao_scheme_busy, i)) -			printf("*"); -		else -			printf("-"); -	} -	printf ("\n"); -} -#define DUMP_BUSY()	dump_busy() -#else -#define DUMP_BUSY() -#endif - -#if MDBG_DUMP -static void -dump_atoms(int show_marked) -{ -	struct ao_scheme_atom	*atom; - -	printf("atoms {\n"); -	for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { -		printf("\t%d: %s", MDBG_OFFSET(atom), atom->name); -		if (show_marked) -			printf(" %s", ao_scheme_marked(atom) ? "referenced" : "unreferenced"); -		printf("\n"); -	} -	printf("}\n"); - -} -#define DUMP_ATOMS(a)	dump_atoms(a) -#else -#define DUMP_ATOMS(a) -#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, -#ifdef AO_SCHEME_FEATURE_BIGINT -	[AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, -#endif -	[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_STRING] = &ao_scheme_string_type, -#ifdef AO_SCHEME_FEATURE_FLOAT -	[AO_SCHEME_FLOAT] = &ao_scheme_float_type, -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR -	[AO_SCHEME_VECTOR] = &ao_scheme_vector_type, -#endif -#ifdef AO_SCHEME_FEATURE_PORT -	[AO_SCHEME_PORT] = &ao_scheme_port_type, -#endif -}; - -static int -ao_scheme_mark(const struct ao_scheme_type *type, void *addr); - -static int -ao_scheme_move(const struct ao_scheme_type *type, void **ref); - -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 -uint64_t ao_scheme_collects[2]; -uint64_t ao_scheme_freed[2]; -uint64_t ao_scheme_loops[2]; -#endif - -int ao_scheme_last_top; -int ao_scheme_collect_counts; - -int -ao_scheme_collect(uint8_t style) -{ -	ao_scheme_declare_stack -	int	i; -	int	top; -#if DBG_MEM_STATS -	int	loops = 0; -#endif -#if DBG_MEM_RECORD -	struct ao_scheme_record	*mark_record = NULL, *move_record = NULL; -#endif -	MDBG_MOVE("collect %lu\n", ao_scheme_collects[style]); - -	MDBG_DO(ao_scheme_frame_write(stdout, ao_scheme_frame_poly(ao_scheme_frame_global), true)); -	MDBG_DO(++ao_scheme_collecting); - -	ao_scheme_reset_stack(); - -	/* The first time through, we're doing a full collect */ -	if (ao_scheme_last_top == 0) -		style = AO_SCHEME_COLLECT_FULL; - -	/* One in a while, just do a full collect */ - -	if (ao_scheme_collect_counts >= 128) -		style = AO_SCHEME_COLLECT_FULL; - -	if (style == AO_SCHEME_COLLECT_FULL) -		ao_scheme_collect_counts = 0; - -	/* 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 (;;) { -		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); - -#ifdef AO_SCHEME_FEATURE_PORT -		ao_scheme_port_check_references(); -#endif -		ao_scheme_atom_check_references(); - -#if DBG_MEM_RECORD -		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_ATOMS(1); -		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; -		} - -		/* Short-circuit the rest of the loop when all of the -		 * found objects aren't moving. This isn't strictly -		 * necessary as the rest of the loop is structured to -		 * work in this case, but GCC 7.2.0 with optimization -		 * greater than 2 generates incorrect code for this... -		 */ -		if (i == AO_SCHEME_NCHUNK) { -			chunk_low = chunk_high; -#if DBG_MEM_STATS -			loops++; -#endif -			continue; -		} - -		/* -		 * 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); -			ao_scheme_atom_move(); -#ifdef AO_SCHEME_FEATURE_PORT -			/* the set of open ports gets relocated but not marked, so -			 * just deal with it separately -			 */ -			ao_scheme_poly_move(&ao_scheme_open_ports, 0); -#endif - -#if DBG_MEM_RECORD -			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 -			DUMP_ATOMS(0); -		} - -#if DBG_MEM_STATS -		loops++; -#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)); - -#if DBG_MEM_STACK -	fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth); -#endif -	MDBG_DO(--ao_scheme_collecting); -	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_addr(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 - */ - - -/* - * 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(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 - */ -static int -ao_scheme_mark(const struct ao_scheme_type *type, void *addr) -{ -	int ret; -	MDBG_MOVE("mark offset %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; -	int	ret; - -	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(addr)) -		return 1; - -	if (type == AO_SCHEME_CONS && do_note_cons) { -		note_cons(pool_offset(addr)); -		return 1; -	} else { -		const struct ao_scheme_type *lisp_type; - -		if (type == AO_SCHEME_OTHER) -			type = ao_scheme_other_type(addr); - -		lisp_type = ao_scheme_types[type]; -#if DBG_MEM -		if (!lisp_type) -			ao_scheme_abort(); -#endif - -		MDBG_MOVE("poly_mark offset %d\n", MDBG_OFFSET(addr)); -		MDBG_MOVE_IN(); -		ret = ao_scheme_mark_memory(lisp_type, addr); -		if (!ret) { -			MDBG_MOVE("mark recurse\n"); -			lisp_type->mark(addr); -		} -		MDBG_MOVE_OUT(); -		return ret; -	} -} - -/* - * 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(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_addr(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); -	ao_scheme_record(type, addr, ao_scheme_size(type, addr)); -	return 0; -} - -static 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) -{ -	ao_poly		p = *ref; -	int		ret; -	void		*addr; -	uint16_t	offset, orig_offset; - -	if (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) -		return 1; - -	addr = ao_scheme_ref(p); -	if (!ao_scheme_is_pool_addr(addr)) -		return 1; - -	orig_offset = pool_offset(addr); -	offset = move_map(orig_offset); - -	if (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS && do_note_cons) { -		note_cons(orig_offset); -		ret = 1; -	} else { -		uint8_t type = ao_scheme_poly_base_type(p); -		const struct ao_scheme_type *lisp_type; - -		if (type == AO_SCHEME_OTHER) -			type = ao_scheme_other_type(ao_scheme_pool + offset); - -		lisp_type = ao_scheme_types[type]; -#if DBG_MEM -		if (!lisp_type) -			ao_scheme_abort(); -#endif -		/* inline ao_scheme_move to save stack space */ -		MDBG_MOVE("move object %d\n", MDBG_OFFSET(addr)); -		MDBG_MOVE_IN(); -		ret = ao_scheme_move_memory(lisp_type, &addr); -		if (!ret) { -			MDBG_MOVE("move recurse\n"); -			lisp_type->move(addr); -		} -		MDBG_MOVE_OUT(); -	} - -	/* Re-write the poly value */ -	if (offset != orig_offset) { -		ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p)); -		MDBG_MOVE("poly %d moved %d -> %d\n", -			  ao_scheme_poly_type(np), orig_offset, offset); -		*ref = np; -	} -	return ret; -} - -int -ao_scheme_marked(void *addr) -{ -	if (!ao_scheme_is_pool_addr(addr)) -		return 1; -	return busy(ao_scheme_busy, pool_offset(addr)); -} - -#if DBG_MEM -static 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_poly_stash(ao_poly p) -{ -	assert(stash_poly_ptr < AO_SCHEME_NUM_STASH); -	stash_poly[stash_poly_ptr++] = p; -} - -ao_poly -ao_scheme_poly_fetch(void) -{ -	ao_poly	p; - -	assert (stash_poly_ptr > 0); -	p = stash_poly[--stash_poly_ptr]; -	stash_poly[stash_poly_ptr] = AO_SCHEME_NIL; -	return p; -} - -int -ao_scheme_print_mark_addr(void *addr) -{ -	int	offset; - -#if DBG_MEM -	if (ao_scheme_collecting) -		ao_scheme_abort(); -#endif - -	if (!ao_scheme_is_pool_addr(addr)) -		return 0; - -	if (!ao_scheme_print_cleared) { -		ao_scheme_print_cleared = 1; -		memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); -	} -	offset = pool_offset(addr); -	if (busy(ao_scheme_busy, offset)) -		return 1; -	mark(ao_scheme_busy, offset); -	return 0; -} - -void -ao_scheme_print_clear_addr(void *addr) -{ -	int	offset; - -#if DBG_MEM -	if (ao_scheme_collecting) -		ao_scheme_abort(); -#endif - -	if (!ao_scheme_is_pool_addr(addr)) -		return; - -	if (!ao_scheme_print_cleared) -		return; -	offset = pool_offset(addr); -	clear(ao_scheme_busy, offset); -} - -/* Notes that printing has started */ -void -ao_scheme_print_start(void) -{ -	ao_scheme_printing++; -} - -/* Notes that printing has ended. Returns 1 if printing is still going on */ -int -ao_scheme_print_stop(void) -{ -	ao_scheme_printing--; -	if (ao_scheme_printing != 0) -		return 1; -	ao_scheme_print_cleared = 0; -	return 0; -} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c deleted file mode 100644 index 8a92c9f2..00000000 --- a/src/scheme/ao_scheme_poly.c +++ /dev/null @@ -1,74 +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_scheme.h" - -static void ao_scheme_invalid_write(FILE *out, ao_poly p, bool write) { -	fprintf(out, "??? type %d poly 0x%04x ???", ao_scheme_poly_type (p), p); -	(void) write; -	ao_scheme_abort(); -} - -static void (*const ao_scheme_write_funcs[AO_SCHEME_NUM_TYPE]) (FILE *out, ao_poly p, bool write) = { -	[AO_SCHEME_CONS] = ao_scheme_cons_write, -#ifdef AO_SCHEME_FEATURE_BIGINT -	[AO_SCHEME_BIGINT] = ao_scheme_bigint_write, -#endif -	[AO_SCHEME_INT] = ao_scheme_int_write, -	[AO_SCHEME_ATOM] = ao_scheme_atom_write, -	[AO_SCHEME_BUILTIN] = ao_scheme_builtin_write, -	[AO_SCHEME_FRAME] = ao_scheme_frame_write, -	[AO_SCHEME_FRAME_VALS] = ao_scheme_invalid_write, -	[AO_SCHEME_LAMBDA] = ao_scheme_lambda_write, -	[AO_SCHEME_STACK] = ao_scheme_stack_write, -	[AO_SCHEME_BOOL] = ao_scheme_bool_write, -	[AO_SCHEME_STRING] = ao_scheme_string_write, -#ifdef AO_SCHEME_FEATURE_FLOAT -	[AO_SCHEME_FLOAT] = ao_scheme_float_write, -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR -	[AO_SCHEME_VECTOR] = ao_scheme_vector_write, -#endif -#ifdef AO_SCHEME_FEATURE_PORT -	[AO_SCHEME_PORT] = ao_scheme_port_write, -#endif -}; - -void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write) -{ -	uint8_t	type = ao_scheme_poly_type(p); - -	if (type < AO_SCHEME_NUM_TYPE) -		return ao_scheme_write_funcs[type]; -	return ao_scheme_invalid_write; -} - -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_addr(a)) -		return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; -	return (a - ao_scheme_pool + 4) | type; -} diff --git a/src/scheme/ao_scheme_port.c b/src/scheme/ao_scheme_port.c deleted file mode 100644 index b5e5d8dc..00000000 --- a/src/scheme/ao_scheme_port.c +++ /dev/null @@ -1,193 +0,0 @@ -/* - * Copyright © 2018 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" - -#ifdef AO_SCHEME_FEATURE_PORT - -static void port_mark(void *addr) -{ -	(void) addr; -} - -static int port_size(void *addr) -{ -	(void) addr; -	return sizeof(struct ao_scheme_port); -} - -static void port_move(void *addr) -{ -	struct ao_scheme_port	*port = addr; - -	(void) ao_scheme_poly_move(&port->next, 0); -} - -const struct ao_scheme_type	ao_scheme_port_type = { -	.mark = port_mark, -	.size = port_size, -	.move = port_move, -	.name = "port", -}; - -void -ao_scheme_port_write(FILE *out, ao_poly v, bool write) -{ -	(void) write; -	ao_scheme_fprintf(out, "#port<%d>", fileno(ao_scheme_poly_port(v)->file)); -} - -ao_poly		ao_scheme_stdin, ao_scheme_stdout, ao_scheme_stderr; - -ao_poly		ao_scheme_open_ports; - -void -ao_scheme_port_check_references(void) -{ -	struct ao_scheme_port	*p; - -	for (p = ao_scheme_poly_port(ao_scheme_open_ports); p; p = ao_scheme_poly_port(p->next)) { -		if (!ao_scheme_marked(p)) -			ao_scheme_port_close(p); -	} -} - -struct ao_scheme_port * -ao_scheme_port_alloc(FILE *file, bool stayopen) -{ -	struct ao_scheme_port	*p; - -	p = ao_scheme_alloc(sizeof (struct ao_scheme_port)); -	if (!p) -		return NULL; -	p->type = AO_SCHEME_PORT; -	p->stayopen = stayopen; -	p->file = file; -	p->next = ao_scheme_open_ports; -	ao_scheme_open_ports = ao_scheme_port_poly(p); -	return p; -} - -void -ao_scheme_port_close(struct ao_scheme_port *port) -{ -	ao_poly			*prev; -	struct ao_scheme_port	*ref; - -	if (port->file && !port->stayopen) { -		fclose(port->file); -		port->file = NULL; -		for (prev = &ao_scheme_open_ports; (ref = ao_scheme_poly_port(*prev)); prev = &ref->next) -			if (ref == port) { -				*prev = port->next; -				break; -			} -	} -} - -ao_poly -ao_scheme_do_portp(struct ao_scheme_cons *cons) -{ -	return ao_scheme_do_typep(_ao_scheme_atom_port3f, AO_SCHEME_PORT, cons); -} - -ao_poly -ao_scheme_do_port_openp(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_port	*port; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons, -				  AO_SCHEME_PORT, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return port->file ? _ao_scheme_bool_true : _ao_scheme_bool_false; -} - -static ao_poly -ao_scheme_do_open_file(ao_poly proc, struct ao_scheme_cons *cons, const char *mode) -{ -	FILE			*file; -	struct ao_scheme_string	*name; - -	if (!ao_scheme_parse_args(proc, cons, -				  AO_SCHEME_STRING, &name, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	file = fopen(name->val, mode); -	if (!file) -		return ao_scheme_error(AO_SCHEME_FILEERROR, -				       "%v: no such file \"%v\"", -				       proc, name); -	return ao_scheme_port_poly(ao_scheme_port_alloc(file, false)); -} - -ao_poly -ao_scheme_do_open_input_file(struct ao_scheme_cons *cons) -{ -	return ao_scheme_do_open_file(_ao_scheme_atom_open2dinput2dfile, cons, "r"); -} - -ao_poly -ao_scheme_do_open_output_file(struct ao_scheme_cons *cons) -{ -	return ao_scheme_do_open_file(_ao_scheme_atom_open2doutput2dfile, cons, "w"); -} - -ao_poly -ao_scheme_do_close_port(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_port	*port; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons, -				  AO_SCHEME_PORT, &port, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	ao_scheme_port_close(port); -	return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_current_input_port(struct ao_scheme_cons *cons) -{ -	if (!ao_scheme_parse_args(_ao_scheme_atom_current2dinput2dport, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (!ao_scheme_stdin) -		ao_scheme_stdin = ao_scheme_port_poly(ao_scheme_port_alloc(stdin, true)); -	return ao_scheme_stdin; -} - -ao_poly -ao_scheme_do_current_output_port(struct ao_scheme_cons *cons) -{ -	if (!ao_scheme_parse_args(_ao_scheme_atom_current2doutput2dport, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (!ao_scheme_stdout) -		ao_scheme_stdout = ao_scheme_port_poly(ao_scheme_port_alloc(stdout, true)); -	return ao_scheme_stdout; -} - -ao_poly -ao_scheme_do_current_error_port(struct ao_scheme_cons *cons) -{ -	if (!ao_scheme_parse_args(_ao_scheme_atom_current2derror2dport, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (!ao_scheme_stderr) -		ao_scheme_stderr = ao_scheme_port_poly(ao_scheme_port_alloc(stderr, true)); -	return ao_scheme_stderr; -} - -#endif /* AO_SCHEME_FEATURE_PORT */ diff --git a/src/scheme/ao_scheme_port.scheme b/src/scheme/ao_scheme_port.scheme deleted file mode 100644 index 886aed25..00000000 --- a/src/scheme/ao_scheme_port.scheme +++ /dev/null @@ -1,43 +0,0 @@ -; -; Copyright © 2018 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. -; -; port functions placed in ROM - - -(define newline -  (lambda args -    (if (null? args) -	(write-char #\newline) -	(write-char #\newline (car args)) -	) -    ) -  ) - -(newline) -(newline (open-output-file "/dev/null")) - -(define (eof-object? a) -  (equal? a 'eof) -  ) - -(define (load name) -  (let ((p (open-input-file name)) -	(e)) -    (while (not (eof-object? (set! e (read p)))) -	   (write (eval e)) (newline) -	   ) -    (close-port p) -    ) -  ) - -(load "/dev/null") diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c deleted file mode 100644 index 3575ff3f..00000000 --- a/src/scheme/ao_scheme_read.c +++ /dev/null @@ -1,727 +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_scheme.h" -#include "ao_scheme_read.h" -#include <math.h> -#include <stdlib.h> - -static const uint16_t	lex_classes[128] = { -	IGNORE,				/* ^@ */ -	IGNORE,				/* ^A */ -	IGNORE,				/* ^B */ -	IGNORE,				/* ^C */ -	IGNORE,				/* ^D */ -	IGNORE,				/* ^E */ -	IGNORE,				/* ^F */ -	IGNORE,				/* ^G */ -	IGNORE,				/* ^H */ -	WHITE,				/* ^I */ -	WHITE,				/* ^J */ -	WHITE,				/* ^K */ -	WHITE,				/* ^L */ -	WHITE,				/* ^M */ -	IGNORE,				/* ^N */ -	IGNORE,				/* ^O */ -	IGNORE,				/* ^P */ -	IGNORE,				/* ^Q */ -	IGNORE,				/* ^R */ -	IGNORE,				/* ^S */ -	IGNORE,				/* ^T */ -	IGNORE,				/* ^U */ -	IGNORE,				/* ^V */ -	IGNORE,				/* ^W */ -	IGNORE,				/* ^X */ -	IGNORE,				/* ^Y */ -	IGNORE,				/* ^Z */ -	IGNORE,				/* ^[ */ -	IGNORE,				/* ^\ */ -	IGNORE,				/* ^] */ -	IGNORE,				/* ^^ */ -	IGNORE,				/* ^_ */ -	PRINTABLE|WHITE,		/*    */ - 	PRINTABLE,			/* ! */ - 	PRINTABLE|STRINGC,		/* " */ - 	PRINTABLE,			/* # */ - 	PRINTABLE,			/* $ */ - 	PRINTABLE,			/* % */ - 	PRINTABLE,			/* & */ - 	PRINTABLE|SPECIAL,		/* ' */ - 	PRINTABLE|SPECIAL,		/* ( */ - 	PRINTABLE|SPECIAL,		/* ) */ - 	PRINTABLE,			/* * */ - 	PRINTABLE|SIGN,			/* + */ - 	PRINTABLE|SPECIAL_QUASI,	/* , */ - 	PRINTABLE|SIGN,			/* - */ - 	PRINTABLE|SPECIAL|FLOATC,	/* . */ - 	PRINTABLE,			/* / */ - 	PRINTABLE|DIGIT,		/* 0 */ - 	PRINTABLE|DIGIT,		/* 1 */ - 	PRINTABLE|DIGIT,		/* 2 */ - 	PRINTABLE|DIGIT,		/* 3 */ - 	PRINTABLE|DIGIT,		/* 4 */ - 	PRINTABLE|DIGIT,		/* 5 */ - 	PRINTABLE|DIGIT,		/* 6 */ - 	PRINTABLE|DIGIT,		/* 7 */ - 	PRINTABLE|DIGIT,		/* 8 */ - 	PRINTABLE|DIGIT,		/* 9 */ - 	PRINTABLE,			/* : */ - 	PRINTABLE|COMMENT,		/* ; */ - 	PRINTABLE,			/* < */ - 	PRINTABLE,			/* = */ - 	PRINTABLE,			/* > */ - 	PRINTABLE,			/* ? */ -  	PRINTABLE,			/*  @ */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  A */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  B */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  C */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  D */ -	PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/*  E */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  F */ -	PRINTABLE|ALPHA,		/*  G */ -	PRINTABLE|ALPHA,		/*  H */ -	PRINTABLE|ALPHA,		/*  I */ -	PRINTABLE|ALPHA,		/*  J */ -	PRINTABLE|ALPHA,		/*  K */ -	PRINTABLE|ALPHA,		/*  L */ -	PRINTABLE|ALPHA,		/*  M */ -	PRINTABLE|ALPHA,		/*  N */ -	PRINTABLE|ALPHA,		/*  O */ -	PRINTABLE|ALPHA,		/*  P */ -	PRINTABLE|ALPHA,		/*  Q */ -	PRINTABLE|ALPHA,		/*  R */ -	PRINTABLE|ALPHA,		/*  S */ -	PRINTABLE|ALPHA,		/*  T */ -	PRINTABLE|ALPHA,		/*  U */ -	PRINTABLE|ALPHA,		/*  V */ -	PRINTABLE|ALPHA,		/*  W */ -	PRINTABLE|ALPHA,		/*  X */ -	PRINTABLE|ALPHA,		/*  Y */ -	PRINTABLE|ALPHA,		/*  Z */ -	PRINTABLE,			/*  [ */ -	PRINTABLE,			/*  \ */ -	PRINTABLE,			/*  ] */ -	PRINTABLE,			/*  ^ */ -	PRINTABLE,			/*  _ */ -  	PRINTABLE|SPECIAL_QUASI,	/*  ` */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  a */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  b */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  c */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  d */ -	PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/*  e */ -	PRINTABLE|ALPHA|HEX_LETTER,	/*  f */ -	PRINTABLE|ALPHA,		/*  g */ -	PRINTABLE|ALPHA,		/*  h */ -	PRINTABLE|ALPHA,		/*  i */ -	PRINTABLE|ALPHA,		/*  j */ -	PRINTABLE|ALPHA,		/*  k */ -	PRINTABLE|ALPHA,		/*  l */ -	PRINTABLE|ALPHA,		/*  m */ -	PRINTABLE|ALPHA,		/*  n */ -	PRINTABLE|ALPHA,		/*  o */ -	PRINTABLE|ALPHA,		/*  p */ -	PRINTABLE|ALPHA,		/*  q */ -	PRINTABLE|ALPHA,		/*  r */ -	PRINTABLE|ALPHA,		/*  s */ -	PRINTABLE|ALPHA,		/*  t */ -	PRINTABLE|ALPHA,		/*  u */ -	PRINTABLE|ALPHA,		/*  v */ -	PRINTABLE|ALPHA,		/*  w */ -	PRINTABLE|ALPHA,		/*  x */ -	PRINTABLE|ALPHA,		/*  y */ -	PRINTABLE|ALPHA,		/*  z */ -	PRINTABLE,			/*  { */ -	PRINTABLE,			/*  | */ -	PRINTABLE,			/*  } */ -	PRINTABLE,			/*  ~ */ -	IGNORE,				/*  ^? */ -}; - -static int lex_unget_c; - -#ifndef ao_scheme_getc -#define ao_scheme_getc(f) getc(f) -#endif - -static inline int -lex_get(FILE *in) -{ -	int	c; -	if (lex_unget_c) { -		c = lex_unget_c; -		lex_unget_c = 0; -	} else { -		c = ao_scheme_getc(in); -	} -	return c; -} - -static inline void -lex_unget(int c) -{ -	if (c != EOF) -		lex_unget_c = c; -} - -static uint16_t	lex_class; - -static int -lexc(FILE *in) -{ -	int	c; -	do { -		c = lex_get(in); -		if (c == EOF) { -			c = 0; -			lex_class = ENDOFFILE; -		} else { -			lex_class = PRINTABLE; -			if (c <= 0x7f) -				lex_class = lex_classes[c]; -		} -	} while (lex_class & IGNORE); -	return c; -} - -static int -lex_quoted(FILE *in) -{ -	int	c; -	int	v; -	int	count; - -	c = lex_get(in); -	if (c == EOF) { -	eof: -		lex_class = ENDOFFILE; -		return 0; -	} -	lex_class = 0; -	c &= 0x7f; - 	switch (c) { -	case 'a': -		return '\a'; -	case 'b': -		return '\b'; -	case 't': -		return '\t'; -	case 'n': -		return '\n'; -	case 'r': -		return '\r'; -	case 'f': -		return '\f'; -	case 'v': -		return '\v'; -	case '0': -	case '1': -	case '2': -	case '3': -	case '4': -	case '5': -	case '6': -	case '7': -		v = c - '0'; -		count = 1; -		while (count <= 3) { -			c = lex_get(in); -			if (c == EOF) -				goto eof; -			c &= 0x7f; -			if (c < '0' || '7' < c) { -				lex_unget(c); -				break; -			} -			v = (v << 3) + c - '0'; -			++count; -		} -		return v; -	default: -		return c; -	} -} - -#ifndef AO_SCHEME_TOKEN_MAX -#define AO_SCHEME_TOKEN_MAX	128 -#endif - -static char	token_string[AO_SCHEME_TOKEN_MAX]; -static int32_t	token_int; -static int	token_len; - -static void start_token(void) { -	token_len = 0; -} - -static void add_token(int c) { -	if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) -		token_string[token_len++] = c; -} - -static void end_token(void) { -	token_string[token_len] = '\0'; -} - -#ifdef AO_SCHEME_FEATURE_FLOAT -static float	token_float; - -struct namedfloat { -	const char	*name; -	float		value; -}; - -static const struct namedfloat namedfloats[] = { -	{ .name = "+inf.0", .value = INFINITY }, -	{ .name = "-inf.0", .value = -INFINITY }, -	{ .name = "+nan.0", .value = NAN }, -	{ .name = "-nan.0", .value = NAN }, -}; - -#define NUM_NAMED_FLOATS	(sizeof namedfloats / sizeof namedfloats[0]) -#endif - -static int -parse_int(FILE *in, int base) -{ -	int	cval; -	int	c; - -	token_int = 0; -	for (;;) { -		c = lexc(in); -		if ((lex_class & HEX_DIGIT) == 0) { -			lex_unget(c); -			return NUM; -		} -		if ('0' <= c && c <= '9') -			cval = c - '0'; -		else -			cval = (c | ('a' - 'A')) - 'a' + 10; -		token_int = token_int * base + cval; -	} -	return NUM; -} - -static int -_lex(FILE *in) -{ -	int	c; - -	start_token(); -	for (;;) { -		c = lexc(in); -		if (lex_class & ENDOFFILE) -			return END; - -		if (lex_class & WHITE) -			continue; - -		if (lex_class & COMMENT) { -			while ((c = lexc(in)) != '\n') { -				if (lex_class & ENDOFFILE) -					return END; -			} -			continue; -		} - -		if (lex_class & SPECIAL) { -			switch (c) { -			case '(': -			case '[': -				return OPEN; -			case ')': -			case ']': -				return CLOSE; -			case '\'': -				return QUOTE; -			case '.': -				return DOT; -#ifdef AO_SCHEME_FEATURE_QUASI -			case '`': -				return QUASIQUOTE; -			case ',': -				c = lexc(in); -				if (c == '@') { -					return UNQUOTE_SPLICING; -				} else { -					lex_unget(c); -					return UNQUOTE; -				} -#endif -			} -		} -		if (c == '#') { -			c = lexc(in); -			switch (c) { -			case 't': -				return TRUE_TOKEN; -			case 'f': -				return FALSE_TOKEN; -#ifdef AO_SCHEME_FEATURE_VECTOR -			case '(': -				return OPEN_VECTOR; -#endif -			case '\\': -				for (;;) { -					c = lexc(in); -					if (token_len == 0) { -						add_token(c); -						if (!(lex_class & ALPHA)) -							break; -					} else { -						if (lex_class & ALPHA) -							add_token(c); -						else { -							lex_unget(c); -							break; -						} -					} -				} -				end_token(); -				if (token_len == 1) -					token_int = token_string[0]; -				else if (!strcmp(token_string, "space")) -					token_int = ' '; -				else if (!strcmp(token_string, "newline")) -					token_int = '\n'; -				else if (!strcmp(token_string, "tab")) -					token_int = '\t'; -				else if (!strcmp(token_string, "return")) -					token_int = '\r'; -				else if (!strcmp(token_string, "formfeed")) -					token_int = '\f'; -				else { -					ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string); -					continue; -				} -				return NUM; -			case 'x': -				return parse_int(in, 16); -			case 'o': -				return parse_int(in, 8); -			case 'b': -				return parse_int(in, 2); -			} -		} -		if (lex_class & STRINGC) { -			for (;;) { -				c = lexc(in); -				if (c == '\\') -					c = lex_quoted(in); -				if (lex_class & (STRINGC|ENDOFFILE)) { -					end_token(); -					return STRING; -				} -				add_token(c); -			} -		} -		if (lex_class & PRINTABLE) { -#ifdef AO_SCHEME_FEATURE_FLOAT -			int	isfloat = 1; -			int	epos = 0; -#endif -			int	hasdigit = 0; -			int	isneg = 0; -			int	isint = 1; - -			token_int = 0; -			for (;;) { -				if (!(lex_class & NUMBER)) { -					isint = 0; -#ifdef AO_SCHEME_FEATURE_FLOAT -					isfloat = 0; -#endif -				} else { -#ifdef AO_SCHEME_FEATURE_FLOAT -					if (!(lex_class & INTEGER)) -						isint = 0; - 					if (token_len != epos && -					    (lex_class & SIGN)) -					{ -						isint = 0; -						isfloat = 0; -					} -#endif -					if (c == '-') -						isneg = 1; -#ifdef AO_SCHEME_FEATURE_FLOAT -					if (c == '.' && epos != 0) -						isfloat = 0; -					if (c == 'e' || c == 'E') { -						if (token_len == 0) -							isfloat = 0; -						else -							epos = token_len + 1; -					} -#endif -					if (lex_class & DIGIT) { -						hasdigit = 1; -						if (isint) -							token_int = token_int * 10 + c - '0'; -					} -				} -				add_token (c); -				c = lexc (in); -				if ((lex_class & (NOTNAME)) -#ifdef AO_SCHEME_FEATURE_FLOAT -				    && (c != '.' || !isfloat) -#endif -					) { -#ifdef AO_SCHEME_FEATURE_FLOAT -					unsigned int u; -#endif -					lex_unget(c); -					end_token (); -					if (isint && hasdigit) { -						if (isneg) -							token_int = -token_int; -						return NUM; -					} -#ifdef AO_SCHEME_FEATURE_FLOAT -					if (isfloat && hasdigit) { -						token_float = strtof(token_string, NULL); -						return FLOAT; -					} -					for (u = 0; u < NUM_NAMED_FLOATS; u++) -						if (!strcmp(namedfloats[u].name, token_string)) { -							token_float = namedfloats[u].value; -							return FLOAT; -						} -#endif -					return NAME; -				} -			} -		} -	} -} - -static inline int lex(FILE *in) -{ -	int	parse_token = _lex(in); -	RDBGI("token %d \"%s\"\n", parse_token, token_string); -	return parse_token; -} - -static int parse_token; - -int			ao_scheme_read_list; -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; -static int		ao_scheme_read_state; - -#define READ_IN_QUOTE	0x01 -#define READ_SAW_DOT	0x02 -#define READ_DONE_DOT	0x04 -#define READ_SAW_VECTOR	0x08 - -static int -push_read_stack(int read_state) -{ -	RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); -	RDBG_IN(); -	if (ao_scheme_read_list) { -		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; -	} else -		ao_scheme_read_state = read_state; -	ao_scheme_read_cons = NULL; -	ao_scheme_read_cons_tail = NULL; -	return 1; -} - -static int -pop_read_stack(void) -{ -	int	read_state = 0; -	if (ao_scheme_read_list) { -		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 { -		read_state = ao_scheme_read_state; -		ao_scheme_read_cons = NULL; -		ao_scheme_read_cons_tail = NULL; -		ao_scheme_read_stack = NULL; -		ao_scheme_read_state = 0; -	} -	RDBG_OUT(); -	RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); -	return read_state; -} - -#ifdef AO_SCHEME_FEATURE_VECTOR -#define is_open(t) ((t) == OPEN || (t) == OPEN_VECTOR) -#else -#define is_open(t) ((t) == OPEN) -#endif - -ao_poly -ao_scheme_read(FILE *in) -{ -	struct ao_scheme_atom	*atom; -	struct ao_scheme_string	*string; -	int			read_state; -	ao_poly			v = AO_SCHEME_NIL; - -	ao_scheme_read_list = 0; -	read_state = 0; -	ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = NULL; -	for (;;) { -		parse_token = lex(in); -		while (is_open(parse_token)) { -#ifdef AO_SCHEME_FEATURE_VECTOR -			if (parse_token == OPEN_VECTOR) -				read_state |= READ_SAW_VECTOR; -#endif -			if (!push_read_stack(read_state)) -				return AO_SCHEME_NIL; -			ao_scheme_read_list++; -			read_state = 0; -			parse_token = lex(in); -		} - -		switch (parse_token) { -		case END: -		default: -			if (ao_scheme_read_list) -				ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); -			return _ao_scheme_atom_eof; -			break; -		case NAME: -			atom = ao_scheme_atom_intern(token_string); -			if (atom) -				v = ao_scheme_atom_poly(atom); -			else -				v = AO_SCHEME_NIL; -			break; -		case NUM: -			v = ao_scheme_integer_poly(token_int); -			break; -#ifdef AO_SCHEME_FEATURE_FLOAT -		case FLOAT: -			v = ao_scheme_float_get(token_float); -			break; -#endif -		case TRUE_TOKEN: -			v = _ao_scheme_bool_true; -			break; -		case FALSE_TOKEN: -			v = _ao_scheme_bool_false; -			break; -		case STRING: -			string = ao_scheme_string_new(token_string); -			if (string) -				v = ao_scheme_string_poly(string); -			else -				v = AO_SCHEME_NIL; -			break; -		case QUOTE: -#ifdef AO_SCHEME_FEATURE_QUASI -		case QUASIQUOTE: -		case UNQUOTE: -		case UNQUOTE_SPLICING: -#endif -			if (!push_read_stack(read_state)) -				return AO_SCHEME_NIL; -			ao_scheme_read_list++; -			read_state = READ_IN_QUOTE; -			switch (parse_token) { -			case QUOTE: -				v = _ao_scheme_atom_quote; -				break; -#ifdef AO_SCHEME_FEATURE_QUASI -			case QUASIQUOTE: -				v = _ao_scheme_atom_quasiquote; -				break; -			case UNQUOTE: -				v = _ao_scheme_atom_unquote; -				break; -			case UNQUOTE_SPLICING: -				v = _ao_scheme_atom_unquote2dsplicing; -				break; -#endif -			} -			break; -		case CLOSE: -			if (!ao_scheme_read_list) { -				v = AO_SCHEME_NIL; -				break; -			} -			v = ao_scheme_cons_poly(ao_scheme_read_cons); -			--ao_scheme_read_list; -			read_state = pop_read_stack(); -#ifdef AO_SCHEME_FEATURE_VECTOR -			if (read_state & READ_SAW_VECTOR) { -				v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); -				read_state &= ~READ_SAW_VECTOR; -			} -#endif -			break; -		case DOT: -			if (!ao_scheme_read_list) { -				ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); -				return AO_SCHEME_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; -		} - -		/* loop over QUOTE ends */ -		for (;;) { -			if (!ao_scheme_read_list) -				return v; - -			if (read_state & READ_DONE_DOT) { -				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_scheme_read_cons_tail->cdr = v; -			} else { -				struct ao_scheme_cons	*read = ao_scheme_cons_cons(v, AO_SCHEME_NIL); -				if (!read) -					return AO_SCHEME_NIL; - -				if (ao_scheme_read_cons_tail) -					ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read); -				else -					ao_scheme_read_cons = read; -				ao_scheme_read_cons_tail = read; -			} - -			if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr) -				break; - -			v = ao_scheme_cons_poly(ao_scheme_read_cons); -			--ao_scheme_read_list; -			read_state = pop_read_stack(); -		} -	} -	return v; -} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h deleted file mode 100644 index 34739c9e..00000000 --- a/src/scheme/ao_scheme_read.h +++ /dev/null @@ -1,76 +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_SCHEME_READ_H_ -#define _AO_SCHEME_READ_H_ - -/* - * token classes - */ - -# define END			0 -# define NAME			1 -# define OPEN  			2 -# define CLOSE			3 -# define QUOTE			4 -#ifdef AO_SCHEME_FEATURE_QUASI -# define QUASIQUOTE		5 -# define UNQUOTE		6 -# define UNQUOTE_SPLICING	7 -#endif -# define STRING			8 -# define NUM			9 -#ifdef AO_SCHEME_FEATURE_FLOAT -# define FLOAT			10 -#endif -# define DOT			11 -# define TRUE_TOKEN		12 -# define FALSE_TOKEN		13 -#ifdef AO_SCHEME_FEATURE_VECTOR -# define OPEN_VECTOR		14 -#endif - -/* - * character classes - */ - -# define PRINTABLE	0x0001	/* \t \n ' ' - ~ */ -# define SPECIAL	0x0002	/* ( [ { ) ] } ' ` , */ -#ifdef AO_SCHEME_FEATURE_QUASI -# define SPECIAL_QUASI	SPECIAL -#else -# define SPECIAL_QUASI	0 -#endif -# -# define ALPHA		0x0004	/* A-Z a-z */ -# define WHITE		0x0008	/* ' ' \t \n */ -# define DIGIT		0x0010	/* [0-9] */ -# define SIGN		0x0020	/* +- */ -#ifdef AO_SCHEME_FEATURE_FLOAT -# define FLOATC		0x0040	/* . e E */ -#else -# define FLOATC		0 -#endif -# define ENDOFFILE	0x0080	/* end of file */ -# define COMMENT	0x0100	/* ; */ -# define IGNORE		0x0200	/* \0 - ' ' */ -# define STRINGC	0x0400	/* " */ -# define HEX_LETTER	0x0800	/* a-f A-F */ - -# define NOTNAME	(STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define INTEGER	(DIGIT|SIGN) -# define NUMBER		(INTEGER|FLOATC) -# define HEX_DIGIT	(DIGIT|HEX_LETTER) - -#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c deleted file mode 100644 index 49ab0559..00000000 --- a/src/scheme/ao_scheme_rep.c +++ /dev/null @@ -1,42 +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_scheme.h" - -ao_poly -ao_scheme_read_eval_print(FILE *read_file, FILE *write_file, bool interactive) -{ -	ao_poly	in, out = AO_SCHEME_NIL; - -	ao_scheme_exception = 0; -	for(;;) { -		if (interactive) -			fputs("> ", write_file); -		in = ao_scheme_read(read_file); -		if (in == _ao_scheme_atom_eof) -			break; -		out = ao_scheme_eval(in); -		if (ao_scheme_exception) { -			if (ao_scheme_exception & AO_SCHEME_EXIT) -				break; -			ao_scheme_exception = 0; -		} else { -			if (write_file) { -				ao_scheme_poly_write(write_file, out, true); -				putc('\n', write_file); -			} -		} -	} -	return out; -} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c deleted file mode 100644 index 0ef547d8..00000000 --- a/src/scheme/ao_scheme_save.c +++ /dev/null @@ -1,89 +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_scheme.h" - -#ifdef AO_SCHEME_FEATURE_SAVE -ao_poly -ao_scheme_do_save(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_MAKE_CONST -	struct ao_scheme_os_save *os; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_save, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; - -	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; -#else -	(void) cons; -#endif -	return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_restore(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_MAKE_CONST -	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_parse_args(_ao_scheme_atom_restore, cons, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; - -	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; -	} -#else -	(void) cons; -#endif -	return _ao_scheme_bool_false; -} - -#endif /* AO_SCHEME_FEATURE_SAVE */ diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c deleted file mode 100644 index d3b5d4b7..00000000 --- a/src/scheme/ao_scheme_stack.c +++ /dev/null @@ -1,279 +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_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, 1); -		ao_scheme_poly_mark(stack->values, 1); -		/* no need to mark values_tail */ -		ao_scheme_poly_mark(stack->frame, 0); -		ao_scheme_poly_mark(stack->list, 1); -		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, 1); -		(void) ao_scheme_poly_move(&stack->values, 1); -		(void) ao_scheme_poly_move(&stack->values_tail, 0); -		(void) ao_scheme_poly_move(&stack->frame, 0); -		(void) ao_scheme_poly_move(&stack->list, 1); -		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_write(FILE *out, ao_poly poly, bool write) -{ -	struct ao_scheme_stack 	*s = ao_scheme_poly_stack(poly); -	struct ao_scheme_stack	*clear = s; -	int			written = 0; - -	(void) write; -	ao_scheme_print_start(); -	ao_scheme_frame_print_indent += 2; -	while (s) { -		if (ao_scheme_print_mark_addr(s)) { -			fputs("[recurse...]", out); -			break; -		} -		written++; -		fputs("\t[\n", out); -		ao_scheme_fprintf(out, "\t\texpr:     %v\n", s->list); -		ao_scheme_fprintf(out, "\t\tvalues:   %v\n", s->values); -		ao_scheme_fprintf(out, "\t\tframe:    %v\n", s->frame); -		fputs("\t]\n", out); -		s = ao_scheme_poly_stack(s->prev); -	} -	ao_scheme_frame_print_indent -= 2; -	if (ao_scheme_print_stop()) { -		while (written--) { -			ao_scheme_print_clear_addr(clear); -			clear = ao_scheme_poly_stack(clear->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(old); -		ao_scheme_stack_stash(new); -		ao_scheme_stack_stash(prev); -		n = ao_scheme_stack_new(); -		prev = ao_scheme_stack_fetch(); -		new = ao_scheme_stack_fetch(); -		old = ao_scheme_stack_fetch(); -		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_cons	*cons; -	struct ao_scheme_stack	*new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); -	if (!new) -		return AO_SCHEME_NIL; - -	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; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_call2fcc, cons, -				  AO_SCHEME_LAMBDA|AO_SCHEME_ARG_RET_POLY, &v, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; - -	ao_scheme_poly_stash(v); -	/* 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; -	v = ao_scheme_poly_fetch(); - -	/* 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; - -	ao_scheme_stack->state = eval_exec; -	return v; -} diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c deleted file mode 100644 index 2c6d0960..00000000 --- a/src/scheme/ao_scheme_string.c +++ /dev/null @@ -1,349 +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_scheme.h" - -static void string_mark(void *addr) -{ -	(void) addr; -} - -static int string_size(void *addr) -{ -	struct ao_scheme_string	*string = addr; -	if (!addr) -		return 0; -	return strlen(string->val) + 2; -} - -static void string_move(void *addr) -{ -	(void) addr; -} - -const struct ao_scheme_type ao_scheme_string_type = { -	.mark = string_mark, -	.size = string_size, -	.move = string_move, -	.name = "string", -}; - -static struct ao_scheme_string * -ao_scheme_string_alloc(int len) -{ -	struct ao_scheme_string	*s; - -	if (len < 0) -		return NULL; -	s = ao_scheme_alloc(len + 2); -	if (!s) -		return NULL; -	s->type = AO_SCHEME_STRING; -	s->val[len] = '\0'; -	return s; -} - -struct ao_scheme_string * -ao_scheme_string_new(char *a) -{ -	struct ao_scheme_string	*r; - -	r = ao_scheme_string_alloc(strlen(a)); -	if (!r) -		return NULL; -	strcpy(r->val, a); -	return r; -} - -struct ao_scheme_string * -ao_scheme_atom_to_string(struct ao_scheme_atom *a) -{ -	int			alen = strlen(a->name); -	struct ao_scheme_string	*r; - -	ao_scheme_atom_stash(a); -	r = ao_scheme_string_alloc(alen); -	a = ao_scheme_atom_fetch(); -	if (!r) -		return NULL; -	strcpy(r->val, a->name); -	return r; -} - -struct ao_scheme_string * -ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) -{ -	int				alen = strlen(a->val); -	int				blen = strlen(b->val); -	struct ao_scheme_string 	*r; - -	ao_scheme_string_stash(a); -	ao_scheme_string_stash(b); -	r = ao_scheme_string_alloc(alen + blen); -	b = ao_scheme_string_fetch(); -	a = ao_scheme_string_fetch(); -	if (!r) -		return NULL; -	strcpy(r->val, a->val); -	strcpy(r->val+alen, b->val); -	return r; -} - -static ao_poly -ao_scheme_string_pack(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_string	*string; -	char			*s; -	int			len; - -	len = ao_scheme_cons_length(cons); -	ao_scheme_cons_stash(cons); -	string = ao_scheme_string_alloc(len); -	cons = ao_scheme_cons_fetch(); -	if (!string) -		return AO_SCHEME_NIL; -	s = string->val; - -	while (cons) { -		ao_poly	car = cons->car; -		int32_t c; -		if (!ao_scheme_is_integer(car) || (c = ao_scheme_poly_integer(car)) == 0) -			return ao_scheme_error(AO_SCHEME_INVALID, "%v: Invalid %v", _ao_scheme_atom_list2d3estring, car); -		*s++ = c; -		cons = ao_scheme_cons_cdr(cons); -	} -	return ao_scheme_string_poly(string); -} - -static ao_poly -ao_scheme_string_unpack(struct ao_scheme_string *a) -{ -	ao_poly	cons = AO_SCHEME_NIL; -	int	i; - -	for (i = strlen(a->val); --i >= 0;) { -		ao_scheme_string_stash(a); -		cons = ao_scheme_cons(ao_scheme_int_poly(a->val[i]), cons); -		a = ao_scheme_string_fetch(); -		if (!cons) -			break; -	} -	return cons; -} - -void -ao_scheme_string_write(FILE *out, ao_poly p, bool write) -{ -	struct ao_scheme_string	*s = ao_scheme_poly_string(p); -	char			*sval = s->val; -	char			c; - -	if (write) { -		putc('"', out); -		while ((c = *sval++)) { -			switch (c) { -			case '\a': -				fputs("\\a", out); -				break; -			case '\b': -				fputs("\\b", out); -				break; -			case '\t': -				fputs("\\t", out); -				break; -			case '\n': -				fputs("\\n", out); -				break; -			case '\r': -				fputs("\\r", out); -				break; -			case '\f': -				fputs("\\f", out); -				break; -			case '\v': -				fputs("\\v", out); -				break; -			case '\"': -				fputs("\\\"", out); -				break; -			case '\\': -				fputs("\\\\", out); -				break; -			default: -				if ((uint8_t) c < ' ') -					fprintf(out, "\\%03o", (uint8_t) c); -				else -					putc(c, out); -				break; -			} -		} -		putc('"', out); -	} else { -		while ((c = *sval++)) -			putc(c, out); -	} -} - -ao_poly -ao_scheme_do_stringp(struct ao_scheme_cons *cons) -{ -	return ao_scheme_do_typep(_ao_scheme_atom_string3f, AO_SCHEME_STRING, cons); -} - -ao_poly -ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons	*list; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3estring, cons, -				  AO_SCHEME_CONS, &list, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_string_pack(list); -} - -ao_poly -ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_string	*string; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3elist, cons, -				  AO_SCHEME_STRING, &string, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_string_unpack(string); -} - -static char * -ao_scheme_string_ref(struct ao_scheme_string *string, int32_t r) -{ -	char *s = string->val; -	while (*s && r) { -		++s; -		--r; -	} -	return s; -} - -ao_poly -ao_scheme_do_string_ref(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_string	*string; -	int32_t			ref; -	char			*s; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_string2dref, cons, -				  AO_SCHEME_STRING, &string, -				  AO_SCHEME_INT, &ref, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; - -	s = ao_scheme_string_ref(string, ref); -	if (!*s) -		return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", -				       _ao_scheme_atom_string2dref, -				       cons->car, -				       ao_scheme_arg(cons, 1)); -	return ao_scheme_integer_poly(*s); -} - -ao_poly -ao_scheme_do_string_length(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_string *string; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_string2dlength, cons, -				  AO_SCHEME_STRING, &string, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_integer_poly(strlen(string->val)); -} - -ao_poly -ao_scheme_do_string_set(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_string	*string; -	int32_t			ref; -	int32_t			val; -	char			*s; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_string2dset21, cons, -				  AO_SCHEME_STRING, &string, -				  AO_SCHEME_INT, &ref, -				  AO_SCHEME_INT, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (!val) -		goto fail; -	s = ao_scheme_string_ref(string, ref); -	if (!*s) -		goto fail; -	*s = val; -	return ao_scheme_integer_poly(val); -fail: -	return ao_scheme_error(AO_SCHEME_INVALID, "%v: %v[%v] = %v invalid", -			       _ao_scheme_atom_string2dset21, -			       ao_scheme_arg(cons, 0), -			       ao_scheme_arg(cons, 1), -			       ao_scheme_arg(cons, 2)); -} - -ao_poly -ao_scheme_do_make_string(struct ao_scheme_cons *cons) -{ -	int32_t			len; -	int32_t			fill; -	struct ao_scheme_string	*string; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_make2dstring, cons, -				  AO_SCHEME_INT, &len, -				  AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(' '), &fill, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (!fill) -		return ao_scheme_error(AO_SCHEME_INVALID, "%v: fill 0 invalid", -				       _ao_scheme_atom_make2dstring); -	string = ao_scheme_string_alloc(len); -	if (!string) -		return AO_SCHEME_NIL; -	memset(string->val, fill, len); -	return ao_scheme_string_poly(string); -} - -ao_poly -ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_atom	*atom; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_symbol2d3estring, cons, -				  AO_SCHEME_ATOM, &atom, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_string_poly(ao_scheme_atom_to_string(atom)); -} - -ao_poly -ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_string	*string; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3esymbol, cons, -				  AO_SCHEME_STRING, &string, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_atom_poly(ao_scheme_string_to_atom(string)); -} diff --git a/src/scheme/ao_scheme_string.scheme b/src/scheme/ao_scheme_string.scheme deleted file mode 100644 index 99f16fab..00000000 --- a/src/scheme/ao_scheme_string.scheme +++ /dev/null @@ -1,156 +0,0 @@ -; -; Copyright © 2018 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. -; -; string functions placed in ROM - -(define string (lambda chars (list->string chars))) - -(string #\a #\b #\c) - -(define string-map -  (lambda (proc . strings) -					; result length is min of arg lengths -    (let* ((l (apply min (map string-length strings))) -					; create the result -	   (s (make-string l))) -					; walk the strings, doing evaluation -      (define (_m p) -	(if (equal? p l) -	    s -	    (begin -	      (string-set! s p (apply proc (map (lambda (s) (string-ref s p)) strings))) -	      (_m (+ p 1)) -	      ) -	    ) -	) -      (_m 0) -      ) -    ) -  ) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-copy! -  (lambda (t a f . args) -    (let ((l 0) -	  (h (string-length f)) -	  (o a) -	  (d 1)) -					; handle optional start/end args -       -      (if (not (null? args)) -	  (begin -	    (set! l (car args)) -	    (if (not (null? (cdr args))) -		(set! h (cadr args))) -	    (set! o (- a l)) -	    ) -	  ) -					; flip copy order if dst is -					; after src -      (if (< l a) -	  (begin -	    (set! d h) -	    (set! h (- l 1)) -	    (set! l (- d 1)) -	    (set! d -1) -	    ) -	  ) -					; loop copying one at a time -      (do ((p l (+ p d)) -	   ) -	  ((= p h) t) -	(string-set! t (+ p o) (string-ref f p)) -	) -      ) -    ) -  ) - -(string-copy! (make-string 10) 0 "hello" 0 5) -(string-copy! (make-string 10) 1 "hello" 0 5) -(string-copy! (make-string 10) 0 "hello" 0 5) - -(define (string-upcase s) (string-map char-upcase s)) -(define (string-downcase s) (string-map char-downcase s)) -(define string-foldcase string-downcase) - -(define string-copy -  (lambda (s . args) -    (let ((l 0) -	  (h (string-length s))) -      (if (not (null? args)) -	  (begin -	    (set! l (car args)) -	    (if (not (null? (cdr args))) -		(set! h (cadr args))) -	    ) -	  ) -      (string-copy! (make-string (- h l)) 0 s l h) -      ) -    ) -  ) - -(string-copy "hello" 0 1) -(string-copy "hello" 1) -(string-copy "hello") - -(define substring string-copy) - -(define string-fill! -  (lambda (s a . args) -    (let ((l 0) -	  (h (string-length s))) -      (cond ((not (null? args)) -	     (set! l (car args)) -	     (cond ((not (null? (cdr args))) -		    (set! h (cadr args))) -		   ) -	     ) -	    ) -      (define (_f b) -	(cond ((< b h) -	       (string-set! s b a) -	       (_f (+ b 1)) -	       ) -	      (else s) -	      ) -	) -      (_f l) -      ) -    ) -  ) - -(string-fill! (make-string 10) #\a) -(string-fill! (make-string 10) #\a 1 2) - -(define string-for-each -  (lambda (proc . strings) -					; result length is min of arg lengths -    (let* ((l (apply min (map string-length strings))) -	   ) -					; walk the strings, doing evaluation -      (define (_m p) -	(if (equal? p l) -	    #t -	    (begin -	      (apply proc (map (lambda (s) (string-ref s p)) strings)) -	      (_m (+ p 1)) -	      ) -	    ) -	) -      (_m 0) -      ) -    ) -  ) - -(string-for-each write-char "IBM\n") diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c deleted file mode 100644 index e7328e32..00000000 --- a/src/scheme/ao_scheme_vector.c +++ /dev/null @@ -1,284 +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_scheme.h" - -#ifdef AO_SCHEME_FEATURE_VECTOR - -static void vector_mark(void *addr) -{ -	struct ao_scheme_vector	*vector = addr; -	unsigned int	i; - -	for (i = 0; i < vector->length; i++) { -		ao_poly v = vector->vals[i]; - -		ao_scheme_poly_mark(v, 1); -	} -} - -static int vector_len_size(uint16_t length) -{ -	return sizeof (struct ao_scheme_vector) + length * sizeof (ao_poly); -} - -static int vector_size(void *addr) -{ -	struct ao_scheme_vector *vector = addr; - -	return vector_len_size(vector->length); -} - -static void vector_move(void *addr) -{ -	struct ao_scheme_vector	*vector = addr; -	unsigned int	i; - -	for (i = 0; i < vector->length; i++) -		(void) ao_scheme_poly_move(&vector->vals[i], 1); -} - -const struct ao_scheme_type ao_scheme_vector_type = { -	.mark = vector_mark, -	.size = vector_size, -	.move = vector_move, -	.name = "vector", -}; - -struct ao_scheme_vector * -ao_scheme_vector_alloc(uint16_t length, ao_poly fill) -{ -	struct ao_scheme_vector	*vector; -	unsigned int i; - -	vector = ao_scheme_alloc(vector_len_size(length)); -	if (!vector) -		return NULL; -	vector->type = AO_SCHEME_VECTOR; -	vector->length = length; -	for (i = 0; i < length; i++) -		vector->vals[i] = fill; -	return vector; -} - -struct vl { -	struct ao_scheme_vector	*vector; -	struct vl *prev; -}; - -static struct vl *vl; -static unsigned int vd; - -void -ao_scheme_vector_write(FILE *out, ao_poly v, bool write) -{ -	struct ao_scheme_vector	*vector = ao_scheme_poly_vector(v); -	unsigned int i; -	int was_marked = 0; -	struct vl *ve; - -	++vd; -	for (ve = vl; ve; ve = ve->prev) -		if (ve->vector == vector) -			abort(); - -	ve = malloc(sizeof (struct vl)); -	ve->prev = vl; -	ve->vector = vector; -	vl = ve; - -	ao_scheme_print_start(); -	was_marked = ao_scheme_print_mark_addr(vector); -	if (was_marked) { -		fputs("...", out); -	} else { -		fputs("#(", out); -		for (i = 0; i < vector->length; i++) { -			if (i != 0) -				putc(' ', out); -			ao_scheme_poly_write(out, vector->vals[i], write); -		} -		printf(")"); -	} -	if (ao_scheme_print_stop() && !was_marked) -		ao_scheme_print_clear_addr(vector); -	if (vl != ve) -		abort(); -	vl = ve->prev; -	free(ve); -	--vd; -} - -struct ao_scheme_vector * -ao_scheme_list_to_vector(struct ao_scheme_cons *cons) -{ -	uint16_t		length; -	uint16_t		i; -	struct ao_scheme_vector	*vector; - -	length = (uint16_t) ao_scheme_cons_length (cons); -	if (ao_scheme_exception) -		return NULL; - -	ao_scheme_cons_stash(cons); -	vector = ao_scheme_vector_alloc(length, AO_SCHEME_NIL); -	cons = ao_scheme_cons_fetch(); -	if (!vector) -		return NULL; -	i = 0; -	while (cons) { -		vector->vals[i++] = cons->car; -		cons = ao_scheme_cons_cdr(cons); -	} -	return vector; -} - -struct ao_scheme_cons * -ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end) -{ -	int			i; -	uint16_t		length = vector->length; -	struct ao_scheme_cons	*cons = NULL; - -	if (end == -1) -		end = length; -	if (start < 0) -		start = 0; -	if (end > length) -		end = length; -	for (i = end; i-- > start;) { -		ao_scheme_vector_stash(vector); -		cons = ao_scheme_cons_cons(vector->vals[i], ao_scheme_cons_poly(cons)); -		vector = ao_scheme_vector_fetch(); -		if (!cons) -			return NULL; -	} -	return cons; -} - -ao_poly -ao_scheme_do_vector(struct ao_scheme_cons *cons) -{ -	return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); -} - -ao_poly -ao_scheme_do_make_vector(struct ao_scheme_cons *cons) -{ -	int32_t	len; -	ao_poly	val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_make2dvector, cons, -				  AO_SCHEME_INT, &len, -				  AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_false, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_vector_poly(ao_scheme_vector_alloc(len, val)); -} - -static bool -ao_scheme_check_vector(ao_poly proc, struct ao_scheme_vector *vector, int32_t offset) -{ -	if (offset < 0 || vector->length <= offset) { -		(void) ao_scheme_error(AO_SCHEME_INVALID, "%v: vector index %d out of range (max %d)", -				       proc, -				       offset, vector->length); -		return false; -	} -	return true; -} - -ao_poly -ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_vector	*vector; -	int32_t			offset; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dref, cons, -				  AO_SCHEME_VECTOR, &vector, -				  AO_SCHEME_INT, &offset, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dref, vector, offset)) -		return AO_SCHEME_NIL; -	return vector->vals[offset]; -} - -ao_poly -ao_scheme_do_vector_set(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_vector	*vector; -	int32_t			offset; -	ao_poly			val; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dset21, cons, -				  AO_SCHEME_VECTOR, &vector, -				  AO_SCHEME_INT, &offset, -				  AO_SCHEME_POLY, &val, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dset21, vector, offset)) -		return AO_SCHEME_NIL; -	vector->vals[offset] = val; -	return val; -} - -ao_poly -ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_cons	*pair; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3evector, cons, -				  AO_SCHEME_CONS|AO_SCHEME_ARG_NIL_OK, &pair, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_vector_poly(ao_scheme_list_to_vector(pair)); -} - -ao_poly -ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_vector	*vector; -	int32_t			start, end; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons, -				  AO_SCHEME_VECTOR, &vector, -				  AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(0), &start, -				  AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(-1), &end, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	if (end == -1) -		end = vector->length; -	return ao_scheme_cons_poly(ao_scheme_vector_to_list(vector, start, end)); -} - -ao_poly -ao_scheme_do_vector_length(struct ao_scheme_cons *cons) -{ -	struct ao_scheme_vector	*vector; - -	if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons, -				  AO_SCHEME_VECTOR, &vector, -				  AO_SCHEME_ARG_END)) -		return AO_SCHEME_NIL; -	return ao_scheme_integer_poly(vector->length); -} - -ao_poly -ao_scheme_do_vectorp(struct ao_scheme_cons *cons) -{ -	return ao_scheme_do_typep(_ao_scheme_atom_vector3f, AO_SCHEME_VECTOR, cons); -} - -#endif /* AO_SCHEME_FEATURE_VECTOR */ diff --git a/src/scheme/ao_scheme_vector.scheme b/src/scheme/ao_scheme_vector.scheme deleted file mode 100644 index 6c25aae5..00000000 --- a/src/scheme/ao_scheme_vector.scheme +++ /dev/null @@ -1,192 +0,0 @@ -; -; Copyright © 2018 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. -; -; vector functions placed in ROM - - -(define vector->string -  (lambda (v . args) -    (let ((l 0) -	  (h (vector-length v))) -      (if (not (null? args)) -	  (begin -	    (set! l (car args)) -	    (if (not (null? (cdr args))) -		(set! h (cadr args))) -	    ) -	  ) -      (do ((s (make-string (- h l))) -	   (p l (+ p 1)) -	   ) -	  ((= p h) s) -	(string-set! s (- p l) (vector-ref v p)) -	) -      ) -    ) -  ) - -(vector->string #(#\a #\b #\c) 0 2) - -(define string->vector -  (lambda (s . args) -    (let ((l 0) -	  (h (string-length s))) -      (if (not (null? args)) -	  (begin -	    (set! l (car args)) -	    (if (not (null? (cdr args))) -		(set! h (cadr args))) -	    ) -	  ) -      (do ((v (make-vector (- h l))) -	   (p l (+ p 1)) -	   ) -	  ((= p h) v) -	(vector-set! v (- p l) (string-ref s p)) -	) -      ) -    ) -  ) - -(string->vector "hello" 0 2) -     -(define vector-copy! -  (lambda (t a f . args) -    (let ((l 0) -	  (h (vector-length f)) -	  (o a) -	  (d 1)) -					; handle optional start/end args -       -      (if (not (null? args)) -	  (begin -	    (set! l (car args)) -	    (if (not (null? (cdr args))) -		(set! h (cadr args))) -	    (set! o (- a l)) -	    ) -	  ) -					; flip copy order if dst is -					; after src -      (if (< l a) -	  (begin -	    (set! d h) -	    (set! h (- l 1)) -	    (set! l (- d 1)) -	    (set! d -1) -	    ) -	  ) -					; loop copying one at a time -      (do ((p l (+ p d)) -	   ) -	  ((= p h) t) -	(vector-set! t (+ p o) (vector-ref f p)) -	) -      ) -    ) -  ) - -					; simple vector-copy test - -(vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) - -(let ((v (vector 1 2 3 4 5 6 7 8 9 0))) -  (vector-copy! v 1 v 0 2) -  (display "v ") (write v) (newline) -  ) - -(define vector-copy -  (lambda (v . args) -    (let ((l 0) -	  (h (vector-length v))) -      (if (not (null? args)) -	  (begin -	    (set! l (car args)) -	    (if (not (null? (cdr args))) -		(set! h (cadr args))) -	    ) -	  ) -      (vector-copy! (make-vector (- h l)) 0 v) -      ) -    ) -  ) - -(vector-copy #(1 2 3) 0 3) - -(define vector-append -  (lambda a -    (define (_f v a p) -      (if (null? a) -	  v -	  (begin -	    (vector-copy! v p (car a)) -	    (_f v (cdr a) (+ p (vector-length (car a)))) -	    ) -	  ) -      ) -    (_f (make-vector (apply + (map vector-length a))) a 0) -    ) -  ) - -(vector-append #(1 2 3) #(4 5 6) #(7 8 9)) - -(define vector-fill! -  (lambda (v a . args) -    (let ((l 0) -	  (h (vector-length v))) -      (cond ((not (null? args)) -	     (set! l (car args)) -	     (cond ((not (null? (cdr args))) -		    (set! h (cadr args))) -		   ) -	     ) -	    ) -      (define (_f b) -	(cond ((< b h) -	       (vector-set! v b a) -	       (_f (+ b 1)) -	       ) -	      (else v) -	      ) -	) -      (_f l) -      ) -    ) -  ) - -(vector-fill! (make-vector 3) #t 1 2) - -					; like 'map', but for vectors - -(define vector-map -  (lambda (proc . vectors) -					; result length is min of arg lengths -    (let* ((l (apply min (map vector-length vectors))) -					; create the result -	   (v (make-vector l))) -					; walk the vectors, doing evaluation -      (define (_m p) -	(if (equal? p l) -	    v -	    (begin -	      (vector-set! v p (apply proc (map (lambda (v) (vector-ref v p)) vectors))) -	      (_m (+ p 1)) -	      ) -	    ) -	) -      (_m 0) -      ) -    ) -  ) -     -(vector-map + #(1 2 3) #(4 5 6)) diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore deleted file mode 100644 index bcd57242..00000000 --- a/src/scheme/make-const/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile deleted file mode 100644 index a8e3a7f5..00000000 --- a/src/scheme/make-const/Makefile +++ /dev/null @@ -1,26 +0,0 @@ -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 -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -.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/scheme/make-const/ao_scheme_os.h b/src/scheme/make-const/ao_scheme_os.h deleted file mode 100644 index f06bbbb1..00000000 --- a/src/scheme/make-const/ao_scheme_os.h +++ /dev/null @@ -1,63 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include <stdio.h> -#include <stdlib.h> -#include <time.h> - -extern int ao_scheme_getc(void); - -static inline void -ao_scheme_os_flush(void) { -	fflush(stdout); -} - -static inline void -ao_scheme_abort(void) -{ -	abort(); -} - -static inline void -ao_scheme_os_led(int led) -{ -	printf("leds set to 0x%x\n", led); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND	100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ -	struct timespec ts = { -		.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_scheme_os_jiffy(void) -{ -	struct timespec tp; -	clock_gettime(CLOCK_MONOTONIC, &tp); -	return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} -#endif diff --git a/src/scheme/test/.gitignore b/src/scheme/test/.gitignore deleted file mode 100644 index 3622bc1d..00000000 --- a/src/scheme/test/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao-scheme diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile deleted file mode 100644 index a8129217..00000000 --- a/src/scheme/test/Makefile +++ /dev/null @@ -1,33 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath %.h .. -vpath %.scheme .. -vpath ao_scheme_make_const ../make-const - -SRCS=$(SCHEME_SRCS) ao_scheme_test.c -HDRS=$(SCHEME_HDRS) ao_scheme_const.h - -OBJS=$(SRCS:.c=.o) - -#PGFLAGS=-pg -no-pie -OFLAGS=-O3 -#DFLAGS=-O0 - -CFLAGS=$(DFLAGS) $(OFLAGS) $(PGFLAGS) -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -ao-scheme: $(OBJS) -	cc $(CFLAGS) -o $@ $(OBJS) -lm -	./ao-scheme ao_scheme_test.scheme - -$(OBJS): $(HDRS) - -ao_scheme_const.h: ao_scheme_make_const $(SCHEME_SCHEME) -	$^ -o $@ -d GPIO - -clean:: -	rm -f $(OBJS) ao-scheme ao_scheme_const.h - -install: ao-scheme -	install -t $$HOME/bin $^ diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h deleted file mode 100644 index 9836d534..00000000 --- a/src/scheme/test/ao_scheme_os.h +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include <stdio.h> -#include <stdlib.h> -#include <time.h> - -#define AO_SCHEME_POOL_TOTAL	32768 - -static inline void -ao_scheme_abort(void) -{ -	abort(); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND	100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ -	struct timespec ts = { -		.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_scheme_os_jiffy(void) -{ -	struct timespec tp; -	clock_gettime(CLOCK_MONOTONIC, &tp); -	return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c deleted file mode 100644 index 195b8b46..00000000 --- a/src/scheme/test/ao_scheme_test.c +++ /dev/null @@ -1,188 +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_scheme.h" -#include <stdio.h> -#include <unistd.h> -#include <getopt.h> - -static char save_file[] = "scheme.image"; - -int -ao_scheme_os_save(void) -{ -	FILE	*save = fopen(save_file, "w"); - -	if (!save) { -		perror(save_file); -		return 0; -	} -	fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); -	fclose(save); -	return 1; -} - -int -ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) -{ -	FILE	*restore = fopen(save_file, "r"); -	size_t	ret; - -	if (!restore) { -		perror(save_file); -		return 0; -	} -	fseek(restore, offset, SEEK_SET); -	ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); -	fclose(restore); -	if (ret != 1) -		return 0; -	return 1; -} - -int -ao_scheme_os_restore(void) -{ -	FILE	*restore = fopen(save_file, "r"); -	size_t	ret; - -	if (!restore) { -		perror(save_file); -		return 0; -	} -	ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); -	fclose(restore); -	if (ret != AO_SCHEME_POOL_TOTAL) -		return 0; -	return 1; -} - -static const struct option options[] = { -	{ .name = "load", .has_arg = 1, .val = 'l' }, -	{ 0, 0, 0, 0 }, -}; - -static void usage(char *program) -{ -	fprintf(stderr, "usage: %s [--load=<library> ...] <program ...>\n", program); -} - -static void -check_exit(ao_poly v) -{ -	if (ao_scheme_exception & AO_SCHEME_EXIT) { -		int	ret; - -		if (v == _ao_scheme_bool_true) -			ret = 0; -		else { -			ret = 1; -			if (ao_scheme_is_integer(v)) -				ret = ao_scheme_poly_integer(v); -		} -		exit(ret); -	} -} - -static void -run_file(char *name) -{ -	FILE	*in; -	int 	c; -	ao_poly	v; - -	in = fopen(name, "r"); -	if (!in) { -		perror(name); -		exit(1); -	} -	c = getc(in); -	if (c == '#') { -		do { -			c = getc(in); -		} while (c != EOF && c != '\n'); -	} else { -		ungetc(c, in); -	} -	v = ao_scheme_read_eval_print(in, NULL, false); -	fclose(in); -	check_exit(v); -} - -int -main (int argc, char **argv) -{ -	int	o; - -	while ((o = getopt_long(argc, argv, "?l:", options, NULL)) != -1) { -		switch (o) { -		case '?': -			usage(argv[0]); -			exit(0); -		case 'l': -#ifdef AO_SCHEME_FEATURE_POSIX -			ao_scheme_set_argv(&argv[argc]); -#endif -			run_file(optarg); -			break; -		default: -			usage(argv[0]); -			exit(1); -		} -	} -#ifdef AO_SCHEME_FEATURE_POSIX -	ao_scheme_set_argv(argv + optind); -#endif -	if (argv[optind]) { -		run_file(argv[optind]); -	} else { -		ao_poly v; -		v = ao_scheme_read_eval_print(stdin, stdout, true); -		check_exit(v); -		putchar('\n'); -	} - -#ifdef DBG_MEM_STATS -	printf ("collects: full: %lu incremental %lu\n", -		ao_scheme_collects[AO_SCHEME_COLLECT_FULL], -		ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - -	printf ("freed: full %lu incremental %lu\n", -		ao_scheme_freed[AO_SCHEME_COLLECT_FULL], -		ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); - -	printf("loops: full %lu incremental %lu\n", -		ao_scheme_loops[AO_SCHEME_COLLECT_FULL], -		ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); - -	printf("loops per collect: full %f incremental %f\n", -	       (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL] / -	       (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], -	       (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL] / -	       (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - -	printf("freed per collect: full %f incremental %f\n", -	       (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / -	       (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], -	       (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / -	       (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - -	printf("freed per loop: full %f incremental %f\n", -	       (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / -	       (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL], -	       (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / -	       (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); -#endif -	return 0; -} diff --git a/src/scheme/test/ao_scheme_test.scheme b/src/scheme/test/ao_scheme_test.scheme deleted file mode 100644 index 41aaeda1..00000000 --- a/src/scheme/test/ao_scheme_test.scheme +++ /dev/null @@ -1,175 +0,0 @@ -					; Basic syntax tests - -(define _assert-eq_ -  (macro (a b) -	   (list cond -		 (list (list eq? a b) -		       ) -		 (list 'else -		       (list display "failed: ") -		       (list write (list quote a)) -		       (list newline) -		       (list exit 1) -		       ) -		 ) -	   ) -  ) - -(define _assert-equal_ -  (macro (a b) -    (list cond -	  (list (list equal? a b) -		) -	  (list 'else -		(list display "failed: ") -		(list write (list quote a)) -		(list newline) -		(list exit 1) -		) -	  ) -    ) -  ) - -(_assert-eq_ (or #f #t) #t) -(_assert-eq_ (and #t #f) #f) -(_assert-eq_ (if (> 3 2) 'yes) 'yes) -(_assert-eq_ (if (> 3 2) 'yes 'no) 'yes) -(_assert-eq_ (if (> 2 3) 'no 'yes) 'yes) -(_assert-eq_ (if (> 2 3) 'no) #f) - -(_assert-eq_ (letrec ((a 1) (b a)) (+ a b)) 2) - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) - -(_assert-equal_ (cdar '((1 2) (3 4))) '(2)) - -(_assert-equal_ (cddr '(1 2 3)) '(3)) - -(_assert-equal_ (caddr '(1 2 3 4)) 3) - -(_assert-equal_ (member '(2) '((1) (2) (3)))  '((2) (3))) -(_assert-equal_ (member '(4) '((1) (2) (3))) #f) - -(_assert-equal_ (memq 2 '(1 2 3)) '(2 3)) -(_assert-equal_ (memq 4 '(1 2 3)) #f) -(_assert-equal_ (memq '(2) '((1) (2) (3))) #f) - -(_assert-equal_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_assert-equal_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2)) -(_assert-equal_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(_assert-equal_ (map cadr '((a b) (d e) (g h))) '(b e h)) - -(_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) - -					; Advanced syntax tests - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) -(_assert-eq_ (equal? #(1 2 3) #(1 2 3)) #t) -(_assert-eq_ (equal? #(1 2 3) #(4 5 6)) #f) -(_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) -(_assert-equal_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) -(_assert-equal_ (when #t (+ 1 2)) 3) -(_assert-equal_ (when #f (+ 1 2)) #f) -(_assert-equal_ (unless #f (+ 2 3)) 5) -(_assert-equal_ (unless #t (+ 2 3)) #f) -(_assert-equal_ (cdar '((1 2) (3 4))) '(2)) -(_assert-equal_ (cddr '(1 2 3)) '(3)) -(_assert-equal_ (caddr '(1 2 3 4)) 3) -(_assert-equal_ (reverse '(1 2 3)) '(3 2 1)) -(_assert-equal_ (make-list 10 'a) '(a a a a a a a a a a)) -(_assert-equal_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) -(_assert-equal_ (let ((a 0)) -		  (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) -		  a -		  ) -		6) -(_assert-equal_ (call-with-current-continuation -		 (lambda (exit) -		   (for-each (lambda (x) -			       (if (negative? x) -				   (exit x))) -			     '(54 0 37 -3 245 19)) -		   ) -		 ) -		-3) -(_assert-equal_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "one") -(_assert-equal_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "two") -(_assert-equal_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "three") -(_assert-equal_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "else") -(_assert-equal_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "twelve") -(_assert-equal_ (do ((x 1 (+ x 1)) -	   (y 0) -	   ) -	  ((= x 10) y) -	(set! y (+ y x)) -	) -      45) - -(_assert-equal_ (do ((vec (make-vector 5)) -		     (i 0 (+ i 1))) -		    ((= i 5) vec) -		  (vector-set! vec i i)) -		#(0 1 2 3 4)) - -					; vector tests - -(_assert-equal_ (vector->string #(#\a #\b #\c) 0 2) "ab") -(_assert-equal_ (string->vector "hello" 0 2) #(#\h #\e)) -(_assert-equal_ (vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t")) -(_assert-equal_ (vector-copy #(1 2 3) 0 3) #(1 2 3)) -(_assert-equal_ (vector-append #(1 2 3) #(4 5 6) #(7 8 9)) #(1 2 3 4 5 6 7 8 9)) -(_assert-equal_ (vector-fill! (make-vector 3) #t 1 2) #(#f #t #f)) -(_assert-equal_ (vector-map + #(1 2 3) #(4 5 6)) #(5 7 9)) - -					; string tests - -(_assert-equal_ (string #\a #\b #\c) "abc") -(_assert-equal_ (string-map (lambda (x) (+ 1 x)) "HAL") "IBM") -(_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ") -(_assert-equal_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello    ") -(_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ") -(_assert-equal_ (string-copy "hello" 0 1) "h") -(_assert-equal_ (string-copy "hello" 1) "ello") -(_assert-equal_ (string-copy "hello") "hello") -(_assert-equal_ (string-fill! (make-string 10) #\a) "aaaaaaaaaa") -(_assert-equal_ (string-fill! (make-string 10) #\a 1 2) " a        ") -;(_assert-equal_ (string-for-each write-char "IBM\n") #t) - -					; char tests - -(_assert-equal_ (char? #\q) #t) -(_assert-equal_ (char? "h") #f) -(_assert-equal_ (char-upper-case? #\a) #f) -(_assert-equal_ (char-upper-case? #\B) #t) -(_assert-equal_ (char-upper-case? #\0) #f) -(_assert-equal_ (char-upper-case? #\space) #f) -(_assert-equal_ (char-lower-case? #\a) #t) -(_assert-equal_ (char-lower-case? #\B) #f) -(_assert-equal_ (char-lower-case? #\0) #f) -(_assert-equal_ (char-lower-case? #\space) #f) -(_assert-equal_ (char-alphabetic? #\a) #t) -(_assert-equal_ (char-alphabetic? #\B) #t) -(_assert-equal_ (char-alphabetic? #\0) #f) -(_assert-equal_ (char-alphabetic? #\space) #f) -(_assert-equal_ (char-numeric? #\a) #f) -(_assert-equal_ (char-numeric? #\B) #f) -(_assert-equal_ (char-numeric? #\0) #t) -(_assert-equal_ (char-numeric? #\space) #f) -(_assert-equal_ (char-whitespace? #\a) #f) -(_assert-equal_ (char-whitespace? #\B) #f) -(_assert-equal_ (char-whitespace? #\0) #f) -(_assert-equal_ (char-whitespace? #\space) #t) -(_assert-equal_ (char-upcase #\a) #\A) -(_assert-equal_ (char-upcase #\B) #\B) -(_assert-equal_ (char-upcase #\0) #\0) -(_assert-equal_ (char-upcase #\space) #\space) -(_assert-equal_ (char-downcase #\a) #\a) -(_assert-equal_ (char-downcase #\B) #\b) -(_assert-equal_ (char-downcase #\0) #\0) -(_assert-equal_ (char-downcase #\space) #\space) -(_assert-equal_ (digit-value #\1) 1) -(_assert-equal_ (digit-value #\a) #f) - diff --git a/src/scheme/test/hanoi.scheme b/src/scheme/test/hanoi.scheme deleted file mode 100755 index 0180de1e..00000000 --- a/src/scheme/test/hanoi.scheme +++ /dev/null @@ -1,177 +0,0 @@ -#!/home/keithp/bin/ao-scheme -; -; Towers of Hanoi -; -; 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. -; - -					; ANSI control sequences - -(define (move-to col row) -  (for-each display (list "\033[" row ";" col "H")) -  ) - -(define (clear) -  (display "\033[2J") -  ) - -(define (display-string x y str) -  (move-to x y) -  (display str) -  ) - -(define (make-piece num max) -					; A piece for position 'num' -					; is num + 1 + num stars -					; centered in a field of max * -					; 2 + 1 characters with spaces -					; on either side. This way, -					; every piece is the same -					; number of characters - -  (define (chars n c) -    (if (zero? n) "" -      (+ c (chars (- n 1) c)) -      ) -    ) -  (+ (chars (- max num 1) " ") -     (chars (+ (* num 2) 1) "*") -     (chars (- max num 1) " ") -     ) -  ) - -(define (make-pieces max) -					; Make a list of numbers from 0 to max-1 -  (define (nums cur max) -    (if (= cur max) () -      (cons cur (nums (+ cur 1) max)) -      ) -    ) -					; Create a list of pieces - -  (map (lambda (x) (make-piece x max)) (nums 0 max)) -  ) - -					; Here's all of the towers of pieces -					; This is generated when the program is run - -(define towers ()) - -					; position of the bottom of -					; the stacks set at runtime -(define bottom-y 0) -(define left-x 0) - -(define move-delay 25) - -					; Display one tower, clearing any -					; space above it - -(define (display-tower x y clear tower) -  (cond ((= 0 clear) -	 (cond ((not (null? tower)) -		(display-string x y (car tower)) -		(display-tower x (+ y 1) 0 (cdr tower)) -		) -	       ) -	 ) -	(else  -	 (display-string x y "                    ") -	 (display-tower x (+ y 1) (- clear 1) tower) -	 ) -	) -  ) - -					; Position of the top of the tower on the screen -					; Shorter towers start further down the screen - -(define (tower-pos tower) -  (- bottom-y (length tower)) -  ) - -					; Display all of the towers, spaced 20 columns apart - -(define (display-towers x towers) -  (cond ((not (null? towers)) -	 (display-tower x 0 (tower-pos (car towers)) (car towers)) -	 (display-towers (+ x 20) (cdr towers))) -	) -  ) - -					; Display all of the towers, then move the cursor -					; out of the way and flush the output - -(define (display-hanoi) -  (display-towers left-x towers) -  (move-to 1 23) -  (flush-output) -  (delay move-delay) -  ) - -					; Reset towers to the starting state, with -					; all of the pieces in the first tower and the -					; other two empty - -(define (reset-towers len) -  (set! towers (list (make-pieces len) () ())) -  (set! bottom-y (+ len 3)) -  ) - -					; Move a piece from the top of one tower -					; to the top of another - -(define (move-piece from to) - -					; references to the cons holding the two towers - -  (define from-tower (list-tail towers from)) -  (define to-tower (list-tail towers to)) - -					; stick the car of from-tower onto to-tower - -  (set-car! to-tower (cons (caar from-tower) (car to-tower))) - -					; remove the car of from-tower - -  (set-car! from-tower (cdar from-tower)) -  ) - -					; The implementation of the game - -(define (_hanoi n from to use) -  (cond ((= 1 n) -	 (move-piece from to) -	 (display-hanoi) -	 ) -	(else -	 (_hanoi (- n 1) from use to) -	 (_hanoi 1 from to use) -	 (_hanoi (- n 1) use to from) -	 ) -	) -  ) - -					; A pretty interface which -					; resets the state of the game, -					; clears the screen and runs -					; the program - -(define (hanoi len) -  (reset-towers len) -  (clear) -  (display-hanoi) -  (_hanoi len 0 1 2) -  #t -  ) - -(unless (null? (command-line)) (hanoi 6)) diff --git a/src/scheme/tiny-test/.gitignore b/src/scheme/tiny-test/.gitignore deleted file mode 100644 index 7c4c3956..00000000 --- a/src/scheme/tiny-test/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao-scheme-tiny diff --git a/src/scheme/tiny-test/Makefile b/src/scheme/tiny-test/Makefile deleted file mode 100644 index 61ef687a..00000000 --- a/src/scheme/tiny-test/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath ao_scheme_test.c ../test -vpath %.h .. -vpath %.scheme .. -vpath ao_scheme_make_const ../make-const - -DEFS= - -SRCS=$(SCHEME_SRCS) ao_scheme_test.c -HDRS=$(SCHEME_HDRS) ao_scheme_const.h - -OBJS=$(SRCS:.c=.o) - -CFLAGS=-O0 -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -ao-scheme-tiny: $(OBJS) -	cc $(CFLAGS) -o $@ $(OBJS) -lm -	./ao-scheme-tiny ao_scheme_tiny_test.scheme - -$(OBJS): $(HDRS) - -ao_scheme_const.h: ao_scheme_make_const ao_scheme_basic_syntax.scheme ao_scheme_finish.scheme -	$^ -o $@ -d FLOAT,VECTOR,QUASI,BIGINT,PORT,POSIX,GPIO,UNDEF - -clean:: -	rm -f $(OBJS) ao-scheme-tiny ao_scheme_const.h - -install: ao-scheme-tiny -	cp $^ $$HOME/bin diff --git a/src/scheme/tiny-test/ao_scheme_os.h b/src/scheme/tiny-test/ao_scheme_os.h deleted file mode 100644 index 17d66ae3..00000000 --- a/src/scheme/tiny-test/ao_scheme_os.h +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include <stdio.h> -#include <stdlib.h> -#include <time.h> - -#define AO_SCHEME_POOL_TOTAL	4096 - -static inline void -ao_scheme_abort(void) -{ -	abort(); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND	100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ -	struct timespec ts = { -		.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_scheme_os_jiffy(void) -{ -	struct timespec tp; -	clock_gettime(CLOCK_MONOTONIC, &tp); -	return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/scheme/tiny-test/ao_scheme_tiny_const.scheme b/src/scheme/tiny-test/ao_scheme_tiny_const.scheme deleted file mode 100644 index d0c0e578..00000000 --- a/src/scheme/tiny-test/ao_scheme_tiny_const.scheme +++ /dev/null @@ -1,389 +0,0 @@ -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - -					; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) -     (macro (a b) -	    (list -	     def -	     (list quote a) -	     b) -	    ) -     ) - -(begin - (def! append -   (lambda args -	  (def! a-l -	    (lambda (a b) -	      (cond ((null? a) b) -		    (else (cons (car a) (a-l (cdr a) b))) -		    ) -	      ) -	    ) -	     -	  (def! a-ls -	    (lambda (l) -	      (cond ((null? l) l) -		    ((null? (cdr l)) (car l)) -		    (else (a-l (car l) (a-ls (cdr l)))) -		    ) -	      ) -	    ) -	  (a-ls args) -	  ) -   ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - -					; -					; Define a variable without returning the value -					; Useful when defining functions to avoid -					; having lots of output generated. -					; -					; Also accepts the alternate -					; form for defining lambdas of -					; (define (name a y z) sexprs ...)  -					; - -(begin - (def (quote define) -   (macro (a . b) -					; check for alternate lambda definition form - -	  (cond ((list? a) -		 (set! b -		       (cons lambda (cons (cdr a) b))) -		 (set! a (car a)) -		 ) -		(else -		 (set! b (car b)) -		 ) -		) -	  (cons begin -		(cons -		 (cons def -		       (cons (cons quote (cons a '())) -			     (cons b '()) -			     ) -		       ) -		 (cons -		  (cons quote (cons a '())) -		  '()) -		 ) -		) -	  ) -   ) - 'define - ) - -					; basic list accessors - -(define (caar l) (car (car l))) - -(define (cadr l) (car (cdr l))) - -(define (cdar l) (cdr (car l))) - -(define (caddr l) (car (cdr (cdr l)))) - -					; (if <condition> <if-true>) -					; (if <condition> <if-true> <if-false) - -(define if -  (macro (test . args) -    (cond ((null? (cdr args)) -	   (list cond (list test (car args))) -		) -	  (else -	   (list cond -		 (list test (car args)) -		 (list 'else (cadr args)) -		 ) -	   ) -	  ) -    ) -  ) - -(if (> 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - -					; simple math operators - -(define zero? (macro (value) (list eqv? value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) (list > value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) (list < value 0))) - -(negative? 12) -(negative? -12) - -(define (abs a) (if (>= a 0) a (- a))) - -(abs 12) -(abs -12) - -(define max (lambda (a . b) -		   (while (not (null? b)) -		     (cond ((< a (car b)) -			    (set! a (car b))) -			   ) -		     (set! b (cdr b)) -		     ) -		   a) -  ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (a . b) -		   (while (not (null? b)) -		     (cond ((> a (car b)) -			    (set! a (car b))) -			   ) -		     (set! b (cdr b)) -		     ) -		   a) -  ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? a) (zero? (% a 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? a) (not (even? a))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - - -(define (list-tail a b) -  (if (zero? b) -      a -    (list-tail (cdr a (- b 1))) -    ) -  ) - -(define (list-ref a b) -  (car (list-tail a b)) -  ) - -(define (list-tail a b) -  (if (zero? b) -      a -    (list-tail (cdr a) (- b 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref a b) (car (list-tail a b))) - -(list-ref '(1 2 3) 2) -     - -					; define a set of local -					; variables one at a time and -					; then evaluate a list of -					; sexprs -					; -					; (let* (var-defines) sexprs) -					; -					; where var-defines are either -					; -					; (name value) -					; -					; or -					; -					; (name) -					; -					; e.g. -					; -					; (let* ((x 1) (y)) (set! y (+ x 1)) y) - -(define let* -  (macro (a . b) - -					; -					; make the list of names in the let -					; - -	 (define (_n a) -	   (cond ((not (null? a)) -		  (cons (car (car a)) -			(_n (cdr a)))) -		 (else ()) -		 ) -	   ) - -					; the set of expressions is -					; the list of set expressions -					; pre-pended to the -					; expressions to evaluate - -	 (define (_v a b) -	   (cond ((null? a) b)		 (else -		  (cons -		   (list set -			 (list quote -			       (car (car a)) -			       ) -			 (cond ((null? (cdr (car a))) ()) -			       (else (cadr (car a)))) -			 ) -		   (_v (cdr a) b) -		   ) -		  ) -		 ) -	   ) - -					; the parameters to the lambda is a list -					; of nils of the right length - -	 (define (_z a) -	   (cond ((null? a) ()) -		 (else (cons () (_z (cdr a)))) -		 ) -	   ) -					; build the lambda. - -	 (cons (cons lambda (cons (_n a) (_v a b))) (_z a)) -	 ) -     ) - -(let* ((a 1) (y a)) (+ a y)) - -(define let let*) -					; recursive equality - -(define (equal? a b) -  (cond ((eq? a b) #t) -	((pair? a) -	 (cond ((pair? b) -		(cond ((equal? (car a) (car b)) -		       (equal? (cdr a) (cdr b))) -		      ) -		) -	       ) -	 ) -	) -  ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) - -(define member (lambda (obj a . test?) -		      (cond ((null? a) -			     #f -			     ) -			    (else -			     (if (null? test?) (set! test? equal?) (set! test? (car test?))) -			     (if (test? obj (car a)) -				 a -			       (member obj (cdr a) test?)) -			     ) -			    ) -		      ) -  ) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) - -(define (memq obj a) (member obj a eq?)) - -(memq 2 '(1 2 3)) - -(memq 4 '(1 2 3)) - -(memq '(2) '((1) (2) (3))) - -(define (_assoc a b t?) -  (if (null? b) -      #f -    (if (t? a (caar b)) -	(car b) -      (_assoc a (cdr b) t?) -      ) -    ) -  ) - -(define (assq a b) (_assoc a b eq?)) -(define (assoc a b) (_assoc a b equal?)) - -(assq 'a '((a 1) (b 2) (c 3))) -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define string (lambda a (list->string a))) - -(display "apply\n") -(apply cons '(a b)) - -(define map -  (lambda (a . b) -	 (define (args b) -	   (cond ((null? b) ()) -		 (else -		  (cons (caar b) (args (cdr b))) -		  ) -		 ) -	   ) -	 (define (next b) -	   (cond ((null? b) ()) -		 (else -		  (cons (cdr (car b)) (next (cdr b))) -		  ) -		 ) -	   ) -	 (define (domap b) -	   (cond ((null? (car b)) ()) -		 (else -		  (cons (apply a (args b)) (domap (next b))) -		  ) -		 ) -	   ) -	 (domap b) -	 ) -  ) - -(map cadr '((a b) (d e) (g h))) - -(define for-each (lambda (a . b) -			(apply map a b) -			#t)) - -(for-each display '("hello" " " "world" "\n")) - -(define (newline) (write-char #\newline)) - -(newline) diff --git a/src/scheme/tiny-test/ao_scheme_tiny_test.scheme b/src/scheme/tiny-test/ao_scheme_tiny_test.scheme deleted file mode 100644 index 94c90ffe..00000000 --- a/src/scheme/tiny-test/ao_scheme_tiny_test.scheme +++ /dev/null @@ -1,56 +0,0 @@ -					; Basic syntax tests - -(define _assert-eq_ -  (macro (a b) -	   (list cond -		 (list (list eq? a b) -		       ) -		 (list 'else -		       (list display "failed: ") -		       (list write (list quote a)) -		       (list newline) -		       (list exit 1) -		       ) -		 ) -	   ) -  ) - -(define _assert-equal_ -  (macro (a b) -	   (list cond -		 (list (list equal? a b) -		       ) -		 (list 'else -		       (list display "failed: ") -		       (list write (list quote a)) -		       (list newline) -		       (list exit 1) -		       ) -		 ) -	   ) -  ) - -(_assert-eq_ (or #f #t) #t) -(_assert-eq_ (and #t #f) #f) -(_assert-eq_ (if (> 3 2) 'yes) 'yes) -(_assert-eq_ (if (> 3 2) 'yes 'no) 'yes) -(_assert-eq_ (if (> 2 3) 'no 'yes) 'yes) -(_assert-eq_ (if (> 2 3) 'no) #f) - -(_assert-eq_ (letrec ((a 1) (b a)) (+ a b)) 2) - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) - -(_assert-equal_ (member '(2) '((1) (2) (3)))  '((2) (3))) -(_assert-equal_ (member '(4) '((1) (2) (3))) #f) - -(_assert-equal_ (memq 2 '(1 2 3)) '(2 3)) -(_assert-equal_ (memq 4 '(1 2 3)) #f) -(_assert-equal_ (memq '(2) '((1) (2) (3))) #f) - -(_assert-equal_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_assert-equal_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(_assert-equal_ (map cadr '((a b) (d e) (g h))) '(b e h)) - diff --git a/src/stmf0/Makefile-stmf0.defs b/src/stmf0/Makefile-stmf0.defs index fa6e6e86..4e9fa551 100644 --- a/src/stmf0/Makefile-stmf0.defs +++ b/src/stmf0/Makefile-stmf0.defs @@ -4,7 +4,7 @@ endif  include $(TOPDIR)/Makedefs -vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math:$(TOPDIR)/scheme +vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math  vpath make-altitude $(TOPDIR)/util  vpath make-kalman $(TOPDIR)/util  vpath kalman.5c $(TOPDIR)/kalman | 
