diff options
| author | Bdale Garbee <bdale@gag.com> | 2017-12-05 13:23:09 -0700 | 
|---|---|---|
| committer | Bdale Garbee <bdale@gag.com> | 2017-12-05 13:23:09 -0700 | 
| commit | 2f8fce1cf6ce4bd12a836cc8ee15f4edbc95c95e (patch) | |
| tree | 19a1bcb93694eb259f29e9ef9690bb31a9b8fa60 /src/scheme | |
| parent | d314a5654fafa5eac86d8293f1197a2f2c2eac72 (diff) | |
| parent | 185b11367cd85948885fceafb5d46303b6f1356d (diff) | |
Merge branch 'master' of ssh://git.gag.com/scm/git/fw/altos
Diffstat (limited to 'src/scheme')
36 files changed, 8086 insertions, 0 deletions
| diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore new file mode 100644 index 00000000..ee72cb9d --- /dev/null +++ b/src/scheme/.gitignore @@ -0,0 +1,2 @@ +ao_scheme_const.h +ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile new file mode 100644 index 00000000..ea94c1c0 --- /dev/null +++ b/src/scheme/Makefile @@ -0,0 +1,20 @@ +all: ao_scheme_builtin.h ao_scheme_const.h test/ao_scheme_test + +clean: +	+cd make-const && make clean +	+cd test && make clean +	rm -f ao_scheme_const.h ao_scheme_builtin.h + +ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const +	make-const/ao_scheme_make_const -o $@ ao_scheme_const.lisp + +ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt +	nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ + +make-const/ao_scheme_make_const: FRC ao_scheme_builtin.h +	+cd make-const && make ao_scheme_make_const + +test/ao_scheme_test: FRC ao_scheme_const.h ao_scheme_builtin.h +	+cd test && make ao_scheme_test + +FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc new file mode 100644 index 00000000..d23ee3d7 --- /dev/null +++ b/src/scheme/Makefile-inc @@ -0,0 +1,24 @@ +SCHEME_SRCS=\ +	ao_scheme_mem.c \ +	ao_scheme_cons.c \ +	ao_scheme_string.c \ +	ao_scheme_atom.c \ +	ao_scheme_int.c \ +	ao_scheme_poly.c \ +	ao_scheme_bool.c \ +	ao_scheme_float.c \ +	ao_scheme_builtin.c \ +	ao_scheme_read.c \ +	ao_scheme_frame.c \ +	ao_scheme_lambda.c \ +	ao_scheme_eval.c \ +	ao_scheme_rep.c \ +	ao_scheme_save.c \ +	ao_scheme_stack.c \ +	ao_scheme_error.c  + +SCHEME_HDRS=\ +	ao_scheme.h \ +	ao_scheme_os.h \ +	ao_scheme_read.h \ +	ao_scheme_builtin.h diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme new file mode 100644 index 00000000..b9018e19 --- /dev/null +++ b/src/scheme/Makefile-scheme @@ -0,0 +1,4 @@ +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 new file mode 100644 index 00000000..98932b44 --- /dev/null +++ b/src/scheme/README @@ -0,0 +1,10 @@ +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; (have classic macros) +* No record types +* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h new file mode 100644 index 00000000..4589f8a5 --- /dev/null +++ b/src/scheme/ao_scheme.h @@ -0,0 +1,928 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#ifndef _AO_SCHEME_H_ +#define _AO_SCHEME_H_ + +#define DBG_MEM		0 +#define DBG_EVAL	0 +#define DBG_READ	0 +#define DBG_FREE_CONS	0 +#define NDEBUG		1 + +#include <stdint.h> +#include <string.h> +#include <ao_scheme_os.h> +#ifndef __BYTE_ORDER +#include <endian.h> +#endif + +typedef uint16_t	ao_poly; +typedef int16_t		ao_signed_poly; + +#ifdef AO_SCHEME_SAVE + +struct ao_scheme_os_save { +	ao_poly		atoms; +	ao_poly		globals; +	uint16_t	const_checksum; +	uint16_t	const_checksum_inv; +}; + +#define AO_SCHEME_POOL_EXTRA	(sizeof(struct ao_scheme_os_save)) +#define AO_SCHEME_POOL	((int) (AO_SCHEME_POOL_TOTAL - AO_SCHEME_POOL_EXTRA)) + +int +ao_scheme_os_save(void); + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); + +int +ao_scheme_os_restore(void); + +#endif + +#ifdef AO_SCHEME_MAKE_CONST +#define AO_SCHEME_POOL_CONST	16384 +extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern(n)) +#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) + +#define _ao_scheme_bool_true	_bool(1) +#define _ao_scheme_bool_false	_bool(0) + +#define _ao_scheme_atom_eof	_atom("eof") +#define _ao_scheme_atom_else	_atom("else") + +#define AO_SCHEME_BUILTIN_ATOMS +#include "ao_scheme_builtin.h" + +#else +#include "ao_scheme_const.h" +#ifndef AO_SCHEME_POOL +#define AO_SCHEME_POOL	3072 +#endif +extern uint8_t		ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); +#endif + +/* Primitive types */ +#define AO_SCHEME_CONS		0 +#define AO_SCHEME_INT		1 +#define AO_SCHEME_STRING	2 +#define AO_SCHEME_OTHER		3 + +#define AO_SCHEME_TYPE_MASK	0x0003 +#define AO_SCHEME_TYPE_SHIFT	2 +#define AO_SCHEME_REF_MASK	0x7ffc +#define AO_SCHEME_CONST		0x8000 + +/* These have a type value at the start of the struct */ +#define AO_SCHEME_ATOM		4 +#define AO_SCHEME_BUILTIN	5 +#define AO_SCHEME_FRAME		6 +#define AO_SCHEME_FRAME_VALS	7 +#define AO_SCHEME_LAMBDA	8 +#define AO_SCHEME_STACK		9 +#define AO_SCHEME_BOOL		10 +#define AO_SCHEME_BIGINT	11 +#define AO_SCHEME_FLOAT		12 +#define AO_SCHEME_NUM_TYPE	13 + +/* Leave two bits for types to use as they please */ +#define AO_SCHEME_OTHER_TYPE_MASK	0x3f + +#define AO_SCHEME_NIL	0 + +extern uint16_t		ao_scheme_top; + +#define AO_SCHEME_OOM			0x01 +#define AO_SCHEME_DIVIDE_BY_ZERO	0x02 +#define AO_SCHEME_INVALID		0x04 +#define AO_SCHEME_UNDEFINED		0x08 +#define AO_SCHEME_REDEFINED		0x10 +#define AO_SCHEME_EOF			0x20 +#define AO_SCHEME_EXIT			0x40 + +extern uint8_t		ao_scheme_exception; + +static inline int +ao_scheme_is_const(ao_poly poly) { +	return poly & AO_SCHEME_CONST; +} + +#define AO_SCHEME_IS_CONST(a)	(ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) +#define AO_SCHEME_IS_POOL(a)	(ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +#define AO_SCHEME_IS_INT(p)	(ao_scheme_poly_base_type(p) == AO_SCHEME_INT) + +void * +ao_scheme_ref(ao_poly poly); + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type); + +struct ao_scheme_type { +	int	(*size)(void *addr); +	void	(*mark)(void *addr); +	void	(*move)(void *addr); +	char	name[]; +}; + +struct ao_scheme_cons { +	ao_poly		car; +	ao_poly		cdr; +}; + +struct ao_scheme_atom { +	uint8_t		type; +	uint8_t		pad[1]; +	ao_poly		next; +	char		name[]; +}; + +struct ao_scheme_val { +	ao_poly		atom; +	ao_poly		val; +}; + +struct ao_scheme_frame_vals { +	uint8_t			type; +	uint8_t			size; +	struct ao_scheme_val	vals[]; +}; + +struct ao_scheme_frame { +	uint8_t			type; +	uint8_t			num; +	ao_poly			prev; +	ao_poly			vals; +}; + +struct ao_scheme_bool { +	uint8_t			type; +	uint8_t			value; +	uint16_t		pad; +}; + +struct ao_scheme_bigint { +	uint32_t		value; +}; + +struct ao_scheme_float { +	uint8_t			type; +	uint8_t			pad1; +	uint16_t		pad2; +	float			value; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { +	return AO_SCHEME_BIGINT | (i << 8); +} +static inline int32_t +ao_scheme_bigint_int(uint32_t bi) { +	return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { +	return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); +} +static inlint int32_t +ao_scheme_bigint_int(uint32_t bi) { +	return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_SCHEME_MIN_INT	(-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) +#define AO_SCHEME_MAX_INT	((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) +#define AO_SCHEME_MIN_BIGINT	(-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT	((1 << 24) - 1) + +#define AO_SCHEME_NOT_INTEGER	0x7fffffff + +/* Set on type when the frame escapes the lambda */ +#define AO_SCHEME_FRAME_MARK	0x80 +#define AO_SCHEME_FRAME_PRINT	0x40 + +static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { +	return f->type & AO_SCHEME_FRAME_MARK; +} + +static inline struct ao_scheme_frame * +ao_scheme_poly_frame(ao_poly poly) { +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_poly(struct ao_scheme_frame *frame) { +	return ao_scheme_poly(frame, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_frame_vals * +ao_scheme_poly_frame_vals(ao_poly poly) { +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_vals_poly(struct ao_scheme_frame_vals *vals) { +	return ao_scheme_poly(vals, AO_SCHEME_OTHER); +} + +enum eval_state { +	eval_sexpr,		/* Evaluate an sexpr */ +	eval_val,		/* Value computed */ +	eval_formal,		/* Formal computed */ +	eval_exec,		/* Start a lambda evaluation */ +	eval_apply,		/* Execute apply */ +	eval_cond,		/* Start next cond clause */ +	eval_cond_test,		/* Check cond condition */ +	eval_begin,		/* Start next begin entry */ +	eval_while,		/* Start while condition */ +	eval_while_test,	/* Check while condition */ +	eval_macro,		/* Finished with macro generation */ +}; + +struct ao_scheme_stack { +	uint8_t			type;		/* AO_SCHEME_STACK */ +	uint8_t			state;		/* enum eval_state */ +	ao_poly			prev;		/* previous stack frame */ +	ao_poly			sexprs;		/* expressions to evaluate */ +	ao_poly			values;		/* values computed */ +	ao_poly			values_tail;	/* end of the values list for easy appending */ +	ao_poly			frame;		/* current lookup frame */ +	ao_poly			list;		/* most recent function call */ +}; + +#define AO_SCHEME_STACK_MARK	0x80	/* set on type when a reference has been taken */ +#define AO_SCHEME_STACK_PRINT	0x40	/* stack is being printed */ + +static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { +	return s->type & AO_SCHEME_STACK_MARK; +} + +static inline void ao_scheme_stack_mark(struct ao_scheme_stack *s) { +	s->type |= AO_SCHEME_STACK_MARK; +} + +static inline struct ao_scheme_stack * +ao_scheme_poly_stack(ao_poly p) +{ +	return ao_scheme_ref(p); +} + +static inline ao_poly +ao_scheme_stack_poly(struct ao_scheme_stack *stack) +{ +	return ao_scheme_poly(stack, AO_SCHEME_OTHER); +} + +extern ao_poly			ao_scheme_v; + +#define AO_SCHEME_FUNC_LAMBDA		0 +#define AO_SCHEME_FUNC_NLAMBDA		1 +#define AO_SCHEME_FUNC_MACRO		2 + +#define AO_SCHEME_FUNC_FREE_ARGS	0x80 +#define AO_SCHEME_FUNC_MASK		0x7f + +#define AO_SCHEME_FUNC_F_LAMBDA		(AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_LAMBDA) +#define AO_SCHEME_FUNC_F_NLAMBDA	(AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_NLAMBDA) +#define AO_SCHEME_FUNC_F_MACRO		(AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_MACRO) + +struct ao_scheme_builtin { +	uint8_t		type; +	uint8_t		args; +	uint16_t	func; +}; + +#define AO_SCHEME_BUILTIN_ID +#include "ao_scheme_builtin.h" + +typedef ao_poly (*ao_scheme_func_t)(struct ao_scheme_cons *cons); + +extern const ao_scheme_func_t	ao_scheme_builtins[]; + +static inline ao_scheme_func_t +ao_scheme_func(struct ao_scheme_builtin *b) +{ +	return ao_scheme_builtins[b->func]; +} + +struct ao_scheme_lambda { +	uint8_t		type; +	uint8_t		args; +	ao_poly		code; +	ao_poly		frame; +}; + +static inline struct ao_scheme_lambda * +ao_scheme_poly_lambda(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_lambda_poly(struct ao_scheme_lambda *lambda) +{ +	return ao_scheme_poly(lambda, AO_SCHEME_OTHER); +} + +static inline void * +ao_scheme_poly_other(ao_poly poly) { +	return ao_scheme_ref(poly); +} + +static inline uint8_t +ao_scheme_other_type(void *other) { +#if DBG_MEM +	if ((*((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK) >= AO_SCHEME_NUM_TYPE) +		ao_scheme_abort(); +#endif +	return *((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK; +} + +static inline ao_poly +ao_scheme_other_poly(const void *other) +{ +	return ao_scheme_poly(other, AO_SCHEME_OTHER); +} + +static inline int +ao_scheme_size_round(int size) +{ +	return (size + 3) & ~3; +} + +static inline int +ao_scheme_size(const struct ao_scheme_type *type, void *addr) +{ +	return ao_scheme_size_round(type->size(addr)); +} + +#define AO_SCHEME_OTHER_POLY(other) ((ao_poly)(other) + AO_SCHEME_OTHER) + +static inline int ao_scheme_poly_base_type(ao_poly poly) { +	return poly & AO_SCHEME_TYPE_MASK; +} + +static inline int ao_scheme_poly_type(ao_poly poly) { +	int	type = poly & AO_SCHEME_TYPE_MASK; +	if (type == AO_SCHEME_OTHER) +		return ao_scheme_other_type(ao_scheme_poly_other(poly)); +	return type; +} + +static inline int +ao_scheme_is_cons(ao_poly poly) { +	return (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline int +ao_scheme_is_pair(ao_poly poly) { +	return poly != AO_SCHEME_NIL && (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline struct ao_scheme_cons * +ao_scheme_poly_cons(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_cons_poly(struct ao_scheme_cons *cons) +{ +	return ao_scheme_poly(cons, AO_SCHEME_CONS); +} + +static inline int32_t +ao_scheme_poly_int(ao_poly poly) +{ +	return (int32_t) ((ao_signed_poly) poly >> AO_SCHEME_TYPE_SHIFT); +} + +static inline ao_poly +ao_scheme_int_poly(int32_t i) +{ +	return ((ao_poly) i << 2) | AO_SCHEME_INT; +} + +static inline struct ao_scheme_bigint * +ao_scheme_poly_bigint(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) +{ +	return ao_scheme_poly(bi, AO_SCHEME_OTHER); +} + +static inline char * +ao_scheme_poly_string(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_string_poly(char *s) +{ +	return ao_scheme_poly(s, AO_SCHEME_STRING); +} + +static inline struct ao_scheme_atom * +ao_scheme_poly_atom(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_atom_poly(struct ao_scheme_atom *a) +{ +	return ao_scheme_poly(a, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_builtin * +ao_scheme_poly_builtin(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_builtin_poly(struct ao_scheme_builtin *b) +{ +	return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline ao_poly +ao_scheme_bool_poly(struct ao_scheme_bool *b) +{ +	return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_bool * +ao_scheme_poly_bool(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_float_poly(struct ao_scheme_float *f) +{ +	return ao_scheme_poly(f, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_float * +ao_scheme_poly_float(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* memory functions */ + +extern int ao_scheme_collects[2]; +extern int ao_scheme_freed[2]; +extern int ao_scheme_loops[2]; + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); + +void * +ao_scheme_move_map(void *addr); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); + +void * +ao_scheme_alloc(int size); + +#define AO_SCHEME_COLLECT_FULL		1 +#define AO_SCHEME_COLLECT_INCREMENTAL	0 + +int +ao_scheme_collect(uint8_t style); + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons); +#endif + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id); + +void +ao_scheme_poly_stash(int id, ao_poly poly); + +ao_poly +ao_scheme_poly_fetch(int id); + +void +ao_scheme_string_stash(int id, char *string); + +char * +ao_scheme_string_fetch(int id); + +static inline void +ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { +	ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +} + +static inline struct ao_scheme_stack * +ao_scheme_stack_fetch(int id) { +	return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id); + +/* bool */ + +extern const struct ao_scheme_type ao_scheme_bool_type; + +void +ao_scheme_bool_write(ao_poly v); + +#ifdef AO_SCHEME_MAKE_CONST +struct ao_scheme_bool	*ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value); +#endif + +/* cons */ +extern const struct ao_scheme_type ao_scheme_cons_type; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr); + +/* Return a cons or NULL for a proper list, else error */ +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr); + +extern struct ao_scheme_cons *ao_scheme_cons_free_list; + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons); + +void +ao_scheme_cons_write(ao_poly); + +void +ao_scheme_cons_display(ao_poly); + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons); + +/* string */ +extern const struct ao_scheme_type ao_scheme_string_type; + +char * +ao_scheme_string_copy(char *a); + +char * +ao_scheme_string_cat(char *a, char *b); + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme_string_unpack(char *a); + +void +ao_scheme_string_write(ao_poly s); + +void +ao_scheme_string_display(ao_poly s); + +/* atom */ +extern const struct ao_scheme_type ao_scheme_atom_type; + +extern struct ao_scheme_atom	*ao_scheme_atoms; +extern struct ao_scheme_frame	*ao_scheme_frame_global; +extern struct ao_scheme_frame	*ao_scheme_frame_current; + +void +ao_scheme_atom_write(ao_poly a); + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name); + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); + +ao_poly +ao_scheme_atom_get(ao_poly atom); + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val); + +/* int */ +void +ao_scheme_int_write(ao_poly i); + +int32_t +ao_scheme_poly_integer(ao_poly p); + +ao_poly +ao_scheme_integer_poly(int32_t i); + +static inline int +ao_scheme_integer_typep(uint8_t t) +{ +	return (t == AO_SCHEME_INT) || (t == AO_SCHEME_BIGINT); +} + +void +ao_scheme_bigint_write(ao_poly i); + +extern const struct ao_scheme_type	ao_scheme_bigint_type; +/* prim */ +void +ao_scheme_poly_write(ao_poly p); + +void +ao_scheme_poly_display(ao_poly p); + +int +ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); + +/* returns 1 if the object has already been moved */ +int +ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); + +/* eval */ + +void +ao_scheme_eval_clear_globals(void); + +int +ao_scheme_eval_restart(void); + +ao_poly +ao_scheme_eval(ao_poly p); + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *cons); + +/* float */ +extern const struct ao_scheme_type ao_scheme_float_type; + +void +ao_scheme_float_write(ao_poly p); + +ao_poly +ao_scheme_float_get(float value); + +static inline uint8_t +ao_scheme_number_typep(uint8_t t) +{ +	return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* builtin */ +void +ao_scheme_builtin_write(ao_poly b); + +extern const struct ao_scheme_type ao_scheme_builtin_type; + +/* Check argument count */ +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc); + +char * +ao_scheme_args_name(uint8_t args); + +/* read */ +extern struct ao_scheme_cons	*ao_scheme_read_cons; +extern struct ao_scheme_cons	*ao_scheme_read_cons_tail; +extern struct ao_scheme_cons	*ao_scheme_read_stack; + +ao_poly +ao_scheme_read(void); + +/* rep */ +ao_poly +ao_scheme_read_eval_print(void); + +/* frame */ +extern const struct ao_scheme_type ao_scheme_frame_type; +extern const struct ao_scheme_type ao_scheme_frame_vals_type; + +#define AO_SCHEME_FRAME_FREE	6 + +extern struct ao_scheme_frame	*ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame); + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom); + +struct ao_scheme_frame * +ao_scheme_frame_new(int num); + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame); + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); + +void +ao_scheme_frame_write(ao_poly p); + +void +ao_scheme_frame_init(void); + +/* lambda */ +extern const struct ao_scheme_type ao_scheme_lambda_type; + +extern const char * const ao_scheme_state_names[]; + +struct ao_scheme_lambda * +ao_scheme_lambda_new(ao_poly cons); + +void +ao_scheme_lambda_write(ao_poly lambda); + +ao_poly +ao_scheme_lambda_eval(void); + +/* stack */ + +extern const struct ao_scheme_type ao_scheme_stack_type; +extern struct ao_scheme_stack	*ao_scheme_stack; +extern struct ao_scheme_stack	*ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack); + +int +ao_scheme_stack_push(void); + +void +ao_scheme_stack_pop(void); + +void +ao_scheme_stack_clear(void); + +void +ao_scheme_stack_write(ao_poly stack); + +ao_poly +ao_scheme_stack_eval(void); + +/* error */ + +void +ao_scheme_vprintf(char *format, va_list args); + +void +ao_scheme_printf(char *format, ...); + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last); + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame); + +ao_poly +ao_scheme_error(int error, char *format, ...); + +/* builtins */ + +#define AO_SCHEME_BUILTIN_DECLS +#include "ao_scheme_builtin.h" + +/* debugging macros */ + +#if DBG_EVAL || DBG_READ || DBG_MEM +#define DBG_CODE	1 +int ao_scheme_stack_depth; +#define DBG_DO(a)	a +#define DBG_INDENT()	do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf("  "); } while(0) +#define DBG_IN()	(++ao_scheme_stack_depth) +#define DBG_OUT()	(--ao_scheme_stack_depth) +#define DBG_RESET()	(ao_scheme_stack_depth = 0) +#define DBG(...) 	ao_scheme_printf(__VA_ARGS__) +#define DBGI(...)	do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBG_CONS(a)	ao_scheme_cons_write(ao_scheme_cons_poly(a)) +#define DBG_POLY(a)	ao_scheme_poly_write(a) +#define OFFSET(a)	((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) +#define DBG_STACK()	ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)) +static inline void +ao_scheme_frames_dump(void) +{ +	struct ao_scheme_stack *s; +	DBGI(".. current frame: "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	for (s = ao_scheme_stack; s; s = ao_scheme_poly_stack(s->prev)) { +		DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); +	} +} +#define DBG_FRAMES()	ao_scheme_frames_dump() +#else +#define DBG_DO(a) +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#define DBG_FRAMES() +#endif + +#if DBG_READ +#define RDBGI(...)	DBGI(__VA_ARGS__) +#define RDBG_IN()	DBG_IN() +#define RDBG_OUT()	DBG_OUT() +#else +#define RDBGI(...) +#define RDBG_IN() +#define RDBG_OUT() +#endif + +#define DBG_MEM_START	1 + +#if DBG_MEM + +#include <assert.h> +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a)	((a) ? (int) ((uint8_t *) (a) - ao_scheme_pool) : -1) + +extern int dbg_mem; + +#define MDBG_DO(a)	DBG_DO(a) +#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf ("  "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) +#define MDBG_MOVE_IN()	(dbg_move_depth++) +#define MDBG_MOVE_OUT()	(assert(--dbg_move_depth >= 0)) + +#else + +#define MDBG_DO(a) +#define MDBG_MOVE(...) +#define MDBG_MORE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() + +#endif + +#endif /* _AO_SCHEME_H_ */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c new file mode 100644 index 00000000..cb32b7fe --- /dev/null +++ b/src/scheme/ao_scheme_atom.c @@ -0,0 +1,167 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +static int name_size(char *name) +{ +	return sizeof(struct ao_scheme_atom) + strlen(name) + 1; +} + +static int atom_size(void *addr) +{ +	struct ao_scheme_atom	*atom = addr; +	if (!atom) +		return 0; +	return name_size(atom->name); +} + +static void atom_mark(void *addr) +{ +	struct ao_scheme_atom	*atom = addr; + +	for (;;) { +		atom = ao_scheme_poly_atom(atom->next); +		if (!atom) +			break; +		if (ao_scheme_mark_memory(&ao_scheme_atom_type, atom)) +			break; +	} +} + +static void atom_move(void *addr) +{ +	struct ao_scheme_atom	*atom = addr; +	int			ret; + +	for (;;) { +		struct ao_scheme_atom *next = ao_scheme_poly_atom(atom->next); + +		if (!next) +			break; +		ret = ao_scheme_move_memory(&ao_scheme_atom_type, (void **) &next); +		if (next != ao_scheme_poly_atom(atom->next)) +			atom->next = ao_scheme_atom_poly(next); +		if (ret) +			break; +		atom = next; +	} +} + +const struct ao_scheme_type ao_scheme_atom_type = { +	.mark = atom_mark, +	.size = atom_size, +	.move = atom_move, +	.name = "atom" +}; + +struct ao_scheme_atom	*ao_scheme_atoms; + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name) +{ +	struct ao_scheme_atom	*atom; + +	for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { +		if (!strcmp(atom->name, name)) +			return atom; +	} +#ifdef ao_builtin_atoms +	for (atom = ao_scheme_poly_atom(ao_builtin_atoms); atom; atom = ao_scheme_poly_atom(atom->next)) { +		if (!strcmp(atom->name, name)) +			return atom; +	} +#endif +	ao_scheme_string_stash(0, name); +	atom = ao_scheme_alloc(name_size(name)); +	name = ao_scheme_string_fetch(0); +	if (atom) { +		atom->type = AO_SCHEME_ATOM; +		atom->next = ao_scheme_atom_poly(ao_scheme_atoms); +		ao_scheme_atoms = atom; +		strcpy(atom->name, name); +	} +	return atom; +} + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref) +{ +	ao_poly	*ref; +	struct ao_scheme_frame *frame; + +	for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) { +		ref = ao_scheme_frame_ref(frame, atom); +		if (ref) { +			if (frame_ref) +				*frame_ref = frame; +			return ref; +		} +	} +	ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom); +	if (ref) +		if (frame_ref) +			*frame_ref = ao_scheme_frame_global; +	return ref; +} + +ao_poly +ao_scheme_atom_get(ao_poly atom) +{ +	ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +#ifdef ao_builtin_frame +	if (!ref) +		ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom); +#endif +	if (ref) +		return *ref; +	return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +} + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val) +{ +	ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +	if (!ref) +		return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +	*ref = val; +	return val; +} + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val) +{ +	struct ao_scheme_frame	*frame; +	ao_poly *ref = ao_scheme_atom_ref(atom, &frame); + +	if (ref) { +		if (frame == ao_scheme_frame_current) +			return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name); +		*ref = val; +		return val; +	} +	return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val); +} + +void +ao_scheme_atom_write(ao_poly a) +{ +	struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); +	printf("%s", atom->name); +} diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c new file mode 100644 index 00000000..c1e880ca --- /dev/null +++ b/src/scheme/ao_scheme_bool.c @@ -0,0 +1,73 @@ +/* + * 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(ao_poly v) +{ +	struct ao_scheme_bool	*b = ao_scheme_poly_bool(v); + +	if (b->value) +		printf("#t"); +	else +		printf("#f"); +} + +#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 new file mode 100644 index 00000000..49f218f6 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,868 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <limits.h> +#include <math.h> + +static int +builtin_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_builtin); +} + +static void +builtin_mark(void *addr) +{ +	(void) addr; +} + +static void +builtin_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_builtin_type = { +	.size = builtin_size, +	.mark = builtin_mark, +	.move = builtin_move +}; + +#ifdef AO_SCHEME_MAKE_CONST + +#define AO_SCHEME_BUILTIN_CASENAME +#include "ao_scheme_builtin.h" + +char *ao_scheme_args_name(uint8_t args) { +	args &= AO_SCHEME_FUNC_MASK; +	switch (args) { +	case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; +	case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; +	case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; +	default: return "???"; +	} +} +#else + +#define AO_SCHEME_BUILTIN_ARRAYNAME +#include "ao_scheme_builtin.h" + +static char * +ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { +	if (b < _builtin_last) +		return ao_scheme_poly_atom(builtin_names[b])->name; +	return "???"; +} + +static const ao_poly ao_scheme_args_atoms[] = { +	[AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, +	[AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, +	[AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, +}; + +char * +ao_scheme_args_name(uint8_t args) +{ +	args &= AO_SCHEME_FUNC_MASK; +	if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) +		return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; +	return "(unknown)"; +} +#endif + +void +ao_scheme_builtin_write(ao_poly b) +{ +	struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); +	printf("%s", ao_scheme_builtin_name(builtin->func)); +} + +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) +{ +	int	argc = 0; + +	while (cons && argc <= max) { +		argc++; +		cons = ao_scheme_cons_cdr(cons); +	} +	if (argc < min || argc > max) +		return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +{ +	if (!cons) +		return AO_SCHEME_NIL; +	while (argc--) { +		if (!cons) +			return AO_SCHEME_NIL; +		cons = ao_scheme_cons_cdr(cons); +	} +	return cons->car; +} + +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok) +{ +	ao_poly car = ao_scheme_arg(cons, argc); + +	if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) +		return ao_scheme_error(AO_SCHEME_INVALID, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_car(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(cons->car)->car; +} + +ao_poly +ao_scheme_do_cdr(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_scheme_do_cons(struct ao_scheme_cons *cons) +{ +	ao_poly	car, cdr; +	if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2)) +		return AO_SCHEME_NIL; +	car = ao_scheme_arg(cons, 0); +	cdr = ao_scheme_arg(cons, 1); +	return ao_scheme__cons(car, cdr); +} + +ao_poly +ao_scheme_do_last(struct ao_scheme_cons *cons) +{ +	struct ao_scheme_cons	*list; +	if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0)); +	     list; +	     list = ao_scheme_cons_cdr(list)) +	{ +		if (!list->cdr) +			return list->car; +	} +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_length(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_quote(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1)) +		return AO_SCHEME_NIL; +	return ao_scheme_arg(cons, 0); +} + +ao_poly +ao_scheme_do_set(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0)) +		return AO_SCHEME_NIL; + +	return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_def(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0)) +		return AO_SCHEME_NIL; + +	return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_setq(struct ao_scheme_cons *cons) +{ +	ao_poly	name; +	if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2)) +		return AO_SCHEME_NIL; +	name = cons->car; +	if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM) +		return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name); +	if (!ao_scheme_atom_ref(name, NULL)) +		return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name); +	return ao_scheme__cons(_ao_scheme_atom_set, +			     ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote, +							 ao_scheme__cons(name, AO_SCHEME_NIL)), +					   cons->cdr)); +} + +ao_poly +ao_scheme_do_cond(struct ao_scheme_cons *cons) +{ +	ao_scheme_set_cond(cons); +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_begin(struct ao_scheme_cons *cons) +{ +	ao_scheme_stack->state = eval_begin; +	ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_while(struct ao_scheme_cons *cons) +{ +	ao_scheme_stack->state = eval_while; +	ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_write(struct ao_scheme_cons *cons) +{ +	ao_poly	val = AO_SCHEME_NIL; +	while (cons) { +		val = cons->car; +		ao_scheme_poly_write(val); +		cons = ao_scheme_cons_cdr(cons); +		if (cons) +			printf(" "); +	} +	printf("\n"); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_display(struct ao_scheme_cons *cons) +{ +	ao_poly	val = AO_SCHEME_NIL; +	while (cons) { +		val = cons->car; +		ao_scheme_poly_display(val); +		cons = ao_scheme_cons_cdr(cons); +	} +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) +{ +	struct ao_scheme_cons *cons = cons; +	ao_poly	ret = AO_SCHEME_NIL; + +	for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { +		ao_poly		car = cons->car; +		uint8_t		rt = ao_scheme_poly_type(ret); +		uint8_t		ct = ao_scheme_poly_type(car); + +		if (cons == orig_cons) { +			ret = car; +			if (cons->cdr == AO_SCHEME_NIL) { +				switch (op) { +				case builtin_minus: +					if (ao_scheme_integer_typep(ct)) +						ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); +					else if (ct == AO_SCHEME_FLOAT) +						ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); +					break; +				case builtin_divide: +					if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) +						; +					else if (ao_scheme_number_typep(ct)) { +						float	v = ao_scheme_poly_number(ret); +						ret = ao_scheme_float_get(1/v); +					} +					break; +				default: +					break; +				} +			} +		} else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { +			int32_t	r = ao_scheme_poly_integer(ret); +			int32_t	c = ao_scheme_poly_integer(car); +			int64_t t; + +			switch(op) { +			case builtin_plus: +				r += c; +			check_overflow: +				if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) +					goto inexact; +				break; +			case builtin_minus: +				r -= c; +				goto check_overflow; +				break; +			case builtin_times: +				t = (int64_t) r * (int64_t) c; +				if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) +					goto inexact; +				r = (int32_t) t; +				break; +			case builtin_divide: +				if (c != 0 && (r % c) == 0) +					r /= c; +				else +					goto inexact; +				break; +			case builtin_quotient: +				if (c == 0) +					return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); +				if (r % c != 0 && (c < 0) != (r < 0)) +					r = r / c - 1; +				else +					r = r / c; +				break; +			case builtin_remainder: +				if (c == 0) +					return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); +				r %= c; +				break; +			case builtin_modulo: +				if (c == 0) +					return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); +				r %= c; +				if ((r < 0) != (c < 0)) +					r += c; +				break; +			default: +				break; +			} +			ret = ao_scheme_integer_poly(r); +		} else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { +			float r, c; +		inexact: +			r = ao_scheme_poly_number(ret); +			c = ao_scheme_poly_number(car); +			switch(op) { +			case builtin_plus: +				r += c; +				break; +			case builtin_minus: +				r -= c; +				break; +			case builtin_times: +				r *= c; +				break; +			case builtin_divide: +				r /= c; +				break; +			case builtin_quotient: +			case builtin_remainder: +			case builtin_modulo: +				return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); +			default: +				break; +			} +			ret = ao_scheme_float_get(r); +		} + +		else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) +			ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), +								     ao_scheme_poly_string(car))); +		else +			return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); +	} +	return ret; +} + +ao_poly +ao_scheme_do_plus(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_plus); +} + +ao_poly +ao_scheme_do_minus(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_minus); +} + +ao_poly +ao_scheme_do_times(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_times); +} + +ao_poly +ao_scheme_do_divide(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_divide); +} + +ao_poly +ao_scheme_do_quotient(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_quotient); +} + +ao_poly +ao_scheme_do_modulo(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_modulo); +} + +ao_poly +ao_scheme_do_remainder(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_remainder); +} + +ao_poly +ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) +{ +	ao_poly	left; + +	if (!cons) +		return _ao_scheme_bool_true; + +	left = cons->car; +	for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { +		ao_poly	right = cons->car; + +		if (op == builtin_equal) { +			if (left != right) +				return _ao_scheme_bool_false; +		} else { +			uint8_t	lt = ao_scheme_poly_type(left); +			uint8_t	rt = ao_scheme_poly_type(right); +			if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { +				int32_t l = ao_scheme_poly_integer(left); +				int32_t r = ao_scheme_poly_integer(right); + +				switch (op) { +				case builtin_less: +					if (!(l < r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater: +					if (!(l > r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_less_equal: +					if (!(l <= r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater_equal: +					if (!(l >= r)) +						return _ao_scheme_bool_false; +					break; +				default: +					break; +				} +			} else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { +				int c = strcmp(ao_scheme_poly_string(left), +					       ao_scheme_poly_string(right)); +				switch (op) { +				case builtin_less: +					if (!(c < 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater: +					if (!(c > 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_less_equal: +					if (!(c <= 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater_equal: +					if (!(c >= 0)) +						return _ao_scheme_bool_false; +					break; +				default: +					break; +				} +			} +		} +		left = right; +	} +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_equal(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_equal); +} + +ao_poly +ao_scheme_do_less(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_less); +} + +ao_poly +ao_scheme_do_greater(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_greater); +} + +ao_poly +ao_scheme_do_less_equal(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_less_equal); +} + +ao_poly +ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_flush_output(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) +		return AO_SCHEME_NIL; +	ao_scheme_os_flush(); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_led(struct ao_scheme_cons *cons) +{ +	ao_poly led; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) +		return AO_SCHEME_NIL; +	led = ao_scheme_arg(cons, 0); +	ao_scheme_os_led(ao_scheme_poly_int(led)); +	return led; +} + +ao_poly +ao_scheme_do_delay(struct ao_scheme_cons *cons) +{ +	ao_poly delay; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) +		return AO_SCHEME_NIL; +	delay = ao_scheme_arg(cons, 0); +	ao_scheme_os_delay(ao_scheme_poly_int(delay)); +	return delay; +} + +ao_poly +ao_scheme_do_eval(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) +		return AO_SCHEME_NIL; +	ao_scheme_stack->state = eval_sexpr; +	return cons->car; +} + +ao_poly +ao_scheme_do_apply(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX)) +		return AO_SCHEME_NIL; +	ao_scheme_stack->state = eval_apply; +	return ao_scheme_cons_poly(cons); +} + +ao_poly +ao_scheme_do_read(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_read(); +} + +ao_poly +ao_scheme_do_collect(struct ao_scheme_cons *cons) +{ +	int	free; +	(void) cons; +	free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); +	return ao_scheme_int_poly(free); +} + +ao_poly +ao_scheme_do_nullp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) +		return _ao_scheme_bool_true; +	else +		return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_not(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) +		return _ao_scheme_bool_true; +	else +		return _ao_scheme_bool_false; +} + +static ao_poly +ao_scheme_do_typep(int type, struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type) +		return _ao_scheme_bool_true; +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_pairp(struct ao_scheme_cons *cons) +{ +	ao_poly	v; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	v = ao_scheme_arg(cons, 0); +	if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) +		return _ao_scheme_bool_true; +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_integerp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +		return _ao_scheme_bool_true; +	default: +		return _ao_scheme_bool_false; +	} +} + +ao_poly +ao_scheme_do_numberp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +	case AO_SCHEME_FLOAT: +		return _ao_scheme_bool_true; +	default: +		return _ao_scheme_bool_false; +	} +} + +ao_poly +ao_scheme_do_stringp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_STRING, cons); +} + +ao_poly +ao_scheme_do_symbolp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_ATOM, cons); +} + +ao_poly +ao_scheme_do_booleanp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_BOOL, cons); +} + +ao_poly +ao_scheme_do_procedurep(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { +	case AO_SCHEME_BUILTIN: +	case AO_SCHEME_LAMBDA: +		return _ao_scheme_bool_true; +	default: +	return _ao_scheme_bool_false; +	} +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_scheme_do_listp(struct ao_scheme_cons *cons) +{ +	ao_poly	v; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	v = ao_scheme_arg(cons, 0); +	for (;;) { +		if (v == AO_SCHEME_NIL) +			return _ao_scheme_bool_true; +		if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) +			return _ao_scheme_bool_false; +		v = ao_scheme_poly_cons(v)->cdr; +	} +} + +ao_poly +ao_scheme_do_set_car(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); +} + +ao_poly +ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; + +	return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_read_char(struct ao_scheme_cons *cons) +{ +	int	c; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	c = getchar(); +	return ao_scheme_int_poly(c); +} + +ao_poly +ao_scheme_do_write_char(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) +		return AO_SCHEME_NIL; +	putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_exit(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	ao_scheme_exception |= AO_SCHEME_EXIT; +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) +{ +	int	jiffy; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	jiffy = ao_scheme_os_jiffy(); +	return (ao_scheme_int_poly(jiffy)); +} + +ao_poly +ao_scheme_do_current_second(struct ao_scheme_cons *cons) +{ +	int	second; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; +	return (ao_scheme_int_poly(second)); +} + +ao_poly +ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); +} + +#define AO_SCHEME_BUILTIN_FUNCS +#include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt new file mode 100644 index 00000000..cb65e252 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.txt @@ -0,0 +1,68 @@ +f_lambda	eval +f_lambda	read +nlambda		lambda +nlambda		nlambda +nlambda		macro +f_lambda	car +f_lambda	cdr +f_lambda	cons +f_lambda	last +f_lambda	length +nlambda		quote +atom		quasiquote +atom		unquote +atom		unquote_splicing	unquote-splicing +f_lambda	set +macro		setq		set! +f_lambda	def +nlambda		cond +nlambda		begin +nlambda		while +f_lambda	write +f_lambda	display +f_lambda	plus		+ +f_lambda	minus		- +f_lambda	times		* +f_lambda	divide		/ +f_lambda	modulo		modulo	% +f_lambda	remainder +f_lambda	quotient +f_lambda	equal		=	eq?	eqv? +f_lambda	less		< +f_lambda	greater		> +f_lambda	less_equal	<= +f_lambda	greater_equal	>= +f_lambda	list_to_string		list->string +f_lambda	string_to_list		string->list +f_lambda	flush_output		flush-output +f_lambda	delay +f_lambda	led +f_lambda	save +f_lambda	restore +f_lambda	call_cc		call-with-current-continuation	call/cc +f_lambda	collect +f_lambda	nullp		null? +f_lambda	not +f_lambda	listp		list? +f_lambda	pairp		pair? +f_lambda	integerp	integer? exact? exact-integer? +f_lambda	numberp		number? real? +f_lambda	booleanp	boolean? +f_lambda	set_car		set-car! +f_lambda	set_cdr		set-cdr! +f_lambda	symbolp		symbol? +f_lambda	symbol_to_string	symbol->string +f_lambda	string_to_symbol	string->symbol +f_lambda	stringp		string? +f_lambda	procedurep	procedure? +lambda		apply +f_lambda	read_char	read-char +f_lambda	write_char	write-char +f_lambda	exit +f_lambda	current_jiffy	current-jiffy +f_lambda	current_second	current-second +f_lambda	jiffies_per_second	jiffies-per-second +f_lambda	finitep		finite? +f_lambda	infinitep	infinite? +f_lambda	inexactp	inexact? +f_lambda	sqrt diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..03dad956 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,201 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static void cons_mark(void *addr) +{ +	struct ao_scheme_cons	*cons = addr; + +	for (;;) { +		ao_poly cdr = cons->cdr; + +		ao_scheme_poly_mark(cons->car, 1); +		if (!cdr) +			break; +		if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { +			ao_scheme_poly_mark(cdr, 1); +			break; +		} +		cons = ao_scheme_poly_cons(cdr); +		if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) +			break; +	} +} + +static int cons_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_cons); +} + +static void cons_move(void *addr) +{ +	struct ao_scheme_cons	*cons = addr; + +	if (!cons) +		return; + +	for (;;) { +		ao_poly			cdr; +		struct ao_scheme_cons	*c; +		int	ret; + +		MDBG_MOVE("cons_move start %d (%d, %d)\n", +			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); +		(void) ao_scheme_poly_move(&cons->car, 1); +		cdr = cons->cdr; +		if (!cdr) +			break; +		if (ao_scheme_poly_base_type(cdr) != AO_SCHEME_CONS) { +			(void) ao_scheme_poly_move(&cons->cdr, 0); +			break; +		} +		c = ao_scheme_poly_cons(cdr); +		ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); +		if (c != ao_scheme_poly_cons(cons->cdr)) +			cons->cdr = ao_scheme_cons_poly(c); +		MDBG_MOVE("cons_move end %d (%d, %d)\n", +			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); +		if (ret) +			break; +		cons = c; +	} +} + +const struct ao_scheme_type ao_scheme_cons_type = { +	.mark = cons_mark, +	.size = cons_size, +	.move = cons_move, +	.name = "cons", +}; + +struct ao_scheme_cons *ao_scheme_cons_free_list; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr) +{ +	struct ao_scheme_cons	*cons; + +	if (ao_scheme_cons_free_list) { +		cons = ao_scheme_cons_free_list; +		ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); +	} else { +		ao_scheme_poly_stash(0, car); +		ao_scheme_poly_stash(1, cdr); +		cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); +		cdr = ao_scheme_poly_fetch(1); +		car = ao_scheme_poly_fetch(0); +		if (!cons) +			return NULL; +	} +	cons->car = car; +	cons->cdr = cdr; +	return cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons) +{ +	ao_poly	cdr = cons->cdr; +	if (cdr == AO_SCHEME_NIL) +		return NULL; +	if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { +		(void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); +		return NULL; +	} +	return ao_scheme_poly_cons(cdr); +} + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr) +{ +	return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); +} + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons) +{ +#if DBG_FREE_CONS +	ao_scheme_cons_check(cons); +#endif +	while (cons) { +		ao_poly cdr = cons->cdr; +		cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); +		ao_scheme_cons_free_list = cons; +		cons = ao_scheme_poly_cons(cdr); +	} +} + +void +ao_scheme_cons_write(ao_poly c) +{ +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(c); +	ao_poly			cdr; +	int			first = 1; + +	printf("("); +	while (cons) { +		if (!first) +			printf(" "); +		ao_scheme_poly_write(cons->car); +		cdr = cons->cdr; +		if (cdr == c) { +			printf(" ..."); +			break; +		} +		if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { +			cons = ao_scheme_poly_cons(cdr); +			first = 0; +		} else { +			printf(" . "); +			ao_scheme_poly_write(cdr); +			cons = NULL; +		} +	} +	printf(")"); +} + +void +ao_scheme_cons_display(ao_poly c) +{ +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(c); +	ao_poly			cdr; + +	while (cons) { +		ao_scheme_poly_display(cons->car); +		cdr = cons->cdr; +		if (cdr == c) { +			printf("..."); +			break; +		} +		if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) +			cons = ao_scheme_poly_cons(cdr); +		else { +			ao_scheme_poly_display(cdr); +			cons = NULL; +		} +	} +} + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons) +{ +	int	len = 0; +	while (cons) { +		len++; +		cons = ao_scheme_poly_cons(cons->cdr); +	} +	return len; +} diff --git a/src/scheme/ao_scheme_const.lisp b/src/scheme/ao_scheme_const.lisp new file mode 100644 index 00000000..422bdd63 --- /dev/null +++ b/src/scheme/ao_scheme_const.lisp @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard <keithp@keithp.com> +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU +; General Public License for more details. +; +; Lisp code placed in ROM + +					; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) +     (macro (name value) +	    (list +	     def +	     (list quote name) +	     value) +	    ) +     ) + +(begin + (def! append +   (lambda args +	  (def! append-list +	    (lambda (a b) +	      (cond ((null? a) b) +		    (else (cons (car a) (append-list (cdr a) b))) +		    ) +	      ) +	    ) +	     +	  (def! append-lists +	    (lambda (lists) +	      (cond ((null? lists) lists) +		    ((null? (cdr lists)) (car lists)) +		    (else (append-list (car lists) (append-lists (cdr lists)))) +		    ) +	      ) +	    ) +	  (append-lists args) +	  ) +   ) + 'append) + +(append '(a b c) '(d e f) '(g h i)) + +					; boolean operators + +(begin + (def! or +   (macro l +	  (def! _or +	    (lambda (l) +	      (cond ((null? l) #f) +		    ((null? (cdr l)) +		     (car l)) +		    (else +		     (list +		      cond +		      (list +		       (car l)) +		      (list +		       'else +		       (_or (cdr l)) +		       ) +		      ) +		     ) +		    ) +	      ) +	    ) +	  (_or l))) + 'or) + +					; execute to resolve macros + +(or #f #t) + +(begin + (def! and +   (macro l +	  (def! _and +	    (lambda (l) +	      (cond ((null? l) #t) +		    ((null? (cdr l)) +		     (car l)) +		    (else +		     (list +		      cond +		      (list +		       (car l) +		       (_and (cdr l)) +		       ) +		      ) +		     ) +		    ) +	      ) +	    ) +	  (_and l) +	  ) +   ) + 'and) + +					; execute to resolve macros + +(and #t #f) + +(begin + (def! quasiquote +   (macro (x) +	  (def! constant? +					; A constant value is either a pair starting with quote, +					; or anything which is neither a pair nor a symbol + +	    (lambda (exp) +	      (cond ((pair? exp) +		     (eq? (car exp) 'quote) +		     ) +		    (else +		     (not (symbol? exp)) +		     ) +		    ) +	      ) +	    ) +	  (def! combine-skeletons +	    (lambda (left right exp) +	      (cond +	       ((and (constant? left) (constant? right))  +		(cond ((and (eqv? (eval left) (car exp)) +			    (eqv? (eval right) (cdr exp))) +		       (list 'quote exp) +		       ) +		      (else +		       (list 'quote (cons (eval left) (eval right))) +		       ) +		      ) +		) +	       ((null? right) +		(list 'list left) +		) +	       ((and (pair? right) (eq? (car right) 'list)) +		(cons 'list (cons left (cdr right))) +		) +	       (else +		(list 'cons left right) +		) +	       ) +	      ) +	    ) + +	  (def! expand-quasiquote +	    (lambda (exp nesting) +	      (cond + +					; non cons -- constants +					; themselves, others are +					; quoted + +	       ((not (pair? exp))  +		(cond ((constant? exp) +		       exp +		       ) +		      (else +		       (list 'quote exp) +		       ) +		      ) +		) + +					; check for an unquote exp and +					; add the param unquoted + +	       ((and (eq? (car exp) 'unquote) (= (length exp) 2)) +		(cond ((= nesting 0) +		       (car (cdr exp)) +		       ) +		      (else +		       (combine-skeletons ''unquote  +					  (expand-quasiquote (cdr exp) (- nesting 1)) +					  exp)) +		      ) +		) + +					; nested quasi-quote -- +					; construct the right +					; expression + +	       ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) +		(combine-skeletons ''quasiquote  +				   (expand-quasiquote (cdr exp) (+ nesting 1)) +				   exp)) + +					; check for an +					; unquote-splicing member, +					; compute the expansion of the +					; value and append the rest of +					; the quasiquote result to it + +	       ((and (pair? (car exp)) +		     (eq? (car (car exp)) 'unquote-splicing) +		     (= (length (car exp)) 2)) +		(cond ((= nesting 0) +		       (list 'append (car (cdr (car exp))) +			     (expand-quasiquote (cdr exp) nesting)) +		       ) +		      (else +		       (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) +					  (expand-quasiquote (cdr exp) nesting) +					  exp)) +		      ) +		) + +					; for other lists, just glue +					; the expansion of the first +					; element to the expansion of +					; the rest of the list + +	       (else (combine-skeletons (expand-quasiquote (car exp) nesting) +					(expand-quasiquote (cdr exp) nesting) +					exp) +		     ) +	       ) +	      ) +	    ) +	  (def! result (expand-quasiquote x 0)) +	  result +	  ) +   ) + 'quasiquote) + +					; +					; Define a variable without returning the value +					; Useful when defining functions to avoid +					; having lots of output generated. +					; +					; Also accepts the alternate +					; form for defining lambdas of +					; (define (name x y z) sexprs ...)  +					; + +(begin + (def! define +   (macro (first . rest) +					; check for alternate lambda definition form + +	  (cond ((list? first) +		 (set! rest +		       (append +			(list +			 'lambda +			 (cdr first)) +			rest)) +		 (set! first (car first)) +		 ) +		(else +		 (set! rest (car rest)) +		 ) +		) +	  (def! result `(,begin +			 (,def (,quote ,first) ,rest) +			 (,quote ,first)) +	    ) +	  result +	  ) +   ) + 'define + ) + +					; basic list accessors + +(define (caar l) (car (car l))) + +(define (cadr l) (car (cdr l))) + +(define (cdar l) (cdr (car l))) + +(define (caddr l) (car (cdr (cdr l)))) + +					; (if <condition> <if-true>) +					; (if <condition> <if-true> <if-false) + +(define if +  (macro (test . args) +	 (cond ((null? (cdr args)) +		`(cond (,test ,(car args))) +		) +	       (else +		`(cond (,test ,(car args)) +		       (else ,(cadr args))) +		) +	       ) +	 ) +  ) + +(if (> 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + +					; simple math operators + +(define zero? (macro (value) `(eq? ,value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) `(> ,value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) `(< ,value 0))) + +(negative? 12) +(negative? -12) + +(define (abs x) (if (>= x 0) x (- x))) + +(abs 12) +(abs -12) + +(define max (lambda (first . rest) +		   (while (not (null? rest)) +		     (cond ((< first (car rest)) +			    (set! first (car rest))) +			   ) +		     (set! rest (cdr rest)) +		     ) +		   first) +  ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (first . rest) +		   (while (not (null? rest)) +		     (cond ((> first (car rest)) +			    (set! first (car rest))) +			   ) +		     (set! rest (cdr rest)) +		     ) +		   first) +  ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + + +(define (list-tail x k) +  (if (zero? k) +      x +    (list-tail (cdr x (- k 1))) +    ) +  ) + +(define (list-ref x k) +  (car (list-tail x k)) +  ) + +					; define a set of local +					; variables all at once and +					; then evaluate a list of +					; sexprs +					; +					; (let (var-defines) sexprs) +					; +					; where var-defines are either +					; +					; (name value) +					; +					; or +					; +					; (name) +					; +					; e.g. +					; +					; (let ((x 1) (y)) (set! y (+ x 1)) y) + +(define let +  (macro (vars . exprs) +	 (define (make-names vars) +	   (cond ((not (null? vars)) +		  (cons (car (car vars)) +			(make-names (cdr vars)))) +		 (else ()) +		 ) +	   ) + +					; the parameters to the lambda is a list +					; of nils of the right length + +	 (define (make-vals vars) +	   (cond ((not (null? vars)) +		  (cons (cond ((null? (cdr (car vars))) ()) +			      (else +			       (car (cdr (car vars)))) +			      ) +			(make-vals (cdr vars)))) +		 (else ()) +		 ) +	   ) +					; prepend the set operations +					; to the expressions + +					; build the lambda. + +	 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) +	 ) +     ) +		    + +(let ((x 1) (y)) (set! y 2) (+ x y)) + +					; define a set of local +					; variables one at a time and +					; then evaluate a list of +					; sexprs +					; +					; (let* (var-defines) sexprs) +					; +					; where var-defines are either +					; +					; (name value) +					; +					; or +					; +					; (name) +					; +					; e.g. +					; +					; (let* ((x 1) (y)) (set! y (+ x 1)) y) + +(define let* +  (macro (vars . exprs) + +					; +					; make the list of names in the let +					; + +	 (define (make-names vars) +	   (cond ((not (null? vars)) +		  (cons (car (car vars)) +			(make-names (cdr vars)))) +		 (else ()) +		 ) +	   ) + +					; the set of expressions is +					; the list of set expressions +					; pre-pended to the +					; expressions to evaluate + +	 (define (make-exprs vars exprs) +	   (cond ((null? vars) exprs) +		 (else +		  (cons +		   (list set +			 (list quote +			       (car (car vars)) +			       ) +			 (cond ((null? (cdr (car vars))) ()) +			       (else (cadr (car vars)))) +			 ) +		   (make-exprs (cdr vars) exprs) +		   ) +		  ) +		 ) +	   ) + +					; the parameters to the lambda is a list +					; of nils of the right length + +	 (define (make-nils vars) +	   (cond ((null? vars) ()) +		 (else (cons () (make-nils (cdr vars)))) +		 ) +	   ) +					; build the lambda. + +	 `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) +	 ) +     ) + +(let* ((x 1) (y x)) (+ x y)) + +(define when (macro (test . l) `(cond (,test ,@l)))) + +(when #t (write 'when)) + +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) + +(unless #f (write 'unless)) + +(define (reverse list) +  (let ((result ())) +    (while (not (null? list)) +      (set! result (cons (car list) result)) +      (set! list (cdr list)) +      ) +    result) +  ) + +(reverse '(1 2 3)) + +(define (list-tail x k) +  (if (zero? k) +      x +    (list-tail (cdr x) (- k 1)))) + +(list-tail '(1 2 3) 2) + +(define (list-ref x k) (car (list-tail x k))) + +(list-ref '(1 2 3) 2) +     +					; recursive equality + +(define (equal? a b) +  (cond ((eq? a b) #t) +	((and (pair? a) (pair? b)) +	 (and (equal? (car a) (car b)) +	      (equal? (cdr a) (cdr b))) +	 ) +	(else #f) +	) +  ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) + +(define member (lambda (obj list . test?) +		      (cond ((null? list) +			     #f +			     ) +			    (else +			     (if (null? test?) (set! test? equal?) (set! test? (car test?))) +			     (if (test? obj (car list)) +				 list +			       (member obj (cdr list) test?)) +			     ) +			    ) +		      ) +  ) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(define (memq obj list) (member obj list eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(memq '(2) '((1) (2) (3))) + +(define (memv obj list) (member obj list eqv?)) + +(memv 2 '(1 2 3)) + +(memv 4 '(1 2 3)) + +(memv '(2) '((1) (2) (3))) + +(define (_assoc obj list test?) +  (if (null? list) +      #f +    (if (test? obj (caar list)) +	(car list) +      (_assoc obj (cdr list) test?) +      ) +    ) +  ) + +(define (assq obj list) (_assoc obj list eq?)) +(define (assv obj list) (_assoc obj list eqv?)) +(define (assoc obj list) (_assoc obj list equal?)) + +(assq 'a '((a 1) (b 2) (c 3))) +(assv 'b '((a 1) (b 2) (c 3))) +(assoc '(c) '((a 1) (b 2) ((c) 3))) + +(define char? integer?) + +(char? #\q) +(char? "h") + +(define (char-upper-case? c) (<= #\A c #\Z)) + +(char-upper-case? #\a) +(char-upper-case? #\B) +(char-upper-case? #\0) +(char-upper-case? #\space) + +(define (char-lower-case? c) (<= #\a c #\a)) + +(char-lower-case? #\a) +(char-lower-case? #\B) +(char-lower-case? #\0) +(char-lower-case? #\space) + +(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) + +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) + +(define (char-numeric? c) (<= #\0 c #\9)) + +(char-numeric? #\a) +(char-numeric? #\B) +(char-numeric? #\0) +(char-numeric? #\space) + +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) + +(char-whitespace? #\a) +(char-whitespace? #\B) +(char-whitespace? #\0) +(char-whitespace? #\space) + +(define (char->integer c) c) +(define (integer->char c) char-integer) + +(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(char-upcase #\a) +(char-upcase #\B) +(char-upcase #\0) +(char-upcase #\space) + +(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) + +(char-downcase #\a) +(char-downcase #\B) +(char-downcase #\0) +(char-downcase #\space) + +(define string (lambda chars (list->string chars))) + +(display "apply\n") +(apply cons '(a b)) + +(define map +  (lambda (proc . lists) +	 (define (args lists) +	   (cond ((null? lists) ()) +		 (else +		  (cons (caar lists) (args (cdr lists))) +		  ) +		 ) +	   ) +	 (define (next lists) +	   (cond ((null? lists) ()) +		 (else +		  (cons (cdr (car lists)) (next (cdr lists))) +		  ) +		 ) +	   ) +	 (define (domap lists) +	   (cond ((null? (car lists)) ()) +		 (else +		  (cons (apply proc (args lists)) (domap (next lists))) +		  ) +		 ) +	   ) +	 (domap lists) +	 ) +  ) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lambda (proc . lists) +			(apply map proc lists) +			#t)) + +(for-each display '("hello" " " "world" "\n")) + +(define (_string-ml strings) +  (if (null? strings) () +    (cons (string->list (car strings)) (_string-ml (cdr strings))) +    ) +  ) + +(define string-map (lambda (proc . strings) +			  (list->string (apply map proc (_string-ml strings)))))) + +(string-map (lambda (x) (+ 1 x)) "HAL") + +(define string-for-each (lambda (proc . strings) +			       (apply for-each proc (_string-ml strings)))) + +(string-for-each write-char "IBM\n") + +(define (newline) (write-char #\newline)) + +(newline) + +(call-with-current-continuation + (lambda (exit) +   (for-each (lambda (x) +	       (write "test" x) +	       (if (negative? x) +		   (exit x))) +	     '(54 0 37 -3 245 19)) +   #t)) + + +					; `q -> (quote q) +					; `(q) -> (append (quote (q))) +					; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) +					; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) + + + +`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) + + +(define repeat +  (macro (count . rest) +	 (define counter '__count__) +	 (cond ((pair? count) +		(set! counter (car count)) +		(set! count (cadr count)) +		) +	       ) +	 `(let ((,counter 0) +		(__max__ ,count) +		) +	    (while (< ,counter __max__) +	      ,@rest +	      (set! ,counter (+ ,counter 1)) +	      ) +	    ) +	 ) +  ) + +(repeat 2 (write 'hello)) +(repeat (x 3) (write 'goodbye x)) + +(define case +  (macro (test . l) +					; construct the body of the +					; case, dealing with the +					; lambda version ( => lambda) + +	 (define (_unarrow l) +	   (cond ((null? l) l) +		 ((eq? (car l) '=>) `(( ,(cadr l) __key__))) +		 (else l)) +	   ) + +					; Build the case elements, which is +					; simply a list of cond clauses + +	 (define (_case l) + +	   (cond ((null? l) ()) + +					; else case + +		 ((eq? (caar l) 'else) +		  `((else ,@(_unarrow (cdr (car l)))))) + +					; regular case +		  +		 (else +		  (cons +		   `((eqv? ,(caar l) __key__) +		     ,@(_unarrow (cdr (car l)))) +		   (_case (cdr l))) +		  ) +		 ) +	   ) + +					; now construct the overall +					; expression, using a lambda +					; to hold the computed value +					; of the test expression + +	 `((lambda (__key__) +	     (cond ,@(_case l))) ,test) +	 ) +  ) + +(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) + +;(define number->string (lambda (arg . opt) +;			      (let ((base (if (null? opt) 10 (car opt))) +					; +; +				 diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c new file mode 100644 index 00000000..d580a2c0 --- /dev/null +++ b/src/scheme/ao_scheme_error.c @@ -0,0 +1,139 @@ +/* + * 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_error_poly(char *name, ao_poly poly, ao_poly last) +{ +	int first = 1; +	printf("\t\t%s(", name); +	if (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) { +		if (poly) { +			while (poly) { +				struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly); +				if (!first) +					printf("\t\t         "); +				else +					first = 0; +				ao_scheme_poly_write(cons->car); +				printf("\n"); +				if (poly == last) +					break; +				poly = cons->cdr; +			} +			printf("\t\t         )\n"); +		} else +			printf(")\n"); +	} else { +		ao_scheme_poly_write(poly); +		printf("\n"); +	} +} + +static void tabs(int indent) +{ +	while (indent--) +		printf("\t"); +} + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame) +{ +	int			f; + +	tabs(indent); +	printf ("%s{", name); +	if (frame) { +		struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +		if (frame->type & AO_SCHEME_FRAME_PRINT) +			printf("recurse..."); +		else { +			frame->type |= AO_SCHEME_FRAME_PRINT; +			for (f = 0; f < frame->num; f++) { +				if (f != 0) { +					tabs(indent); +					printf("         "); +				} +				ao_scheme_poly_write(vals->vals[f].atom); +				printf(" = "); +				ao_scheme_poly_write(vals->vals[f].val); +				printf("\n"); +			} +			if (frame->prev) +				ao_scheme_error_frame(indent + 1, "prev:   ", ao_scheme_poly_frame(frame->prev)); +			frame->type &= ~AO_SCHEME_FRAME_PRINT; +		} +		tabs(indent); +		printf("        }\n"); +	} else +		printf ("}\n"); +} + +void +ao_scheme_vprintf(char *format, va_list args) +{ +	char c; + +	while ((c = *format++) != '\0') { +		if (c == '%') { +			switch (c = *format++) { +			case 'v': +				ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int)); +				break; +			case 'p': +				printf("%p", va_arg(args, void *)); +				break; +			case 'd': +				printf("%d", va_arg(args, int)); +				break; +			case 's': +				printf("%s", va_arg(args, char *)); +				break; +			default: +				putchar(c); +				break; +			} +		} else +			putchar(c); +	} +} + +void +ao_scheme_printf(char *format, ...) +{ +	va_list args; +	va_start(args, format); +	ao_scheme_vprintf(format, args); +	va_end(args); +} + +ao_poly +ao_scheme_error(int error, char *format, ...) +{ +	va_list	args; + +	ao_scheme_exception |= error; +	va_start(args, format); +	ao_scheme_vprintf(format, args); +	putchar('\n'); +	va_end(args); +	ao_scheme_printf("Value:  %v\n", ao_scheme_v); +	ao_scheme_printf("Frame:  %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); +	printf("Stack:\n"); +	ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)); +	ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); +	return AO_SCHEME_NIL; +} diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c new file mode 100644 index 00000000..9b3cf63e --- /dev/null +++ b/src/scheme/ao_scheme_eval.c @@ -0,0 +1,578 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <assert.h> + +struct ao_scheme_stack		*ao_scheme_stack; +ao_poly				ao_scheme_v; +uint8_t				ao_scheme_skip_cons_free; + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *c) +{ +	ao_scheme_stack->state = eval_cond; +	ao_scheme_stack->sexprs = ao_scheme_cons_poly(c); +	return AO_SCHEME_NIL; +} + +static int +func_type(ao_poly func) +{ +	if (func == AO_SCHEME_NIL) +		return ao_scheme_error(AO_SCHEME_INVALID, "func is nil"); +	switch (ao_scheme_poly_type(func)) { +	case AO_SCHEME_BUILTIN: +		return ao_scheme_poly_builtin(func)->args & AO_SCHEME_FUNC_MASK; +	case AO_SCHEME_LAMBDA: +		return ao_scheme_poly_lambda(func)->args; +	case AO_SCHEME_STACK: +		return AO_SCHEME_FUNC_LAMBDA; +	default: +		ao_scheme_error(AO_SCHEME_INVALID, "not a func"); +		return -1; +	} +} + +/* + * Flattened eval to avoid stack issues + */ + +/* + * Evaluate an s-expression + * + * For a list, evaluate all of the elements and + * then execute the resulting function call. + * + * Each element of the list is evaluated in + * a clean stack context. + * + * The current stack state is set to 'formal' so that + * when the evaluation is complete, the value + * will get appended to the values list. + * + * For other types, compute the value directly. + */ + +static int +ao_scheme_eval_sexpr(void) +{ +	DBGI("sexpr: %v\n", ao_scheme_v); +	switch (ao_scheme_poly_type(ao_scheme_v)) { +	case AO_SCHEME_CONS: +		if (ao_scheme_v == AO_SCHEME_NIL) { +			if (!ao_scheme_stack->values) { +				/* +				 * empty list evaluates to empty list +				 */ +				ao_scheme_v = AO_SCHEME_NIL; +				ao_scheme_stack->state = eval_val; +			} else { +				/* +				 * done with arguments, go execute it +				 */ +				ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; +				ao_scheme_stack->state = eval_exec; +			} +		} else { +			if (!ao_scheme_stack->values) +				ao_scheme_stack->list = ao_scheme_v; +			/* +			 * Evaluate another argument and then switch +			 * to 'formal' to add the value to the values +			 * list +			 */ +			ao_scheme_stack->sexprs = ao_scheme_v; +			ao_scheme_stack->state = eval_formal; +			if (!ao_scheme_stack_push()) +				return 0; +			/* +			 * push will reset the state to 'sexpr', which +			 * will evaluate the expression +			 */ +			ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; +		} +		break; +	case AO_SCHEME_ATOM: +		DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); +		/* fall through */ +	case AO_SCHEME_BOOL: +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +	case AO_SCHEME_FLOAT: +	case AO_SCHEME_STRING: +	case AO_SCHEME_BUILTIN: +	case AO_SCHEME_LAMBDA: +		ao_scheme_stack->state = eval_val; +		break; +	} +	DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG("\n"); +	return 1; +} + +/* + * A value has been computed. + * + * If the value was computed from a macro, + * then we want to reset the current context + * to evaluate the macro result again. + * + * If not a macro, then pop the stack. + * If the stack is empty, we're done. + * Otherwise, the stack will contain + * the next state. + */ + +static int +ao_scheme_eval_val(void) +{ +	DBGI("val: "); DBG_POLY(ao_scheme_v); DBG("\n"); +	/* +	 * Value computed, pop the stack +	 * to figure out what to do with the value +	 */ +	ao_scheme_stack_pop(); +	DBGI("..state %d\n", ao_scheme_stack ? ao_scheme_stack->state : -1); +	return 1; +} + +/* + * A formal has been computed. + * + * If this is the first formal, then check to see if we've got a + * lamda, macro or nlambda. + * + * For lambda, go compute another formal.  This will terminate + * when the sexpr state sees nil. + * + * For macro/nlambda, we're done, so move the sexprs into the values + * and go execute it. + * + * Macros have an additional step of saving a stack frame holding the + * macro value execution context, which then gets the result of the + * macro to run + */ + +static int +ao_scheme_eval_formal(void) +{ +	ao_poly			formal; +	struct ao_scheme_stack	*prev; + +	DBGI("formal: "); DBG_POLY(ao_scheme_v); DBG("\n"); + +	/* Check what kind of function we've got */ +	if (!ao_scheme_stack->values) { +		switch (func_type(ao_scheme_v)) { +		case AO_SCHEME_FUNC_LAMBDA: +			DBGI(".. lambda\n"); +			break; +		case AO_SCHEME_FUNC_MACRO: +			/* Evaluate the result once more */ +			ao_scheme_stack->state = eval_macro; +			if (!ao_scheme_stack_push()) +				return 0; + +			/* After the function returns, take that +			 * value and re-evaluate it +			 */ +			prev = ao_scheme_poly_stack(ao_scheme_stack->prev); +			ao_scheme_stack->sexprs = prev->sexprs; + +			DBGI(".. start macro\n"); +			DBGI("\t.. sexprs       "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +			DBGI("\t.. values       "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); +			DBG_FRAMES(); + +			/* fall through ... */ +		case AO_SCHEME_FUNC_NLAMBDA: +			DBGI(".. nlambda or macro\n"); + +			/* use the raw sexprs as values */ +			ao_scheme_stack->values = ao_scheme_stack->sexprs; +			ao_scheme_stack->values_tail = AO_SCHEME_NIL; +			ao_scheme_stack->state = eval_exec; + +			/* ready to execute now */ +			return 1; +		case -1: +			return 0; +		} +	} + +	/* Append formal to list of values */ +	formal = ao_scheme__cons(ao_scheme_v, AO_SCHEME_NIL); +	if (!formal) +		return 0; + +	if (ao_scheme_stack->values_tail) +		ao_scheme_poly_cons(ao_scheme_stack->values_tail)->cdr = formal; +	else +		ao_scheme_stack->values = formal; +	ao_scheme_stack->values_tail = formal; + +	DBGI(".. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + +	/* +	 * Step to the next argument, if this is last, then +	 * 'sexpr' will end up switching to 'exec' +	 */ +	ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + +	ao_scheme_stack->state = eval_sexpr; + +	DBGI(".. "); DBG_POLY(ao_scheme_v); DBG("\n"); +	return 1; +} + +/* + * Start executing a function call + * + * Most builtins are easy, just call the function. + * 'cond' is magic; it sticks the list of clauses + * in 'sexprs' and switches to 'cond' state. That + * bit of magic is done in ao_scheme_set_cond. + * + * Lambdas build a new frame to hold the locals and + * then re-use the current stack context to evaluate + * the s-expression from the lambda. + */ + +static int +ao_scheme_eval_exec(void) +{ +	ao_poly v; +	struct ao_scheme_builtin	*builtin; + +	DBGI("exec: "); DBG_POLY(ao_scheme_v); DBG(" values "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); +	ao_scheme_stack->sexprs = AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_v)) { +	case AO_SCHEME_BUILTIN: +		ao_scheme_stack->state = eval_val; +		builtin = ao_scheme_poly_builtin(ao_scheme_v); +		v = ao_scheme_func(builtin) ( +			ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr)); +		DBG_DO(if (!ao_scheme_exception && ao_scheme_poly_builtin(ao_scheme_v)->func == builtin_set) { +				struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); +				ao_poly atom = ao_scheme_arg(cons, 1); +				ao_poly val = ao_scheme_arg(cons, 2); +				DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); +			}); +		builtin = ao_scheme_poly_builtin(ao_scheme_v); +		if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack) && !ao_scheme_skip_cons_free) { +			struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); +			ao_scheme_stack->values = AO_SCHEME_NIL; +			ao_scheme_cons_free(cons); +		} + +		ao_scheme_v = v; +		ao_scheme_stack->values = AO_SCHEME_NIL; +		ao_scheme_stack->values_tail = AO_SCHEME_NIL; +		DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		break; +	case AO_SCHEME_LAMBDA: +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		ao_scheme_stack->state = eval_begin; +		v = ao_scheme_lambda_eval(); +		ao_scheme_stack->sexprs = v; +		ao_scheme_stack->values = AO_SCHEME_NIL; +		ao_scheme_stack->values_tail = AO_SCHEME_NIL; +		DBGI(".. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		break; +	case AO_SCHEME_STACK: +		DBGI(".. stack "); DBG_POLY(ao_scheme_v); DBG("\n"); +		ao_scheme_v = ao_scheme_stack_eval(); +		DBGI(".. value "); DBG_POLY(ao_scheme_v); DBG("\n"); +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		break; +	} +	ao_scheme_skip_cons_free = 0; +	return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_scheme_eval_apply(void) +{ +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_v); +	struct ao_scheme_cons	*cdr, *prev; + +	/* Glue the arguments into the right shape. That's all but the last +	 * concatenated onto the last +	 */ +	cdr = cons; +	for (;;) { +		prev = cdr; +		cdr = ao_scheme_poly_cons(prev->cdr); +		if (cdr->cdr == AO_SCHEME_NIL) +			break; +	} +	DBGI("before mangling: "); DBG_POLY(ao_scheme_v); DBG("\n"); +	prev->cdr = cdr->car; +	ao_scheme_stack->values = ao_scheme_v; +	ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; +	DBGI("apply: "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); +	ao_scheme_stack->state = eval_exec; +	ao_scheme_skip_cons_free = 1; +	return 1; +} + +/* + * Start evaluating the next cond clause + * + * If the list of clauses is empty, then + * the result of the cond is nil. + * + * Otherwise, set the current stack state to 'cond_test' and create a + * new stack context to evaluate the test s-expression. Once that's + * complete, we'll land in 'cond_test' to finish the clause. + */ +static int +ao_scheme_eval_cond(void) +{ +	DBGI("cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); +	if (!ao_scheme_stack->sexprs) { +		ao_scheme_v = _ao_scheme_bool_false; +		ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; +		if (!ao_scheme_v || ao_scheme_poly_type(ao_scheme_v) != AO_SCHEME_CONS) { +			ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); +			return 0; +		} +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; +		if (ao_scheme_v == _ao_scheme_atom_else) +			ao_scheme_v = _ao_scheme_bool_true; +		ao_scheme_stack->state = eval_cond_test; +		if (!ao_scheme_stack_push()) +			return 0; +	} +	return 1; +} + +/* + * Finish a cond clause. + * + * Check the value from the test expression, if + * non-nil, then set up to evaluate the value expression. + * + * Otherwise, step to the next clause and go back to the 'cond' + * state + */ +static int +ao_scheme_eval_cond_test(void) +{ +	DBGI("cond_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); +	if (ao_scheme_v != _ao_scheme_bool_false) { +		struct ao_scheme_cons *car = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car); +		ao_poly c = car->cdr; + +		if (c) { +			ao_scheme_stack->state = eval_begin; +			ao_scheme_stack->sexprs = c; +		} else +			ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; +		DBGI("next cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +		ao_scheme_stack->state = eval_cond; +	} +	return 1; +} + +/* + * Evaluate a list of sexprs, returning the value from the last one. + * + * ao_scheme_begin records the list in stack->sexprs, so we just need to + * walk that list. Set ao_scheme_v to the car of the list and jump to + * eval_sexpr. When that's done, it will land in eval_val. For all but + * the last, leave a stack frame with eval_begin set so that we come + * back here. For the last, don't add a stack frame so that we can + * just continue on. + */ +static int +ao_scheme_eval_begin(void) +{ +	DBGI("begin: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + +	if (!ao_scheme_stack->sexprs) { +		ao_scheme_v = AO_SCHEME_NIL; +		ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; +		ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + +		/* If there are more sexprs to do, then come back here, otherwise +		 * return the value of the last one by just landing in eval_sexpr +		 */ +		if (ao_scheme_stack->sexprs) { +			ao_scheme_stack->state = eval_begin; +			if (!ao_scheme_stack_push()) +				return 0; +		} +		ao_scheme_stack->state = eval_sexpr; +	} +	return 1; +} + +/* + * Conditionally execute a list of sexprs while the first is true + */ +static int +ao_scheme_eval_while(void) +{ +	DBGI("while: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + +	ao_scheme_stack->values = ao_scheme_v; +	if (!ao_scheme_stack->sexprs) { +		ao_scheme_v = AO_SCHEME_NIL; +		ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; +		ao_scheme_stack->state = eval_while_test; +		if (!ao_scheme_stack_push()) +			return 0; +	} +	return 1; +} + +/* + * Check the while condition, terminate the loop if nil. Otherwise keep going + */ +static int +ao_scheme_eval_while_test(void) +{ +	DBGI("while_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + +	if (ao_scheme_v != _ao_scheme_bool_false) { +		ao_scheme_stack->values = ao_scheme_v; +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; +		ao_scheme_stack->state = eval_while; +		if (!ao_scheme_stack_push()) +			return 0; +		ao_scheme_stack->state = eval_begin; +		ao_scheme_stack->sexprs = ao_scheme_v; +	} +	else +	{ +		ao_scheme_stack->state = eval_val; +		ao_scheme_v = ao_scheme_stack->values; +	} +	return 1; +} + +/* + * Replace the original sexpr with the macro expansion, then + * execute that + */ +static int +ao_scheme_eval_macro(void) +{ +	DBGI("macro: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + +	if (ao_scheme_v == AO_SCHEME_NIL) +		ao_scheme_abort(); +	if (ao_scheme_poly_type(ao_scheme_v) == AO_SCHEME_CONS) { +		*ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); +		ao_scheme_v = ao_scheme_stack->sexprs; +		DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); +	} +	ao_scheme_stack->sexprs = AO_SCHEME_NIL; +	ao_scheme_stack->state = eval_sexpr; +	return 1; +} + +static int (*const evals[])(void) = { +	[eval_sexpr] = ao_scheme_eval_sexpr, +	[eval_val] = ao_scheme_eval_val, +	[eval_formal] = ao_scheme_eval_formal, +	[eval_exec] = ao_scheme_eval_exec, +	[eval_apply] = ao_scheme_eval_apply, +	[eval_cond] = ao_scheme_eval_cond, +	[eval_cond_test] = ao_scheme_eval_cond_test, +	[eval_begin] = ao_scheme_eval_begin, +	[eval_while] = ao_scheme_eval_while, +	[eval_while_test] = ao_scheme_eval_while_test, +	[eval_macro] = ao_scheme_eval_macro, +}; + +const char * const ao_scheme_state_names[] = { +	[eval_sexpr] = "sexpr", +	[eval_val] = "val", +	[eval_formal] = "formal", +	[eval_exec] = "exec", +	[eval_apply] = "apply", +	[eval_cond] = "cond", +	[eval_cond_test] = "cond_test", +	[eval_begin] = "begin", +	[eval_while] = "while", +	[eval_while_test] = "while_test", +	[eval_macro] = "macro", +}; + +/* + * Called at restore time to reset all execution state + */ + +void +ao_scheme_eval_clear_globals(void) +{ +	ao_scheme_stack = NULL; +	ao_scheme_frame_current = NULL; +	ao_scheme_v = AO_SCHEME_NIL; +} + +int +ao_scheme_eval_restart(void) +{ +	return ao_scheme_stack_push(); +} + +ao_poly +ao_scheme_eval(ao_poly _v) +{ +	ao_scheme_v = _v; + +	ao_scheme_frame_init(); + +	if (!ao_scheme_stack_push()) +		return AO_SCHEME_NIL; + +	while (ao_scheme_stack) { +		if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) { +			ao_scheme_stack_clear(); +			return AO_SCHEME_NIL; +		} +	} +	DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); +	ao_scheme_frame_current = NULL; +	return ao_scheme_v; +} diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c new file mode 100644 index 00000000..541f0264 --- /dev/null +++ b/src/scheme/ao_scheme_float.c @@ -0,0 +1,148 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <math.h> + +static void float_mark(void *addr) +{ +	(void) addr; +} + +static int float_size(void *addr) +{ +	if (!addr) +		return 0; +	return sizeof (struct ao_scheme_float); +} + +static void float_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_float_type = { +	.mark = float_mark, +	.size = float_size, +	.move = float_move, +	.name = "float", +}; + +void +ao_scheme_float_write(ao_poly p) +{ +	struct ao_scheme_float *f = ao_scheme_poly_float(p); +	float	v = f->value; + +	if (isnanf(v)) +		printf("+nan.0"); +	else if (isinff(v)) { +		if (v < 0) +			printf("-"); +		else +			printf("+"); +		printf("inf.0"); +	} else +		printf ("%g", f->value); +} + +float +ao_scheme_poly_number(ao_poly p) +{ +	switch (ao_scheme_poly_base_type(p)) { +	case AO_SCHEME_INT: +		return ao_scheme_poly_int(p); +	case AO_SCHEME_OTHER: +		switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { +		case AO_SCHEME_BIGINT: +			return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); +		case AO_SCHEME_FLOAT: +			return ao_scheme_poly_float(p)->value; +		} +	} +	return NAN; +} + +ao_poly +ao_scheme_float_get(float value) +{ +	struct ao_scheme_float	*f; + +	f = ao_scheme_alloc(sizeof (struct ao_scheme_float)); +	f->type = AO_SCHEME_FLOAT; +	f->value = value; +	return ao_scheme_float_poly(f); +} + +ao_poly +ao_scheme_do_inexactp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT) +		return _ao_scheme_bool_true; +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_finitep(struct ao_scheme_cons *cons) +{ +	ao_poly	value; +	float	f; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	value = ao_scheme_arg(cons, 0); +	switch (ao_scheme_poly_type(value)) { +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +		return _ao_scheme_bool_true; +	case AO_SCHEME_FLOAT: +		f = ao_scheme_poly_float(value)->value; +		if (!isnan(f) && !isinf(f)) +			return _ao_scheme_bool_true; +	} +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_infinitep(struct ao_scheme_cons *cons) +{ +	ao_poly	value; +	float	f; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	value = ao_scheme_arg(cons, 0); +	switch (ao_scheme_poly_type(value)) { +	case AO_SCHEME_FLOAT: +		f = ao_scheme_poly_float(value)->value; +		if (isinf(f)) +			return _ao_scheme_bool_true; +	} +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_sqrt(struct ao_scheme_cons *cons) +{ +	ao_poly	value; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1)) +		return AO_SCHEME_NIL; +	value = ao_scheme_arg(cons, 0); +	if (!ao_scheme_number_typep(ao_scheme_poly_type(value))) +		return ao_scheme_error(AO_SCHEME_INVALID, "%s: non-numeric", ao_scheme_poly_atom(_ao_scheme_atom_sqrt)->name); +	return ao_scheme_float_get(sqrtf(ao_scheme_poly_number(value))); +} diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c new file mode 100644 index 00000000..e5d481e7 --- /dev/null +++ b/src/scheme/ao_scheme_frame.c @@ -0,0 +1,330 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static inline int +frame_vals_num_size(int num) +{ +	return sizeof (struct ao_scheme_frame_vals) + num * sizeof (struct ao_scheme_val); +} + +static int +frame_vals_size(void *addr) +{ +	struct ao_scheme_frame_vals	*vals = addr; +	return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ +	struct ao_scheme_frame_vals	*vals = addr; +	int				f; + +	for (f = 0; f < vals->size; f++) { +		struct ao_scheme_val	*v = &vals->vals[f]; + +		ao_scheme_poly_mark(v->val, 0); +		MDBG_MOVE("frame mark atom %s %d val %d at %d    ", +			  ao_scheme_poly_atom(v->atom)->name, +			  MDBG_OFFSET(ao_scheme_ref(v->atom)), +			  MDBG_OFFSET(ao_scheme_ref(v->val)), f); +		MDBG_DO(ao_scheme_poly_write(v->val)); +		MDBG_DO(printf("\n")); +	} +} + +static void +frame_vals_move(void *addr) +{ +	struct ao_scheme_frame_vals	*vals = addr; +	int				f; + +	for (f = 0; f < vals->size; f++) { +		struct ao_scheme_val	*v = &vals->vals[f]; + +		ao_scheme_poly_move(&v->atom, 0); +		ao_scheme_poly_move(&v->val, 0); +		MDBG_MOVE("frame move atom %s %d val %d at %d\n", +			  ao_scheme_poly_atom(v->atom)->name, +			  MDBG_OFFSET(ao_scheme_ref(v->atom)), +			  MDBG_OFFSET(ao_scheme_ref(v->val)), f); +	} +} + +const struct ao_scheme_type ao_scheme_frame_vals_type = { +	.mark = frame_vals_mark, +	.size = frame_vals_size, +	.move = frame_vals_move, +	.name = "frame_vals" +}; + +static int +frame_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_frame); +} + +static void +frame_mark(void *addr) +{ +	struct ao_scheme_frame	*frame = addr; + +	for (;;) { +		MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); +		if (!AO_SCHEME_IS_POOL(frame)) +			break; +		ao_scheme_poly_mark(frame->vals, 0); +		frame = ao_scheme_poly_frame(frame->prev); +		MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); +		if (!frame) +			break; +		if (ao_scheme_mark_memory(&ao_scheme_frame_type, frame)) +			break; +	} +} + +static void +frame_move(void *addr) +{ +	struct ao_scheme_frame	*frame = addr; + +	for (;;) { +		struct ao_scheme_frame	*prev; +		int			ret; + +		MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); +		if (!AO_SCHEME_IS_POOL(frame)) +			break; +		ao_scheme_poly_move(&frame->vals, 0); +		prev = ao_scheme_poly_frame(frame->prev); +		if (!prev) +			break; +		ret = ao_scheme_move_memory(&ao_scheme_frame_type, (void **) &prev); +		if (prev != ao_scheme_poly_frame(frame->prev)) { +			MDBG_MOVE("frame prev moved from %d to %d\n", +				  MDBG_OFFSET(ao_scheme_poly_frame(frame->prev)), +				  MDBG_OFFSET(prev)); +			frame->prev = ao_scheme_frame_poly(prev); +		} +		if (ret) +			break; +		frame = prev; +	} +} + +const struct ao_scheme_type ao_scheme_frame_type = { +	.mark = frame_mark, +	.size = frame_size, +	.move = frame_move, +	.name = "frame", +}; + +void +ao_scheme_frame_write(ao_poly p) +{ +	struct ao_scheme_frame		*frame = ao_scheme_poly_frame(p); +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int				f; + +	printf ("{"); +	if (frame) { +		if (frame->type & AO_SCHEME_FRAME_PRINT) +			printf("recurse..."); +		else { +			frame->type |= AO_SCHEME_FRAME_PRINT; +			for (f = 0; f < frame->num; f++) { +				if (f != 0) +					printf(", "); +				ao_scheme_poly_write(vals->vals[f].atom); +				printf(" = "); +				ao_scheme_poly_write(vals->vals[f].val); +			} +			if (frame->prev) +				ao_scheme_poly_write(frame->prev); +			frame->type &= ~AO_SCHEME_FRAME_PRINT; +		} +	} +	printf("}"); +} + +static int +ao_scheme_frame_find(struct ao_scheme_frame *frame, int top, ao_poly atom) +{ +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int 				l = 0; +	int 				r = top - 1; + +	while (l <= r) { +		int m = (l + r) >> 1; +		if (vals->vals[m].atom < atom) +			l = m + 1; +		else +			r = m - 1; +	} +	return l; +} + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom) +{ +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int				l = ao_scheme_frame_find(frame, frame->num, atom); + +	if (l >= frame->num) +		return NULL; + +	if (vals->vals[l].atom != atom) +		return NULL; +	return &vals->vals[l].val; +} + +struct ao_scheme_frame	*ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +static struct ao_scheme_frame_vals * +ao_scheme_frame_vals_new(int num) +{ +	struct ao_scheme_frame_vals	*vals; + +	vals = ao_scheme_alloc(frame_vals_num_size(num)); +	if (!vals) +		return NULL; +	vals->type = AO_SCHEME_FRAME_VALS; +	vals->size = num; +	memset(vals->vals, '\0', num * sizeof (struct ao_scheme_val)); +	return vals; +} + +struct ao_scheme_frame * +ao_scheme_frame_new(int num) +{ +	struct ao_scheme_frame		*frame; +	struct ao_scheme_frame_vals	*vals; + +	if (num < AO_SCHEME_FRAME_FREE && (frame = ao_scheme_frame_free_list[num])) { +		ao_scheme_frame_free_list[num] = ao_scheme_poly_frame(frame->prev); +		vals = ao_scheme_poly_frame_vals(frame->vals); +	} else { +		frame = ao_scheme_alloc(sizeof (struct ao_scheme_frame)); +		if (!frame) +			return NULL; +		frame->type = AO_SCHEME_FRAME; +		frame->num = 0; +		frame->prev = AO_SCHEME_NIL; +		frame->vals = AO_SCHEME_NIL; +		ao_scheme_frame_stash(0, frame); +		vals = ao_scheme_frame_vals_new(num); +		frame = ao_scheme_frame_fetch(0); +		if (!vals) +			return NULL; +		frame->vals = ao_scheme_frame_vals_poly(vals); +		frame->num = num; +	} +	frame->prev = AO_SCHEME_NIL; +	return frame; +} + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame) +{ +	if (!frame) +		return AO_SCHEME_NIL; +	frame->type |= AO_SCHEME_FRAME_MARK; +	return ao_scheme_frame_poly(frame); +} + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame) +{ +	if (frame && !ao_scheme_frame_marked(frame)) { +		int	num = frame->num; +		if (num < AO_SCHEME_FRAME_FREE) { +			struct ao_scheme_frame_vals	*vals; + +			vals = ao_scheme_poly_frame_vals(frame->vals); +			memset(vals->vals, '\0', vals->size * sizeof (struct ao_scheme_val)); +			frame->prev = ao_scheme_frame_poly(ao_scheme_frame_free_list[num]); +			ao_scheme_frame_free_list[num] = frame; +		} +	} +} + +static struct ao_scheme_frame * +ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) +{ +	struct ao_scheme_frame_vals	*vals; +	struct ao_scheme_frame_vals	*new_vals; +	int				copy; + +	if (new_num == frame->num) +		return frame; +	ao_scheme_frame_stash(0, frame); +	new_vals = ao_scheme_frame_vals_new(new_num); +	frame = ao_scheme_frame_fetch(0); +	if (!new_vals) +		return NULL; +	vals = ao_scheme_poly_frame_vals(frame->vals); +	copy = new_num; +	if (copy > frame->num) +		copy = frame->num; +	memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_scheme_val)); +	frame->vals = ao_scheme_frame_vals_poly(new_vals); +	frame->num = new_num; +	return frame; +} + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val) +{ +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int 				l = ao_scheme_frame_find(frame, num, atom); + +	memmove(&vals->vals[l+1], +		&vals->vals[l], +		(num - l) * sizeof (struct ao_scheme_val)); +	vals->vals[l].atom = atom; +	vals->vals[l].val = val; +} + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) +{ +	ao_poly *ref = frame ? ao_scheme_frame_ref(frame, atom) : NULL; + +	if (!ref) { +		int f = frame->num; +		ao_scheme_poly_stash(0, atom); +		ao_scheme_poly_stash(1, val); +		frame = ao_scheme_frame_realloc(frame, f + 1); +		val = ao_scheme_poly_fetch(1); +		atom = ao_scheme_poly_fetch(0); +		if (!frame) +			return AO_SCHEME_NIL; +		ao_scheme_frame_bind(frame, frame->num - 1, atom, val); +	} else +		*ref = val; +	return val; +} + +struct ao_scheme_frame	*ao_scheme_frame_global; +struct ao_scheme_frame	*ao_scheme_frame_current; + +void +ao_scheme_frame_init(void) +{ +	if (!ao_scheme_frame_global) +		ao_scheme_frame_global = ao_scheme_frame_new(0); +} diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c new file mode 100644 index 00000000..350a5d35 --- /dev/null +++ b/src/scheme/ao_scheme_int.c @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +void +ao_scheme_int_write(ao_poly p) +{ +	int i = ao_scheme_poly_int(p); +	printf("%d", i); +} + +int32_t +ao_scheme_poly_integer(ao_poly p) +{ +	switch (ao_scheme_poly_base_type(p)) { +	case AO_SCHEME_INT: +		return ao_scheme_poly_int(p); +	case AO_SCHEME_OTHER: +		if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) +			return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); +	} +	return AO_SCHEME_NOT_INTEGER; +} + +ao_poly +ao_scheme_integer_poly(int32_t p) +{ +	struct ao_scheme_bigint	*bi; + +	if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) +		return ao_scheme_int_poly(p); +	bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); +	bi->value = ao_scheme_int_bigint(p); +	return ao_scheme_bigint_poly(bi); +} + +static void bigint_mark(void *addr) +{ +	(void) addr; +} + +static int bigint_size(void *addr) +{ +	if (!addr) +		return 0; +	return sizeof (struct ao_scheme_bigint); +} + +static void bigint_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_bigint_type = { +	.mark = bigint_mark, +	.size = bigint_size, +	.move = bigint_move, +	.name = "bigint", +}; + +void +ao_scheme_bigint_write(ao_poly p) +{ +	struct ao_scheme_bigint	*bi = ao_scheme_poly_bigint(p); + +	printf("%d", ao_scheme_bigint_int(bi->value)); +} diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c new file mode 100644 index 00000000..ec6f858c --- /dev/null +++ b/src/scheme/ao_scheme_lambda.c @@ -0,0 +1,208 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +int +lambda_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_lambda); +} + +void +lambda_mark(void *addr) +{ +	struct ao_scheme_lambda	*lambda = addr; + +	ao_scheme_poly_mark(lambda->code, 0); +	ao_scheme_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ +	struct ao_scheme_lambda	*lambda = addr; + +	ao_scheme_poly_move(&lambda->code, 0); +	ao_scheme_poly_move(&lambda->frame, 0); +} + +const struct ao_scheme_type ao_scheme_lambda_type = { +	.size = lambda_size, +	.mark = lambda_mark, +	.move = lambda_move, +	.name = "lambda", +}; + +void +ao_scheme_lambda_write(ao_poly poly) +{ +	struct ao_scheme_lambda	*lambda = ao_scheme_poly_lambda(poly); +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(lambda->code); + +	printf("("); +	printf("%s", ao_scheme_args_name(lambda->args)); +	while (cons) { +		printf(" "); +		ao_scheme_poly_write(cons->car); +		cons = ao_scheme_poly_cons(cons->cdr); +	} +	printf(")"); +} + +ao_poly +ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) +{ +	struct ao_scheme_lambda	*lambda; +	ao_poly			formal; +	struct ao_scheme_cons	*cons; + +	formal = ao_scheme_arg(code, 0); +	while (formal != AO_SCHEME_NIL) { +		switch (ao_scheme_poly_type(formal)) { +		case AO_SCHEME_CONS: +			cons = ao_scheme_poly_cons(formal); +			if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM) +				return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car); +			formal = cons->cdr; +			break; +		case AO_SCHEME_ATOM: +			formal = AO_SCHEME_NIL; +			break; +		default: +			return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal); +		} +	} + +	ao_scheme_cons_stash(0, code); +	lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); +	code = ao_scheme_cons_fetch(0); +	if (!lambda) +		return AO_SCHEME_NIL; + +	lambda->type = AO_SCHEME_LAMBDA; +	lambda->args = args; +	lambda->code = ao_scheme_cons_poly(code); +	lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current); +	DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); +	DBG_STACK(); +	return ao_scheme_lambda_poly(lambda); +} + +ao_poly +ao_scheme_do_lambda(struct ao_scheme_cons *cons) +{ +	return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA); +} + +ao_poly +ao_scheme_do_nlambda(struct ao_scheme_cons *cons) +{ +	return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA); +} + +ao_poly +ao_scheme_do_macro(struct ao_scheme_cons *cons) +{ +	return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO); +} + +ao_poly +ao_scheme_lambda_eval(void) +{ +	struct ao_scheme_lambda	*lambda = ao_scheme_poly_lambda(ao_scheme_v); +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_stack->values); +	struct ao_scheme_cons	*code = ao_scheme_poly_cons(lambda->code); +	ao_poly			formals; +	struct ao_scheme_frame	*next_frame; +	int			args_wanted; +	ao_poly			varargs = AO_SCHEME_NIL; +	int			args_provided; +	int			f; +	struct ao_scheme_cons	*vals; + +	DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n"); + +	args_wanted = 0; +	for (formals = ao_scheme_arg(code, 0); +	     ao_scheme_is_pair(formals); +	     formals = ao_scheme_poly_cons(formals)->cdr) +		++args_wanted; +	if (formals != AO_SCHEME_NIL) { +		if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM) +			return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form"); +		varargs = formals; +	} + +	/* Create a frame to hold the variables +	 */ +	args_provided = ao_scheme_cons_length(cons) - 1; +	if (varargs == AO_SCHEME_NIL) { +		if (args_wanted != args_provided) +			return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided); +	} else { +		if (args_provided < args_wanted) +			return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); +	} + +	ao_scheme_poly_stash(1, varargs); +	next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); +	varargs = ao_scheme_poly_fetch(1); +	if (!next_frame) +		return AO_SCHEME_NIL; + +	/* Re-fetch all of the values in case something moved */ +	lambda = ao_scheme_poly_lambda(ao_scheme_v); +	cons = ao_scheme_poly_cons(ao_scheme_stack->values); +	code = ao_scheme_poly_cons(lambda->code); +	formals = ao_scheme_arg(code, 0); +	vals = ao_scheme_poly_cons(cons->cdr); + +	next_frame->prev = lambda->frame; +	ao_scheme_frame_current = next_frame; +	ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + +	for (f = 0; f < args_wanted; f++) { +		struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); +		DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); +		ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); +		formals = arg->cdr; +		vals = ao_scheme_poly_cons(vals->cdr); +	} +	if (varargs) { +		DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); +		/* +		 * Bind the rest of the arguments to the final parameter +		 */ +		ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals)); +	} else { +		/* +		 * Mark the cons cells from the actuals as freed for immediate re-use, unless +		 * the actuals point into the source function (nlambdas and macros), or if the +		 * stack containing them was copied as a part of a continuation +		 */ +		if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { +			ao_scheme_stack->values = AO_SCHEME_NIL; +			ao_scheme_cons_free(cons); +		} +	} +	DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n"); +	DBG_STACK(); +	DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); +	return code->cdr; +} diff --git a/src/scheme/ao_scheme_lex.c b/src/scheme/ao_scheme_lex.c new file mode 100644 index 00000000..266b1fc0 --- /dev/null +++ b/src/scheme/ao_scheme_lex.c @@ -0,0 +1,16 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin new file mode 100644 index 00000000..8e9c2c0b --- /dev/null +++ b/src/scheme/ao_scheme_make_builtin @@ -0,0 +1,190 @@ +#!/usr/bin/nickle + +typedef struct { +	string	type; +	string	c_name; +	string[*]	lisp_names; +} builtin_t; + +string[string] type_map = { +	"lambda" => "LAMBDA", +	"nlambda" => "NLAMBDA", +	"macro" => "MACRO", +	"f_lambda" => "F_LAMBDA", +	"atom" => "atom", +}; + +string[*] +make_lisp(string[*] tokens) +{ +	string[...] lisp = {}; + +	if (dim(tokens) < 3) +		return (string[1]) { tokens[dim(tokens) - 1] }; +	return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; +} + +builtin_t +read_builtin(file f) { +	string	line = File::fgets(f); +	string[*]	tokens = String::wordsplit(line, " \t"); + +	return (builtin_t) { +		.type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", +		.c_name = dim(tokens) > 1 ? tokens[1] : "#", +		.lisp_names = make_lisp(tokens), +	}; +} + +builtin_t[*] +read_builtins(file f) { +	builtin_t[...] builtins = {}; + +	while (!File::end(f)) { +		builtin_t	b = read_builtin(f); + +		if (b.type[0] != '#') +			builtins[dim(builtins)] = b; +	} +	return builtins; +} + +bool is_atom(builtin_t b) = b.type == "atom"; + +void +dump_ids(builtin_t[*] builtins) { +	printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); +	printf("#undef AO_SCHEME_BUILTIN_ID\n"); +	printf("enum ao_scheme_builtin_id {\n"); +	for (int i = 0; i < dim(builtins); i++) +		if (!is_atom(builtins[i])) +			printf("\tbuiltin_%s,\n", builtins[i].c_name); +	printf("\t_builtin_last\n"); +	printf("};\n"); +	printf("#endif /* AO_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_atom(builtins[i])) +			printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", +			       builtins[i].c_name, builtins[i].lisp_names[0]); +	printf("\tdefault: return \"???\";\n"); +	printf("\t}\n"); +	printf("}\n"); +	printf("#endif /* AO_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_atom(builtins[i])) { +			printf("\t[builtin_%s] = _ao_scheme_atom_", +			       builtins[i].c_name); +			cify_lisp(builtins[i].lisp_names[0]); +			printf(",\n"); +		} +	} +	printf("};\n"); +	printf("#endif /* AO_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_atom(builtins[i])) +			printf("\t[builtin_%s] = ao_scheme_do_%s,\n", +			       builtins[i].c_name, +			       builtins[i].c_name); +	} +	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_atom(builtins[i])) { +			printf("ao_poly\n"); +			printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", +			       builtins[i].c_name); +		} +	} +	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_atom(builtins[i])) { +			for (int j = 0; j < dim(builtins[i].lisp_names); j++) { +				printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", +					builtins[i].lisp_names[j], +					builtins[i].type, +					builtins[i].c_name); +			} +		} +	} +	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++) { +		for (int j = 0; j < dim(builtins[i].lisp_names); j++) { +			printf("#define _ao_scheme_atom_"); +			cify_lisp(builtins[i].lisp_names[j]); +			printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); +		} +	} +	printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); +} + +void main() { +	if (dim(argv) < 2) { +		File::fprintf(stderr, "usage: %s <file>\n", argv[0]); +		exit(1); +	} +	twixt(file f = File::open(argv[1], "r"); File::close(f)) { +		builtin_t[*]	builtins = read_builtins(f); +		dump_ids(builtins); +		dump_casename(builtins); +		dump_arrayname(builtins); +		dump_funcs(builtins); +		dump_decls(builtins); +		dump_consts(builtins); +		dump_atoms(builtins); +	} +} + +main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c new file mode 100644 index 00000000..cf42ec52 --- /dev/null +++ b/src/scheme/ao_scheme_make_const.c @@ -0,0 +1,395 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <stdlib.h> +#include <ctype.h> +#include <unistd.h> +#include <getopt.h> + +static struct ao_scheme_builtin * +ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { +	struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin)); + +	b->type = AO_SCHEME_BUILTIN; +	b->func = func; +	b->args = args; +	return b; +} + +struct builtin_func { +	char	*name; +	int	args; +	enum ao_scheme_builtin_id	func; +}; + +#define AO_SCHEME_BUILTIN_CONSTS +#include "ao_scheme_builtin.h" + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +struct ao_scheme_frame	*globals; + +static int +is_atom(int offset) +{ +	struct ao_scheme_atom *a; + +	for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) +		if (((uint8_t *) a->name - ao_scheme_const) == offset) +			return strlen(a->name); +	return 0; +} + +#define AO_FEC_CRC_INIT	0xffff + +static inline uint16_t +ao_fec_crc_byte(uint8_t byte, uint16_t crc) +{ +	uint8_t	bit; + +	for (bit = 0; bit < 8; bit++) { +		if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) +			crc = (crc << 1) ^ 0x8005; +		else +			crc = (crc << 1); +		byte <<= 1; +	} +	return crc; +} + +uint16_t +ao_fec_crc(const uint8_t *bytes, uint8_t len) +{ +	uint16_t	crc = AO_FEC_CRC_INIT; + +	while (len--) +		crc = ao_fec_crc_byte(*bytes++, crc); +	return crc; +} + +struct ao_scheme_macro_stack { +	struct ao_scheme_macro_stack *next; +	ao_poly	p; +}; + +struct ao_scheme_macro_stack *macro_stack; + +int +ao_scheme_macro_push(ao_poly p) +{ +	struct ao_scheme_macro_stack *m = macro_stack; + +	while (m) { +		if (m->p == p) +			return 1; +		m = m->next; +	} +	m = malloc (sizeof (struct ao_scheme_macro_stack)); +	m->p = p; +	m->next = macro_stack; +	macro_stack = m; +	return 0; +} + +void +ao_scheme_macro_pop(void) +{ +	struct ao_scheme_macro_stack *m = macro_stack; + +	macro_stack = m->next; +	free(m); +} + +#define DBG_MACRO 0 +#if DBG_MACRO +int macro_scan_depth; + +void indent(void) +{ +	int i; +	for (i = 0; i < macro_scan_depth; i++) +		printf("  "); +} +#define MACRO_DEBUG(a)	a +#else +#define MACRO_DEBUG(a) +#endif + +ao_poly +ao_has_macro(ao_poly p); + +ao_poly +ao_macro_test_get(ao_poly atom) +{ +	ao_poly	*ref = ao_scheme_atom_ref(atom, NULL); +	if (ref) +		return *ref; +	return AO_SCHEME_NIL; +} + +ao_poly +ao_is_macro(ao_poly p) +{ +	struct ao_scheme_builtin	*builtin; +	struct ao_scheme_lambda	*lambda; +	ao_poly ret; + +	MACRO_DEBUG(indent(); printf ("is macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); +	switch (ao_scheme_poly_type(p)) { +	case AO_SCHEME_ATOM: +		if (ao_scheme_macro_push(p)) +			ret = AO_SCHEME_NIL; +		else { +			if (ao_is_macro(ao_macro_test_get(p))) +				ret = p; +			else +				ret = AO_SCHEME_NIL; +			ao_scheme_macro_pop(); +		} +		break; +	case AO_SCHEME_CONS: +		ret = ao_has_macro(p); +		break; +	case AO_SCHEME_BUILTIN: +		builtin = ao_scheme_poly_builtin(p); +		if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO) +			ret = p; +		else +			ret = 0; +		break; + +	case AO_SCHEME_LAMBDA: +		lambda = ao_scheme_poly_lambda(p); +		if (lambda->args == AO_SCHEME_FUNC_MACRO) +			ret = p; +		else +			ret = ao_has_macro(lambda->code); +		break; +	default: +		ret = AO_SCHEME_NIL; +		break; +	} +	MACRO_DEBUG(--macro_scan_depth;	indent(); printf ("... "); ao_scheme_poly_write(ret); printf("\n")); +	return ret; +} + +ao_poly +ao_has_macro(ao_poly p) +{ +	struct ao_scheme_cons	*cons; +	struct ao_scheme_lambda	*lambda; +	ao_poly			m; +	ao_poly			list; + +	if (p == AO_SCHEME_NIL) +		return AO_SCHEME_NIL; + +	MACRO_DEBUG(indent(); printf("has macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); +	switch (ao_scheme_poly_type(p)) { +	case AO_SCHEME_LAMBDA: +		lambda = ao_scheme_poly_lambda(p); +		p = ao_has_macro(lambda->code); +		break; +	case AO_SCHEME_CONS: +		cons = ao_scheme_poly_cons(p); +		if ((p = ao_is_macro(cons->car))) +			break; + +		list = cons->cdr; +		p = AO_SCHEME_NIL; +		while (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { +			cons = ao_scheme_poly_cons(list); +			m = ao_has_macro(cons->car); +			if (m) { +				p = m; +				break; +			} +			list = cons->cdr; +		} +		break; + +	default: +		p = AO_SCHEME_NIL; +		break; +	} +	MACRO_DEBUG(--macro_scan_depth;	indent(); printf("... "); ao_scheme_poly_write(p); printf("\n")); +	return p; +} + +int +ao_scheme_read_eval_abort(void) +{ +	ao_poly	in, out = AO_SCHEME_NIL; +	for(;;) { +		in = ao_scheme_read(); +		if (in == _ao_scheme_atom_eof) +			break; +		out = ao_scheme_eval(in); +		if (ao_scheme_exception) +			return 0; +		ao_scheme_poly_write(out); +		putchar ('\n'); +	} +	return 1; +} + +static FILE	*in; +static FILE	*out; + +int +ao_scheme_getc(void) +{ +	return getc(in); +} + +static const struct option options[] = { +	{ .name = "out", .has_arg = 1, .val = 'o' }, +	{ 0, 0, 0, 0 } +}; + +static void usage(char *program) +{ +	fprintf(stderr, "usage: %s [--out=<output>] [input]\n", program); +	exit(1); +} + +int +main(int argc, char **argv) +{ +	int	f, o; +	ao_poly	val; +	struct ao_scheme_atom	*a; +	struct ao_scheme_builtin	*b; +	int	in_atom = 0; +	char	*out_name = NULL; +	int	c; +	enum ao_scheme_builtin_id	prev_func; + +	in = stdin; +	out = stdout; + +	while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { +		switch (c) { +		case 'o': +			out_name = optarg; +			break; +		default: +			usage(argv[0]); +			break; +		} +	} + +	ao_scheme_frame_init(); + +	/* Boolean values #f and #t */ +	ao_scheme_bool_get(0); +	ao_scheme_bool_get(1); + +	prev_func = _builtin_last; +	for (f = 0; f < (int) N_FUNC; f++) { +		if (funcs[f].func != prev_func) +			b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); +		a = ao_scheme_atom_intern(funcs[f].name); +		ao_scheme_atom_def(ao_scheme_atom_poly(a), +				 ao_scheme_builtin_poly(b)); +	} + +	/* end of file value */ +	a = ao_scheme_atom_intern("eof"); +	ao_scheme_atom_def(ao_scheme_atom_poly(a), +			 ao_scheme_atom_poly(a)); + +	/* 'else' */ +	a = ao_scheme_atom_intern("else"); + +	if (argv[optind]){ +		in = fopen(argv[optind], "r"); +		if (!in) { +			perror(argv[optind]); +			exit(1); +		} +	} +	if (!ao_scheme_read_eval_abort()) { +		fprintf(stderr, "eval failed\n"); +		exit(1); +	} + +	/* Reduce to referenced values */ +	ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + +	for (f = 0; f < ao_scheme_frame_global->num; f++) { +		struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); +		val = ao_has_macro(vals->vals[f].val); +		if (val != AO_SCHEME_NIL) { +			printf("error: function %s contains unresolved macro: ", +			       ao_scheme_poly_atom(vals->vals[f].atom)->name); +			ao_scheme_poly_write(val); +			printf("\n"); +			exit(1); +		} +	} + +	if (out_name) { +		out = fopen(out_name, "w"); +		if (!out) { +			perror(out_name); +			exit(1); +		} +	} + +	fprintf(out, "/* Generated file, do not edit */\n\n"); + +	fprintf(out, "#define AO_SCHEME_POOL_CONST %d\n", ao_scheme_top); +	fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n"); +	fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms)); +	fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global)); +	fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top)); + +	fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false)); +	fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true)); + +	for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) { +		char	*n = a->name, c; +		fprintf(out, "#define _ao_scheme_atom_"); +		while ((c = *n++)) { +			if (isalnum(c)) +				fprintf(out, "%c", c); +			else +				fprintf(out, "%02x", c); +		} +		fprintf(out, "  0x%04x\n", ao_scheme_atom_poly(a)); +	} +	fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); +	fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); +	for (o = 0; o < ao_scheme_top; o++) { +		uint8_t	c; +		if ((o & 0xf) == 0) +			fprintf(out, "\n\t"); +		else +			fprintf(out, " "); +		c = ao_scheme_const[o]; +		if (!in_atom) +			in_atom = is_atom(o); +		if (in_atom) { +			fprintf(out, " '%c',", c); +			in_atom--; +		} else { +			fprintf(out, "0x%02x,", c); +		} +	} +	fprintf(out, "\n};\n"); +	fprintf(out, "#endif /* AO_SCHEME_CONST_BITS */\n"); +	exit(0); +} diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c new file mode 100644 index 00000000..acc726c8 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,968 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#define AO_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include <stdio.h> +#include <assert.h> + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include <stdlib.h> +uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#undef AO_SCHEME_POOL +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#else + +uint8_t	ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); + +#endif + +#ifndef DBG_MEM_STATS +#define DBG_MEM_STATS	DBG_MEM +#endif + +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_validate = 0; + +struct ao_scheme_record { +	struct ao_scheme_record		*next; +	const struct ao_scheme_type	*type; +	void				*addr; +	int				size; +}; + +static struct ao_scheme_record	*record_head, **record_tail; + +static void +ao_scheme_record_free(struct ao_scheme_record *record) +{ +	while (record) { +		struct ao_scheme_record *next = record->next; +		free(record); +		record = next; +	} +} + +static void +ao_scheme_record_reset(void) +{ +	ao_scheme_record_free(record_head); +	record_head = NULL; +	record_tail = &record_head; +} + +static void +ao_scheme_record(const struct ao_scheme_type	*type, +	       void				*addr, +	       int				size) +{ +	struct ao_scheme_record	*r = malloc(sizeof (struct ao_scheme_record)); + +	r->next = NULL; +	r->type = type; +	r->addr = addr; +	r->size = size; +	*record_tail = r; +	record_tail = &r->next; +} + +static struct ao_scheme_record * +ao_scheme_record_save(void) +{ +	struct ao_scheme_record *r = record_head; + +	record_head = NULL; +	record_tail = &record_head; +	return r; +} + +static void +ao_scheme_record_compare(char *where, +		       struct ao_scheme_record *a, +		       struct ao_scheme_record *b) +{ +	while (a && b) { +		if (a->type != b->type || a->size != b->size) { +			printf("%s record difers %d %s %d -> %d %s %d\n", +			       where, +			       MDBG_OFFSET(a->addr), +			       a->type->name, +			       a->size, +			       MDBG_OFFSET(b->addr), +			       b->type->name, +			       b->size); +			ao_scheme_abort(); +		} +		a = a->next; +		b = b->next; +	} +	if (a) { +		printf("%s record differs %d %s %d -> NULL\n", +		       where, +		       MDBG_OFFSET(a->addr), +		       a->type->name, +		       a->size); +		ao_scheme_abort(); +	} +	if (b) { +		printf("%s record differs NULL -> %d %s %d\n", +		       where, +		       MDBG_OFFSET(b->addr), +		       b->type->name, +		       b->size); +		ao_scheme_abort(); +	} +} + +#else +#define ao_scheme_record_reset() +#endif + +uint8_t	ao_scheme_exception; + +struct ao_scheme_root { +	const struct ao_scheme_type	*type; +	void				**addr; +}; + +static struct ao_scheme_cons 	*save_cons[2]; +static char			*save_string[2]; +static struct ao_scheme_frame	*save_frame[1]; +static ao_poly			save_poly[3]; + +static const struct ao_scheme_root	ao_scheme_root[] = { +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &save_cons[0], +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &save_cons[1], +	}, +	{ +		.type = &ao_scheme_string_type, +		.addr = (void **) &save_string[0], +	}, +	{ +		.type = &ao_scheme_string_type, +		.addr = (void **) &save_string[1], +	}, +	{ +		.type = &ao_scheme_frame_type, +		.addr = (void **) &save_frame[0], +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &save_poly[0] +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &save_poly[1] +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &save_poly[2] +	}, +	{ +		.type = &ao_scheme_atom_type, +		.addr = (void **) &ao_scheme_atoms +	}, +	{ +		.type = &ao_scheme_frame_type, +		.addr = (void **) &ao_scheme_frame_global, +	}, +	{ +		.type = &ao_scheme_frame_type, +		.addr = (void **) &ao_scheme_frame_current, +	}, +	{ +		.type = &ao_scheme_stack_type, +		.addr = (void **) &ao_scheme_stack, +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &ao_scheme_v, +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &ao_scheme_read_cons, +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &ao_scheme_read_cons_tail, +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &ao_scheme_read_stack, +	}, +#ifdef AO_SCHEME_MAKE_CONST +	{ +		.type = &ao_scheme_bool_type, +		.addr = (void **) &ao_scheme_false, +	}, +	{ +		.type = &ao_scheme_bool_type, +		.addr = (void **) &ao_scheme_true, +	}, +#endif +}; + +#define AO_SCHEME_ROOT	(sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) + +static const void ** const ao_scheme_cache[] = { +	(const void **) &ao_scheme_cons_free_list, +	(const void **) &ao_scheme_stack_free_list, +	(const void **) &ao_scheme_frame_free_list[0], +	(const void **) &ao_scheme_frame_free_list[1], +	(const void **) &ao_scheme_frame_free_list[2], +	(const void **) &ao_scheme_frame_free_list[3], +	(const void **) &ao_scheme_frame_free_list[4], +	(const void **) &ao_scheme_frame_free_list[5], +}; + +#if AO_SCHEME_FRAME_FREE != 6 +#error Unexpected AO_SCHEME_FRAME_FREE value +#endif + +#define AO_SCHEME_CACHE	(sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) + +#define AO_SCHEME_BUSY_SIZE	((AO_SCHEME_POOL + 31) / 32) + +static uint8_t	ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; +static uint8_t	ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; +static uint8_t	ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; +static uint8_t	ao_scheme_cons_noted; + +uint16_t	ao_scheme_top; + +struct ao_scheme_chunk { +	uint16_t		old_offset; +	union { +		uint16_t	size; +		uint16_t	new_offset; +	}; +}; + +#define AO_SCHEME_NCHUNK	64 + +static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM +	if (!AO_SCHEME_IS_POOL(addr)) +		ao_scheme_abort(); +#endif +	return ((uint8_t *) addr) - ao_scheme_pool; +} + +static inline void mark(uint8_t *tag, int offset) { +	int	byte = offset >> 5; +	int	bit = (offset >> 2) & 7; +	tag[byte] |= (1 << bit); +} + +static inline void clear(uint8_t *tag, int offset) { +	int	byte = offset >> 5; +	int	bit = (offset >> 2) & 7; +	tag[byte] &= ~(1 << bit); +} + +static inline int busy(uint8_t *tag, int offset) { +	int	byte = offset >> 5; +	int	bit = (offset >> 2) & 7; +	return (tag[byte] >> bit) & 1; +} + +static inline int min(int a, int b) { return a < b ? a : b; } +static inline int max(int a, int b) { return a > b ? a : b; } + +static inline int limit(int offset) { +	return min(AO_SCHEME_POOL, max(offset, 0)); +} + +static void +note_cons(uint16_t offset) +{ +	MDBG_MOVE("note cons %d\n", offset); +	ao_scheme_cons_noted = 1; +	mark(ao_scheme_cons_note, offset); +} + +static uint16_t	chunk_low, chunk_high; +static uint16_t	chunk_first, chunk_last; + +static int +find_chunk(uint16_t offset) +{ +	int l, r; +	/* Binary search for the location */ +	l = chunk_first; +	r = chunk_last - 1; +	while (l <= r) { +		int m = (l + r) >> 1; +		if (ao_scheme_chunk[m].old_offset < offset) +			l = m + 1; +		else +			r = m - 1; +	} +	return l; +} + +static void +note_chunk(uint16_t offset, uint16_t size) +{ +	int l; + +	if (offset < chunk_low || chunk_high <= offset) +		return; + +	l = find_chunk(offset); + +	/* +	 * The correct location is always in 'l', with r = l-1 being +	 * the entry before the right one +	 */ + +#if DBG_MEM +	/* Off the right side */ +	if (l >= AO_SCHEME_NCHUNK) +		ao_scheme_abort(); + +	/* Off the left side */ +	if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) +		ao_scheme_abort(); +#endif + +	/* Shuffle existing entries right */ +	int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + +	memmove(&ao_scheme_chunk[l+1], +		&ao_scheme_chunk[l], +		(end - (l+1)) * sizeof (struct ao_scheme_chunk)); + +	/* Add new entry */ +	ao_scheme_chunk[l].old_offset = offset; +	ao_scheme_chunk[l].size = size; + +	/* Increment the number of elements up to the size of the array */ +	if (chunk_last < AO_SCHEME_NCHUNK) +		chunk_last++; + +	/* Set the top address if the array is full */ +	if (chunk_last == AO_SCHEME_NCHUNK) +		chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + +			ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; +} + +static void +reset_chunks(void) +{ +	chunk_high = ao_scheme_top; +	chunk_last = 0; +	chunk_first = 0; +} + +/* + * Walk all referenced objects calling functions on each one + */ + +static void +walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr), +     int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) +{ +	int i; + +	ao_scheme_record_reset(); +	memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); +	memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); +	ao_scheme_cons_noted = 0; +	for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { +		if (ao_scheme_root[i].type) { +			void **a = ao_scheme_root[i].addr, *v; +			if (a && (v = *a)) { +				MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); +				visit_addr(ao_scheme_root[i].type, a); +			} +		} else { +			ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; +			if (a && (p = *a)) { +				MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); +				visit_poly(a, 0); +			} +		} +	} +	while (ao_scheme_cons_noted) { +		memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); +		memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); +		ao_scheme_cons_noted = 0; +		for (i = 0; i < AO_SCHEME_POOL; i += 4) { +			if (busy(ao_scheme_cons_last, i)) { +				void *v = ao_scheme_pool + i; +				MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); +				visit_addr(&ao_scheme_cons_type, &v); +			} +		} +	} +} + +#if MDBG_DUMP +static void +dump_busy(void) +{ +	int	i; +	MDBG_MOVE("busy:"); +	for (i = 0; i < ao_scheme_top; i += 4) { +		if ((i & 0xff) == 0) { +			MDBG_MORE("\n"); +			MDBG_MOVE("%s", ""); +		} +		else if ((i & 0x1f) == 0) +			MDBG_MORE(" "); +		if (busy(ao_scheme_busy, i)) +			MDBG_MORE("*"); +		else +			MDBG_MORE("-"); +	} +	MDBG_MORE ("\n"); +} +#define DUMP_BUSY()	dump_busy() +#else +#define DUMP_BUSY() +#endif + +static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { +	[AO_SCHEME_CONS] = &ao_scheme_cons_type, +	[AO_SCHEME_INT] = NULL, +	[AO_SCHEME_STRING] = &ao_scheme_string_type, +	[AO_SCHEME_OTHER] = (void *) 0x1, +	[AO_SCHEME_ATOM] = &ao_scheme_atom_type, +	[AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, +	[AO_SCHEME_FRAME] = &ao_scheme_frame_type, +	[AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, +	[AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, +	[AO_SCHEME_STACK] = &ao_scheme_stack_type, +	[AO_SCHEME_BOOL] = &ao_scheme_bool_type, +	[AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, +	[AO_SCHEME_FLOAT] = &ao_scheme_float_type, +}; + +static int +ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) +{ +	return ao_scheme_mark(type, *ref); +} + +static int +ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) +{ +	return ao_scheme_poly_mark(*p, do_note_cons); +} + +#if DBG_MEM_STATS +int ao_scheme_collects[2]; +int ao_scheme_freed[2]; +int ao_scheme_loops[2]; +#endif + +int ao_scheme_last_top; + +int +ao_scheme_collect(uint8_t style) +{ +	int	i; +	int	top; +#if DBG_MEM_STATS +	int	loops = 0; +#endif +#if DBG_MEM +	struct ao_scheme_record	*mark_record = NULL, *move_record = NULL; + +	MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); +#endif +	MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + +	/* The first time through, we're doing a full collect */ +	if (ao_scheme_last_top == 0) +		style = AO_SCHEME_COLLECT_FULL; + +	/* Clear references to all caches */ +	for (i = 0; i < (int) AO_SCHEME_CACHE; i++) +		*ao_scheme_cache[i] = NULL; +	if (style == AO_SCHEME_COLLECT_FULL) { +		chunk_low = top = 0; +	} else { +		chunk_low = top = ao_scheme_last_top; +	} +	for (;;) { +#if DBG_MEM_STATS +		loops++; +#endif +		MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); +		/* Find the sizes of the first chunk of objects to move */ +		reset_chunks(); +		walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +#if DBG_MEM + +		ao_scheme_record_free(mark_record); +		mark_record = ao_scheme_record_save(); +		if (mark_record && move_record) +			ao_scheme_record_compare("mark", move_record, mark_record); +#endif + +		DUMP_BUSY(); + +		/* Find the first moving object */ +		for (i = 0; i < chunk_last; i++) { +			uint16_t	size = ao_scheme_chunk[i].size; + +#if DBG_MEM +			if (!size) +				ao_scheme_abort(); +#endif + +			if (ao_scheme_chunk[i].old_offset > top) +				break; + +			MDBG_MOVE("chunk %d %d not moving\n", +				  ao_scheme_chunk[i].old_offset, +				  ao_scheme_chunk[i].size); +#if DBG_MEM +			if (ao_scheme_chunk[i].old_offset != top) +				ao_scheme_abort(); +#endif +			top += size; +		} + +		/* +		 * Limit amount of chunk array used in mapping moves +		 * to the active region +		 */ +		chunk_first = i; +		chunk_low = ao_scheme_chunk[i].old_offset; + +		/* Copy all of the objects */ +		for (; i < chunk_last; i++) { +			uint16_t	size = ao_scheme_chunk[i].size; + +#if DBG_MEM +			if (!size) +				ao_scheme_abort(); +#endif + +			MDBG_MOVE("chunk %d %d -> %d\n", +				  ao_scheme_chunk[i].old_offset, +				  size, +				  top); +			ao_scheme_chunk[i].new_offset = top; + +			memmove(&ao_scheme_pool[top], +				&ao_scheme_pool[ao_scheme_chunk[i].old_offset], +				size); + +			top += size; +		} + +		if (chunk_first < chunk_last) { +			/* Relocate all references to the objects */ +			walk(ao_scheme_move, ao_scheme_poly_move); + +#if DBG_MEM +			ao_scheme_record_free(move_record); +			move_record = ao_scheme_record_save(); +			if (mark_record && move_record) +				ao_scheme_record_compare("move", mark_record, move_record); +#endif +		} + +		/* If we ran into the end of the heap, then +		 * there's no need to keep walking +		 */ +		if (chunk_last != AO_SCHEME_NCHUNK) +			break; + +		/* Next loop starts right above this loop */ +		chunk_low = chunk_high; +	} + +#if DBG_MEM_STATS +	/* Collect stats */ +	++ao_scheme_collects[style]; +	ao_scheme_freed[style] += ao_scheme_top - top; +	ao_scheme_loops[style] += loops; +#endif + +	ao_scheme_top = top; +	if (style == AO_SCHEME_COLLECT_FULL) +		ao_scheme_last_top = top; + +	MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); +		walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); + +	return AO_SCHEME_POOL - ao_scheme_top; +} + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons) +{ +	ao_poly	cdr; +	int offset; + +	chunk_low = 0; +	reset_chunks(); +	walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +	while (cons) { +		if (!AO_SCHEME_IS_POOL(cons)) +			break; +		offset = pool_offset(cons); +		if (busy(ao_scheme_busy, offset)) { +			ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); +			abort(); +		} +		cdr = cons->cdr; +		if (!ao_scheme_is_pair(cdr)) +			break; +		cons = ao_scheme_poly_cons(cdr); +	} +} +#endif + +/* + * Mark interfaces for objects + */ + + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_scheme_mark_block(void *addr, int size) +{ +	int offset; +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	offset = pool_offset(addr); +	MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); +	if (busy(ao_scheme_busy, offset)) { +		MDBG_MOVE("already marked\n"); +		return 1; +	} +	mark(ao_scheme_busy, offset); +	note_chunk(offset, size); +	return 0; +} + +/* + * Note a reference to memory and collect information about a few + * object sizes at a time + */ + +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) +{ +	int offset; +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	offset = pool_offset(addr); +	MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); +	if (busy(ao_scheme_busy, offset)) { +		MDBG_MOVE("already marked\n"); +		return 1; +	} +	mark(ao_scheme_busy, offset); +	note_chunk(offset, ao_scheme_size(type, addr)); +	return 0; +} + +/* + * Mark an object and all that it refereces + */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr) +{ +	int ret; +	MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); +	MDBG_MOVE_IN(); +	ret = ao_scheme_mark_memory(type, addr); +	if (!ret) { +		MDBG_MOVE("mark recurse\n"); +		type->mark(addr); +	} +	MDBG_MOVE_OUT(); +	return ret; +} + +/* + * Mark an object, unless it is a cons cell and + * do_note_cons is set. In that case, just + * set a bit in the cons note array; those + * will be marked in a separate pass to avoid + * deep recursion in the collector + */ +int +ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) +{ +	uint8_t type; +	void	*addr; + +	type = ao_scheme_poly_base_type(p); + +	if (type == AO_SCHEME_INT) +		return 1; + +	addr = ao_scheme_ref(p); +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	if (type == AO_SCHEME_CONS && do_note_cons) { +		note_cons(pool_offset(addr)); +		return 1; +	} else { +		if (type == AO_SCHEME_OTHER) +			type = ao_scheme_other_type(addr); + +		const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM +		if (!lisp_type) +			ao_scheme_abort(); +#endif + +		return ao_scheme_mark(lisp_type, addr); +	} +} + +/* + * Find the current location of an object + * based on the original location. For unmoved + * objects, this is simple. For moved objects, + * go search for it + */ + +static uint16_t +move_map(uint16_t offset) +{ +	int		l; + +	if (offset < chunk_low || chunk_high <= offset) +		return offset; + +	l = find_chunk(offset); + +#if DBG_MEM +	if (ao_scheme_chunk[l].old_offset != offset) +		ao_scheme_abort(); +#endif +	return ao_scheme_chunk[l].new_offset; +} + +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) +{ +	void		*addr = *ref; +	uint16_t	offset, orig_offset; + +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	(void) type; + +	MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); +	orig_offset = pool_offset(addr); +	offset = move_map(orig_offset); +	if (offset != orig_offset) { +		MDBG_MOVE("update ref %d %d -> %d\n", +			  AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, +			  orig_offset, offset); +		*ref = ao_scheme_pool + offset; +	} +	if (busy(ao_scheme_busy, offset)) { +		MDBG_MOVE("already moved\n"); +		return 1; +	} +	mark(ao_scheme_busy, offset); +	MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); +	return 0; +} + +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref) +{ +	int ret; +	MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); +	MDBG_MOVE_IN(); +	ret = ao_scheme_move_memory(type, ref); +	if (!ret) { +		MDBG_MOVE("move recurse\n"); +		type->move(*ref); +	} +	MDBG_MOVE_OUT(); +	return ret; +} + +int +ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) +{ +	uint8_t		type; +	ao_poly		p = *ref; +	int		ret; +	void		*addr; +	uint16_t	offset, orig_offset; +	uint8_t		base_type; + +	base_type = type = ao_scheme_poly_base_type(p); + +	if (type == AO_SCHEME_INT) +		return 1; + +	addr = ao_scheme_ref(p); +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	orig_offset = pool_offset(addr); +	offset = move_map(orig_offset); + +	if (type == AO_SCHEME_CONS && do_note_cons) { +		note_cons(orig_offset); +		ret = 1; +	} else { +		if (type == AO_SCHEME_OTHER) +			type = ao_scheme_other_type(ao_scheme_pool + offset); + +		const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM +		if (!lisp_type) +			ao_scheme_abort(); +#endif + +		ret = ao_scheme_move(lisp_type, &addr); +	} + +	/* Re-write the poly value */ +	if (offset != orig_offset) { +		ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); +		MDBG_MOVE("poly %d moved %d -> %d\n", +			  type, orig_offset, offset); +		*ref = np; +	} +	return ret; +} + +#if DBG_MEM +void +ao_scheme_validate(void) +{ +	chunk_low = 0; +	memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); +	walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +} + +int dbg_allocs; + +#endif + +void * +ao_scheme_alloc(int size) +{ +	void	*addr; + +	MDBG_DO(++dbg_allocs); +	MDBG_DO(if (dbg_validate) ao_scheme_validate()); +	size = ao_scheme_size_round(size); +	if (AO_SCHEME_POOL - ao_scheme_top < size && +	    ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && +	    ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) +	{ +		ao_scheme_error(AO_SCHEME_OOM, "out of memory"); +		return NULL; +	} +	addr = ao_scheme_pool + ao_scheme_top; +	ao_scheme_top += size; +	MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); +	return addr; +} + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons) +{ +	assert(save_cons[id] == 0); +	save_cons[id] = cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id) +{ +	struct ao_scheme_cons *cons = save_cons[id]; +	save_cons[id] = NULL; +	return cons; +} + +void +ao_scheme_poly_stash(int id, ao_poly poly) +{ +	assert(save_poly[id] == AO_SCHEME_NIL); +	save_poly[id] = poly; +} + +ao_poly +ao_scheme_poly_fetch(int id) +{ +	ao_poly poly = save_poly[id]; +	save_poly[id] = AO_SCHEME_NIL; +	return poly; +} + +void +ao_scheme_string_stash(int id, char *string) +{ +	assert(save_string[id] == NULL); +	save_string[id] = string; +} + +char * +ao_scheme_string_fetch(int id) +{ +	char *string = save_string[id]; +	save_string[id] = NULL; +	return string; +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) +{ +	assert(save_frame[id] == NULL); +	save_frame[id] = frame; +} + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id) +{ +	struct ao_scheme_frame *frame = save_frame[id]; +	save_frame[id] = NULL; +	return frame; +} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c new file mode 100644 index 00000000..d726321c --- /dev/null +++ b/src/scheme/ao_scheme_poly.c @@ -0,0 +1,118 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +struct ao_scheme_funcs { +	void (*write)(ao_poly); +	void (*display)(ao_poly); +}; + +static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { +	[AO_SCHEME_CONS] = { +		.write = ao_scheme_cons_write, +		.display = ao_scheme_cons_display, +	}, +	[AO_SCHEME_STRING] = { +		.write = ao_scheme_string_write, +		.display = ao_scheme_string_display, +	}, +	[AO_SCHEME_INT] = { +		.write = ao_scheme_int_write, +		.display = ao_scheme_int_write, +	}, +	[AO_SCHEME_ATOM] = { +		.write = ao_scheme_atom_write, +		.display = ao_scheme_atom_write, +	}, +	[AO_SCHEME_BUILTIN] = { +		.write = ao_scheme_builtin_write, +		.display = ao_scheme_builtin_write, +	}, +	[AO_SCHEME_FRAME] = { +		.write = ao_scheme_frame_write, +		.display = ao_scheme_frame_write, +	}, +	[AO_SCHEME_FRAME_VALS] = { +		.write = NULL, +		.display = NULL, +	}, +	[AO_SCHEME_LAMBDA] = { +		.write = ao_scheme_lambda_write, +		.display = ao_scheme_lambda_write, +	}, +	[AO_SCHEME_STACK] = { +		.write = ao_scheme_stack_write, +		.display = ao_scheme_stack_write, +	}, +	[AO_SCHEME_BOOL] = { +		.write = ao_scheme_bool_write, +		.display = ao_scheme_bool_write, +	}, +	[AO_SCHEME_BIGINT] = { +		.write = ao_scheme_bigint_write, +		.display = ao_scheme_bigint_write, +	}, +	[AO_SCHEME_FLOAT] = { +		.write = ao_scheme_float_write, +		.display = ao_scheme_float_write, +	}, +}; + +static const struct ao_scheme_funcs * +funcs(ao_poly p) +{ +	uint8_t	type = ao_scheme_poly_type(p); + +	if (type < AO_SCHEME_NUM_TYPE) +		return &ao_scheme_funcs[type]; +	return NULL; +} + +void +ao_scheme_poly_write(ao_poly p) +{ +	const struct ao_scheme_funcs *f = funcs(p); + +	if (f && f->write) +		f->write(p); +} + +void +ao_scheme_poly_display(ao_poly p) +{ +	const struct ao_scheme_funcs *f = funcs(p); + +	if (f && f->display) +		f->display(p); +} + +void * +ao_scheme_ref(ao_poly poly) { +	if (poly == AO_SCHEME_NIL) +		return NULL; +	if (poly & AO_SCHEME_CONST) +		return (void *) (ao_scheme_const + (poly & AO_SCHEME_REF_MASK) - 4); +	return (void *) (ao_scheme_pool + (poly & AO_SCHEME_REF_MASK) - 4); +} + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type) { +	const uint8_t	*a = addr; +	if (a == NULL) +		return AO_SCHEME_NIL; +	if (AO_SCHEME_IS_CONST(a)) +		return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; +	return (a - ao_scheme_pool + 4) | type; +} diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c new file mode 100644 index 00000000..6b1e9d66 --- /dev/null +++ b/src/scheme/ao_scheme_read.c @@ -0,0 +1,655 @@ +/* + * 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|POUND,	/* # */ + 	PRINTABLE,		/* $ */ + 	PRINTABLE,		/* % */ + 	PRINTABLE,		/* & */ + 	PRINTABLE|SPECIAL,	/* ' */ + 	PRINTABLE|SPECIAL,	/* ( */ + 	PRINTABLE|SPECIAL,	/* ) */ + 	PRINTABLE,		/* * */ + 	PRINTABLE|SIGN,		/* + */ + 	PRINTABLE|SPECIAL,	/* , */ + 	PRINTABLE|SIGN,		/* - */ + 	PRINTABLE|DOTC|FLOATC,	/* . */ + 	PRINTABLE,		/* / */ + 	PRINTABLE|DIGIT,	/* 0 */ + 	PRINTABLE|DIGIT,	/* 1 */ + 	PRINTABLE|DIGIT,	/* 2 */ + 	PRINTABLE|DIGIT,	/* 3 */ + 	PRINTABLE|DIGIT,	/* 4 */ + 	PRINTABLE|DIGIT,	/* 5 */ + 	PRINTABLE|DIGIT,	/* 6 */ + 	PRINTABLE|DIGIT,	/* 7 */ + 	PRINTABLE|DIGIT,	/* 8 */ + 	PRINTABLE|DIGIT,	/* 9 */ + 	PRINTABLE,		/* : */ + 	PRINTABLE|COMMENT,	/* ; */ + 	PRINTABLE,		/* < */ + 	PRINTABLE,		/* = */ + 	PRINTABLE,		/* > */ + 	PRINTABLE,		/* ? */ +  	PRINTABLE,		/*  @ */ +	PRINTABLE,		/*  A */ +	PRINTABLE,		/*  B */ +	PRINTABLE,		/*  C */ +	PRINTABLE,		/*  D */ +	PRINTABLE|FLOATC,	/*  E */ +	PRINTABLE,		/*  F */ +	PRINTABLE,		/*  G */ +	PRINTABLE,		/*  H */ +	PRINTABLE,		/*  I */ +	PRINTABLE,		/*  J */ +	PRINTABLE,		/*  K */ +	PRINTABLE,		/*  L */ +	PRINTABLE,		/*  M */ +	PRINTABLE,		/*  N */ +	PRINTABLE,		/*  O */ +	PRINTABLE,		/*  P */ +	PRINTABLE,		/*  Q */ +	PRINTABLE,		/*  R */ +	PRINTABLE,		/*  S */ +	PRINTABLE,		/*  T */ +	PRINTABLE,		/*  U */ +	PRINTABLE,		/*  V */ +	PRINTABLE,		/*  W */ +	PRINTABLE,		/*  X */ +	PRINTABLE,		/*  Y */ +	PRINTABLE,		/*  Z */ +	PRINTABLE,		/*  [ */ +	PRINTABLE|BACKSLASH,	/*  \ */ +	PRINTABLE,		/*  ] */ +	PRINTABLE,		/*  ^ */ +	PRINTABLE,		/*  _ */ +  	PRINTABLE|SPECIAL,	/*  ` */ +	PRINTABLE,		/*  a */ +	PRINTABLE,		/*  b */ +	PRINTABLE,		/*  c */ +	PRINTABLE,		/*  d */ +	PRINTABLE|FLOATC,	/*  e */ +	PRINTABLE,		/*  f */ +	PRINTABLE,		/*  g */ +	PRINTABLE,		/*  h */ +	PRINTABLE,		/*  i */ +	PRINTABLE,		/*  j */ +	PRINTABLE,		/*  k */ +	PRINTABLE,		/*  l */ +	PRINTABLE,		/*  m */ +	PRINTABLE,		/*  n */ +	PRINTABLE,		/*  o */ +	PRINTABLE,		/*  p */ +	PRINTABLE,		/*  q */ +	PRINTABLE,		/*  r */ +	PRINTABLE,		/*  s */ +	PRINTABLE,		/*  t */ +	PRINTABLE,		/*  u */ +	PRINTABLE,		/*  v */ +	PRINTABLE,		/*  w */ +	PRINTABLE,		/*  x */ +	PRINTABLE,		/*  y */ +	PRINTABLE,		/*  z */ +	PRINTABLE,		/*  { */ +	PRINTABLE,		/*  | */ +	PRINTABLE,		/*  } */ +	PRINTABLE,		/*  ~ */ +	IGNORE,			/*  ^? */ +}; + +static int lex_unget_c; + +static inline int +lex_get() +{ +	int	c; +	if (lex_unget_c) { +		c = lex_unget_c; +		lex_unget_c = 0; +	} else { +		c = ao_scheme_getc(); +	} +	return c; +} + +static inline void +lex_unget(int c) +{ +	if (c != EOF) +		lex_unget_c = c; +} + +static uint16_t	lex_class; + +static int +lexc(void) +{ +	int	c; +	do { +		c = lex_get(); +		if (c == EOF) { +			c = 0; +			lex_class = ENDOFFILE; +		} else { +			c &= 0x7f; +			lex_class = lex_classes[c]; +		} +	} while (lex_class & IGNORE); +	return c; +} + +static int +lex_quoted(void) +{ +	int	c; +	int	v; +	int	count; + +	c = lex_get(); +	if (c == EOF) { +		lex_class = ENDOFFILE; +		return 0; +	} +	lex_class = 0; +	c &= 0x7f; + 	switch (c) { +	case 'n': +		return '\n'; +	case 'f': +		return '\f'; +	case 'b': +		return '\b'; +	case 'r': +		return '\r'; +	case 'v': +		return '\v'; +	case 't': +		return '\t'; +	case '0': +	case '1': +	case '2': +	case '3': +	case '4': +	case '5': +	case '6': +	case '7': +		v = c - '0'; +		count = 1; +		while (count <= 3) { +			c = lex_get(); +			if (c == EOF) +				return EOF; +			c &= 0x7f; +			if (c < '0' || '7' < c) { +				lex_unget(c); +				break; +			} +			v = (v << 3) + c - '0'; +			++count; +		} +		return v; +	default: +		return c; +	} +} + +#define AO_SCHEME_TOKEN_MAX	32 + +static char	token_string[AO_SCHEME_TOKEN_MAX]; +static int32_t	token_int; +static int	token_len; +static float	token_float; + +static inline void add_token(int c) { +	if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) +		token_string[token_len++] = c; +} + +static inline void del_token(void) { +	if (token_len > 0) +		token_len--; +} + +static inline void end_token(void) { +	token_string[token_len] = '\0'; +} + +struct namedfloat { +	const char	*name; +	float		value; +}; + +static const struct namedfloat namedfloats[] = { +	{ .name = "+inf.0", .value = INFINITY }, +	{ .name = "-inf.0", .value = -INFINITY }, +	{ .name = "+nan.0", .value = NAN }, +	{ .name = "-nan.0", .value = NAN }, +}; + +#define NUM_NAMED_FLOATS	(sizeof namedfloats / sizeof namedfloats[0]) + +static int +_lex(void) +{ +	int	c; + +	token_len = 0; +	for (;;) { +		c = lexc(); +		if (lex_class & ENDOFFILE) +			return END; + +		if (lex_class & WHITE) +			continue; + +		if (lex_class & COMMENT) { +			while ((c = lexc()) != '\n') { +				if (lex_class & ENDOFFILE) +					return END; +			} +			continue; +		} + +		if (lex_class & (SPECIAL|DOTC)) { +			add_token(c); +			end_token(); +			switch (c) { +			case '(': +			case '[': +				return OPEN; +			case ')': +			case ']': +				return CLOSE; +			case '\'': +				return QUOTE; +			case '.': +				return DOT; +			case '`': +				return QUASIQUOTE; +			case ',': +				c = lexc(); +				if (c == '@') { +					add_token(c); +					end_token(); +					return UNQUOTE_SPLICING; +				} else { +					lex_unget(c); +					return UNQUOTE; +				} +			} +		} +		if (lex_class & POUND) { +			c = lexc(); +			switch (c) { +			case 't': +				add_token(c); +				end_token(); +				return BOOL; +			case 'f': +				add_token(c); +				end_token(); +				return BOOL; +			case '\\': +				for (;;) { +					int alphabetic; +					c = lexc(); +					alphabetic = (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')); +					if (token_len == 0) { +						add_token(c); +						if (!alphabetic) +							break; +					} else { +						if (alphabetic) +							add_token(c); +						else { +							lex_unget(c); +							break; +						} +					} +				} +				end_token(); +				if (token_len == 1) +					token_int = token_string[0]; +				else if (!strcmp(token_string, "space")) +					token_int = ' '; +				else if (!strcmp(token_string, "newline")) +					token_int = '\n'; +				else if (!strcmp(token_string, "tab")) +					token_int = '\t'; +				else if (!strcmp(token_string, "return")) +					token_int = '\r'; +				else if (!strcmp(token_string, "formfeed")) +					token_int = '\f'; +				else { +					ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string); +					continue; +				} +				return NUM; +			} +		} +		if (lex_class & STRINGC) { +			for (;;) { +				c = lexc(); +				if (lex_class & BACKSLASH) +					c = lex_quoted(); +				if (lex_class & (STRINGC|ENDOFFILE)) { +					end_token(); +					return STRING; +				} +				add_token(c); +			} +		} +		if (lex_class & PRINTABLE) { +			int	isfloat; +			int	hasdigit; +			int	isneg; +			int	isint; +			int	epos; + +			isfloat = 1; +			isint = 1; +			hasdigit = 0; +			token_int = 0; +			isneg = 0; +			epos = 0; +			for (;;) { +				if (!(lex_class & NUMBER)) { +					isint = 0; +					isfloat = 0; +				} else { +					if (!(lex_class & INTEGER)) +						isint = 0; + 					if (token_len != epos && +					    (lex_class & SIGN)) +					{ +						isint = 0; +						isfloat = 0; +					} +					if (c == '-') +						isneg = 1; +					if (c == '.' && epos != 0) +						isfloat = 0; +					if (c == 'e' || c == 'E') { +						if (token_len == 0) +							isfloat = 0; +						else +							epos = token_len + 1; +					} +					if (lex_class & DIGIT) { +						hasdigit = 1; +						if (isint) +							token_int = token_int * 10 + c - '0'; +					} +				} +				add_token (c); +				c = lexc (); +				if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { +					unsigned int u; +//					if (lex_class & ENDOFFILE) +//						clearerr (f); +					lex_unget(c); +					end_token (); +					if (isint && hasdigit) { +						if (isneg) +							token_int = -token_int; +						return NUM; +					} +					if (isfloat && hasdigit) { +						token_float = strtof(token_string, NULL); +						return FLOAT; +					} +					for (u = 0; u < NUM_NAMED_FLOATS; u++) +						if (!strcmp(namedfloats[u].name, token_string)) { +							token_float = namedfloats[u].value; +							return FLOAT; +						} +					return NAME; +				} +			} +		} +	} +} + +static inline int lex(void) +{ +	int	parse_token = _lex(); +	RDBGI("token %d (%s)\n", parse_token, token_string); +	return parse_token; +} + +static int parse_token; + +struct ao_scheme_cons	*ao_scheme_read_cons; +struct ao_scheme_cons	*ao_scheme_read_cons_tail; +struct ao_scheme_cons	*ao_scheme_read_stack; + +#define READ_IN_QUOTE	0x01 +#define READ_SAW_DOT	0x02 +#define READ_DONE_DOT	0x04 + +static int +push_read_stack(int cons, int read_state) +{ +	RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); +	RDBG_IN(); +	if (cons) { +		ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), +						       ao_scheme__cons(ao_scheme_int_poly(read_state), +								     ao_scheme_cons_poly(ao_scheme_read_stack))); +		if (!ao_scheme_read_stack) +			return 0; +	} +	ao_scheme_read_cons = NULL; +	ao_scheme_read_cons_tail = NULL; +	return 1; +} + +static int +pop_read_stack(int cons) +{ +	int	read_state = 0; +	if (cons) { +		ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); +		ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); +		read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); +		ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); +		for (ao_scheme_read_cons_tail = ao_scheme_read_cons; +		     ao_scheme_read_cons_tail && ao_scheme_read_cons_tail->cdr; +		     ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr)) +			; +	} else { +		ao_scheme_read_cons = 0; +		ao_scheme_read_cons_tail = 0; +		ao_scheme_read_stack = 0; +	} +	RDBG_OUT(); +	RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); +	return read_state; +} + +ao_poly +ao_scheme_read(void) +{ +	struct ao_scheme_atom	*atom; +	char			*string; +	int			cons; +	int			read_state; +	ao_poly			v = AO_SCHEME_NIL; + +	cons = 0; +	read_state = 0; +	ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; +	for (;;) { +		parse_token = lex(); +		while (parse_token == OPEN) { +			if (!push_read_stack(cons, read_state)) +				return AO_SCHEME_NIL; +			cons++; +			read_state = 0; +			parse_token = lex(); +		} + +		switch (parse_token) { +		case END: +		default: +			if (cons) +				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; +		case FLOAT: +			v = ao_scheme_float_get(token_float); +			break; +		case BOOL: +			if (token_string[0] == 't') +				v = _ao_scheme_bool_true; +			else +				v = _ao_scheme_bool_false; +			break; +		case STRING: +			string = ao_scheme_string_copy(token_string); +			if (string) +				v = ao_scheme_string_poly(string); +			else +				v = AO_SCHEME_NIL; +			break; +		case QUOTE: +		case QUASIQUOTE: +		case UNQUOTE: +		case UNQUOTE_SPLICING: +			if (!push_read_stack(cons, read_state)) +				return AO_SCHEME_NIL; +			cons++; +			read_state = READ_IN_QUOTE; +			switch (parse_token) { +			case QUOTE: +				v = _ao_scheme_atom_quote; +				break; +			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; +			} +			break; +		case CLOSE: +			if (!cons) { +				v = AO_SCHEME_NIL; +				break; +			} +			v = ao_scheme_cons_poly(ao_scheme_read_cons); +			--cons; +			read_state = pop_read_stack(cons); +			break; +		case DOT: +			if (!cons) { +				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 (!cons) +				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); +			--cons; +			read_state = pop_read_stack(cons); +		} +	} +	return v; +} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h new file mode 100644 index 00000000..e9508835 --- /dev/null +++ b/src/scheme/ao_scheme_read.h @@ -0,0 +1,58 @@ +/* + * 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 +# define QUASIQUOTE		5 +# define UNQUOTE		6 +# define UNQUOTE_SPLICING	7 +# define STRING			8 +# define NUM			9 +# define FLOAT			10 +# define DOT			11 +# define BOOL			12 + +/* + * character classes + */ + +# define PRINTABLE	0x0001	/* \t \n ' ' - ~ */ +# define SPECIAL	0x0002	/* ( [ { ) ] } ' ` , */ +# define DOTC		0x0004	/* . */ +# define WHITE		0x0008	/* ' ' \t \n */ +# define DIGIT		0x0010	/* [0-9] */ +# define SIGN		0x0020	/* +- */ +# define FLOATC		0x0040	/* . e E */ +# define ENDOFFILE	0x0080	/* end of file */ +# define COMMENT	0x0100	/* ; */ +# define IGNORE		0x0200	/* \0 - ' ' */ +# define BACKSLASH	0x0400	/* \ */ +# define STRINGC	0x0800	/* " */ +# define POUND		0x1000	/* # */ + +# define NOTNAME	(STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define INTEGER	(DIGIT|SIGN) +# define NUMBER		(INTEGER|FLOATC) + +#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c new file mode 100644 index 00000000..9dbce5f2 --- /dev/null +++ b/src/scheme/ao_scheme_rep.c @@ -0,0 +1,36 @@ +/* + * 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(void) +{ +	ao_poly	in, out = AO_SCHEME_NIL; +	for(;;) { +		in = ao_scheme_read(); +		if (in == _ao_scheme_atom_eof) +			break; +		out = ao_scheme_eval(in); +		if (ao_scheme_exception) { +			if (ao_scheme_exception & AO_SCHEME_EXIT) +				break; +			ao_scheme_exception = 0; +		} else { +			ao_scheme_poly_write(out); +			putchar ('\n'); +		} +	} +	return out; +} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c new file mode 100644 index 00000000..af9345b8 --- /dev/null +++ b/src/scheme/ao_scheme_save.c @@ -0,0 +1,77 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +ao_poly +ao_scheme_do_save(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) +		return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE +	struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + +	ao_scheme_collect(AO_SCHEME_COLLECT_FULL); +	os->atoms = ao_scheme_atom_poly(ao_scheme_atoms); +	os->globals = ao_scheme_frame_poly(ao_scheme_frame_global); +	os->const_checksum = ao_scheme_const_checksum; +	os->const_checksum_inv = (uint16_t) ~ao_scheme_const_checksum; + +	if (ao_scheme_os_save()) +		return _ao_scheme_bool_true; +#endif +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_restore(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) +		return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE +	struct ao_scheme_os_save save; +	struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + +	if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) +		return ao_scheme_error(AO_SCHEME_INVALID, "header restore failed"); + +	if (save.const_checksum != ao_scheme_const_checksum || +	    save.const_checksum_inv != (uint16_t) ~ao_scheme_const_checksum) +	{ +		return ao_scheme_error(AO_SCHEME_INVALID, "image is corrupted or stale"); +	} + +	if (ao_scheme_os_restore()) { + +		ao_scheme_atoms = ao_scheme_poly_atom(os->atoms); +		ao_scheme_frame_global = ao_scheme_poly_frame(os->globals); + +		/* Clear the eval global variabls */ +		ao_scheme_eval_clear_globals(); + +		/* Reset the allocator */ +		ao_scheme_top = AO_SCHEME_POOL; +		ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + +		/* Re-create the evaluator stack */ +		if (!ao_scheme_eval_restart()) +			return _ao_scheme_bool_false; + +		return _ao_scheme_bool_true; +	} +#endif +	return _ao_scheme_bool_false; +} diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c new file mode 100644 index 00000000..d19dd6d6 --- /dev/null +++ b/src/scheme/ao_scheme_stack.c @@ -0,0 +1,280 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +const struct ao_scheme_type ao_scheme_stack_type; + +static int +stack_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_stack); +} + +static void +stack_mark(void *addr) +{ +	struct ao_scheme_stack	*stack = addr; +	for (;;) { +		ao_scheme_poly_mark(stack->sexprs, 0); +		ao_scheme_poly_mark(stack->values, 0); +		/* no need to mark values_tail */ +		ao_scheme_poly_mark(stack->frame, 0); +		ao_scheme_poly_mark(stack->list, 0); +		stack = ao_scheme_poly_stack(stack->prev); +		if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) +			break; +	} +} + +static void +stack_move(void *addr) +{ +	struct ao_scheme_stack	*stack = addr; + +	while (stack) { +		struct ao_scheme_stack	*prev; +		int			ret; +		(void) ao_scheme_poly_move(&stack->sexprs, 0); +		(void) ao_scheme_poly_move(&stack->values, 0); +		(void) ao_scheme_poly_move(&stack->values_tail, 0); +		(void) ao_scheme_poly_move(&stack->frame, 0); +		(void) ao_scheme_poly_move(&stack->list, 0); +		prev = ao_scheme_poly_stack(stack->prev); +		if (!prev) +			break; +		ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); +		if (prev != ao_scheme_poly_stack(stack->prev)) +			stack->prev = ao_scheme_stack_poly(prev); +		if (ret) +			break; +		stack = prev; +	} +} + +const struct ao_scheme_type ao_scheme_stack_type = { +	.size = stack_size, +	.mark = stack_mark, +	.move = stack_move, +	.name = "stack" +}; + +struct ao_scheme_stack		*ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack) +{ +	stack->state = eval_sexpr; +	stack->sexprs = AO_SCHEME_NIL; +	stack->values = AO_SCHEME_NIL; +	stack->values_tail = AO_SCHEME_NIL; +} + +static struct ao_scheme_stack * +ao_scheme_stack_new(void) +{ +	struct ao_scheme_stack *stack; + +	if (ao_scheme_stack_free_list) { +		stack = ao_scheme_stack_free_list; +		ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); +	} else { +		stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); +		if (!stack) +			return 0; +		stack->type = AO_SCHEME_STACK; +	} +	ao_scheme_stack_reset(stack); +	return stack; +} + +int +ao_scheme_stack_push(void) +{ +	struct ao_scheme_stack	*stack; + +	stack = ao_scheme_stack_new(); + +	if (!stack) +		return 0; + +	stack->prev = ao_scheme_stack_poly(ao_scheme_stack); +	stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); +	stack->list = AO_SCHEME_NIL; + +	ao_scheme_stack = stack; + +	DBGI("stack push\n"); +	DBG_FRAMES(); +	DBG_IN(); +	return 1; +} + +void +ao_scheme_stack_pop(void) +{ +	ao_poly			prev; +	struct ao_scheme_frame	*prev_frame; + +	if (!ao_scheme_stack) +		return; +	prev = ao_scheme_stack->prev; +	if (!ao_scheme_stack_marked(ao_scheme_stack)) { +		ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); +		ao_scheme_stack_free_list = ao_scheme_stack; +	} + +	ao_scheme_stack = ao_scheme_poly_stack(prev); +	prev_frame = ao_scheme_frame_current; +	if (ao_scheme_stack) +		ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); +	else +		ao_scheme_frame_current = NULL; +	if (ao_scheme_frame_current != prev_frame) +		ao_scheme_frame_free(prev_frame); +	DBG_OUT(); +	DBGI("stack pop\n"); +	DBG_FRAMES(); +} + +void +ao_scheme_stack_clear(void) +{ +	ao_scheme_stack = NULL; +	ao_scheme_frame_current = NULL; +	ao_scheme_v = AO_SCHEME_NIL; +} + +void +ao_scheme_stack_write(ao_poly poly) +{ +	struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + +	while (s) { +		if (s->type & AO_SCHEME_STACK_PRINT) { +			printf("[recurse...]"); +			return; +		} +		s->type |= AO_SCHEME_STACK_PRINT; +		printf("\t[\n"); +		printf("\t\texpr:   "); ao_scheme_poly_write(s->list); printf("\n"); +		printf("\t\tstate:  %s\n", ao_scheme_state_names[s->state]); +		ao_scheme_error_poly ("values: ", s->values, s->values_tail); +		ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); +		ao_scheme_error_frame(2, "frame:  ", ao_scheme_poly_frame(s->frame)); +		printf("\t]\n"); +		s->type &= ~AO_SCHEME_STACK_PRINT; +		s = ao_scheme_poly_stack(s->prev); +	} +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_scheme_stack * +ao_scheme_stack_copy(struct ao_scheme_stack *old) +{ +	struct ao_scheme_stack *new = NULL; +	struct ao_scheme_stack *n, *prev = NULL; + +	while (old) { +		ao_scheme_stack_stash(0, old); +		ao_scheme_stack_stash(1, new); +		ao_scheme_stack_stash(2, prev); +		n = ao_scheme_stack_new(); +		prev = ao_scheme_stack_fetch(2); +		new = ao_scheme_stack_fetch(1); +		old = ao_scheme_stack_fetch(0); +		if (!n) +			return NULL; + +		ao_scheme_stack_mark(old); +		ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); +		*n = *old; + +		if (prev) +			prev->prev = ao_scheme_stack_poly(n); +		else +			new = n; +		prev = n; + +		old = ao_scheme_poly_stack(old->prev); +	} +	return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_scheme_stack_eval(void) +{ +	struct ao_scheme_stack	*new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); +	if (!new) +		return AO_SCHEME_NIL; + +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_stack->values); + +	if (!cons || !cons->cdr) +		return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); + +	new->state = eval_val; + +	ao_scheme_stack = new; +	ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + +	return ao_scheme_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_scheme_do_call_cc(struct ao_scheme_cons *cons) +{ +	struct ao_scheme_stack	*new; +	ao_poly			v; + +	/* Make sure the single parameter is a lambda */ +	if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0)) +		return AO_SCHEME_NIL; + +	/* go get the lambda */ +	ao_scheme_v = ao_scheme_arg(cons, 0); + +	/* Note that the whole call chain now has +	 * a reference to it which may escape +	 */ +	new = ao_scheme_stack_copy(ao_scheme_stack); +	if (!new) +		return AO_SCHEME_NIL; + +	/* re-fetch cons after the allocation */ +	cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); + +	/* Reset the arg list to the current stack, +	 * and call the lambda +	 */ + +	cons->car = ao_scheme_stack_poly(new); +	cons->cdr = AO_SCHEME_NIL; +	v = ao_scheme_lambda_eval(); +	ao_scheme_stack->sexprs = v; +	ao_scheme_stack->state = eval_begin; +	return AO_SCHEME_NIL; +} diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c new file mode 100644 index 00000000..e25306cb --- /dev/null +++ b/src/scheme/ao_scheme_string.c @@ -0,0 +1,161 @@ +/* + * 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) +{ +	if (!addr) +		return 0; +	return strlen(addr) + 1; +} + +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", +}; + +char * +ao_scheme_string_copy(char *a) +{ +	int	alen = strlen(a); + +	ao_scheme_string_stash(0, a); +	char	*r = ao_scheme_alloc(alen + 1); +	a = ao_scheme_string_fetch(0); +	if (!r) +		return NULL; +	strcpy(r, a); +	return r; +} + +char * +ao_scheme_string_cat(char *a, char *b) +{ +	int	alen = strlen(a); +	int	blen = strlen(b); + +	ao_scheme_string_stash(0, a); +	ao_scheme_string_stash(1, b); +	char	*r = ao_scheme_alloc(alen + blen + 1); +	a = ao_scheme_string_fetch(0); +	b = ao_scheme_string_fetch(1); +	if (!r) +		return NULL; +	strcpy(r, a); +	strcpy(r+alen, b); +	return r; +} + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons) +{ +	int	len = ao_scheme_cons_length(cons); +	ao_scheme_cons_stash(0, cons); +	char	*r = ao_scheme_alloc(len + 1); +	cons = ao_scheme_cons_fetch(0); +	char	*s = r; + +	while (cons) { +		if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) +			return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); +		*s++ = ao_scheme_poly_integer(cons->car); +		cons = ao_scheme_poly_cons(cons->cdr); +	} +	*s++ = 0; +	return ao_scheme_string_poly(r); +} + +ao_poly +ao_scheme_string_unpack(char *a) +{ +	struct ao_scheme_cons	*cons = NULL, *tail = NULL; +	int			c; +	int			i; + +	for (i = 0; (c = a[i]); i++) { +		ao_scheme_cons_stash(0, cons); +		ao_scheme_cons_stash(1, tail); +		ao_scheme_string_stash(0, a); +		struct ao_scheme_cons	*n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); +		a = ao_scheme_string_fetch(0); +		cons = ao_scheme_cons_fetch(0); +		tail = ao_scheme_cons_fetch(1); + +		if (!n) { +			cons = NULL; +			break; +		} +		if (tail) +			tail->cdr = ao_scheme_cons_poly(n); +		else +			cons = n; +		tail = n; +	} +	return ao_scheme_cons_poly(cons); +} + +void +ao_scheme_string_write(ao_poly p) +{ +	char	*s = ao_scheme_poly_string(p); +	char	c; + +	putchar('"'); +	while ((c = *s++)) { +		switch (c) { +		case '\n': +			printf ("\\n"); +			break; +		case '\r': +			printf ("\\r"); +			break; +		case '\t': +			printf ("\\t"); +			break; +		default: +			if (c < ' ') +				printf("\\%03o", c); +			else +				putchar(c); +			break; +		} +	} +	putchar('"'); +} + +void +ao_scheme_string_display(ao_poly p) +{ +	char	*s = ao_scheme_poly_string(p); +	char	c; + +	while ((c = *s++)) +		putchar(c); +} diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore new file mode 100644 index 00000000..bcd57242 --- /dev/null +++ b/src/scheme/make-const/.gitignore @@ -0,0 +1 @@ +ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile new file mode 100644 index 00000000..caf7acbe --- /dev/null +++ b/src/scheme/make-const/Makefile @@ -0,0 +1,26 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +SRCS=$(SCHEME_SRCS) ao_scheme_make_const.c +HDRS=$(SCHEME_HDRS) ao_scheme_os.h + +OBJS=$(SRCS:.c=.o) + +CC=cc +CFLAGS=-DAO_SCHEME_MAKE_CONST -O0 -g -I. -Wall -Wextra + +.c.o: +	$(CC) -c $(CFLAGS) $< -o $@ + +all: ao_scheme_make_const + +ao_scheme_make_const: $(OBJS) +	$(CC) $(CFLAGS) -o $@ $^ -lm + +clean: +	rm -f $(OBJS) ao_scheme_make_const + +$(OBJS): $(SCHEME_HDRS) diff --git a/src/scheme/make-const/ao_scheme_os.h b/src/scheme/make-const/ao_scheme_os.h new file mode 100644 index 00000000..f06bbbb1 --- /dev/null +++ b/src/scheme/make-const/ao_scheme_os.h @@ -0,0 +1,63 @@ +/* + * 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 new file mode 100644 index 00000000..3cdae594 --- /dev/null +++ b/src/scheme/test/.gitignore @@ -0,0 +1 @@ +ao_scheme_test diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h new file mode 100644 index 00000000..09a945bc --- /dev/null +++ b/src/scheme/test/ao_scheme_os.h @@ -0,0 +1,68 @@ +/* + * 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	16384 +#define AO_SCHEME_SAVE		1 +#define DBG_MEM_STATS		1 + +extern int ao_scheme_getc(void); + +static inline void +ao_scheme_os_flush() { +	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/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c new file mode 100644 index 00000000..15c71203 --- /dev/null +++ b/src/scheme/test/ao_scheme_test.c @@ -0,0 +1,139 @@ +/* + * 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> + +static FILE *ao_scheme_file; +static int newline = 1; + +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; +} + +int +ao_scheme_getc(void) +{ +	int c; + +	if (ao_scheme_file) +		return getc(ao_scheme_file); + +	if (newline) { +		if (ao_scheme_read_stack) +			printf("+ "); +		else +			printf("> "); +		newline = 0; +	} +	c = getchar(); +	if (c == '\n') +		newline = 1; +	return c; +} + +int +main (int argc, char **argv) +{ +	(void) argc; + +	while (*++argv) { +		ao_scheme_file = fopen(*argv, "r"); +		if (!ao_scheme_file) { +			perror(*argv); +			exit(1); +		} +		ao_scheme_read_eval_print(); +		fclose(ao_scheme_file); +		ao_scheme_file = NULL; +	} +	ao_scheme_read_eval_print(); + +	printf ("collects: full: %d incremental %d\n", +		ao_scheme_collects[AO_SCHEME_COLLECT_FULL], +		ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + +	printf ("freed: full %d incremental %d\n", +		ao_scheme_freed[AO_SCHEME_COLLECT_FULL], +		ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); + +	printf("loops: full %d incremental %d\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]); +} diff --git a/src/scheme/test/hanoi.scheme b/src/scheme/test/hanoi.scheme new file mode 100644 index 00000000..c4ae7378 --- /dev/null +++ b/src/scheme/test/hanoi.scheme @@ -0,0 +1,174 @@ +; +; 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 +  ) | 
