From 16061947d4376b41e596d87f97ec53ec29d17644 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 6 Jan 2018 17:29:10 -0800 Subject: [PATCH] altos/scheme: Add ports. Split scheme code up. And lots of other changes, including freeing unreferenced atoms. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 10 +- src/lambdakey-v1.0/ao_lambdakey.c | 4 +- src/lambdakey-v1.0/ao_lambdakey_const.scheme | 30 +- src/lambdakey-v1.0/ao_pins.h | 19 +- src/lambdakey-v1.0/ao_scheme_os.h | 2 + src/scheme/Makefile-inc | 11 +- src/scheme/ao_scheme.h | 283 ++++-- src/scheme/ao_scheme_advanced_syntax.scheme | 402 ++++++++ src/scheme/ao_scheme_atom.c | 188 +++- src/scheme/ao_scheme_basic_syntax.scheme | 437 +++++++++ src/scheme/ao_scheme_bool.c | 12 +- src/scheme/ao_scheme_builtin.c | 944 +++++++------------ src/scheme/ao_scheme_builtin.txt | 21 +- src/scheme/ao_scheme_char.scheme | 80 ++ src/scheme/ao_scheme_cons.c | 184 +++- src/scheme/ao_scheme_const.scheme | 60 +- src/scheme/ao_scheme_do.scheme | 34 + src/scheme/ao_scheme_error.c | 32 +- src/scheme/ao_scheme_eval.c | 15 +- src/scheme/ao_scheme_finish.scheme | 17 + src/scheme/ao_scheme_float.c | 53 +- src/scheme/ao_scheme_frame.c | 65 +- src/scheme/ao_scheme_int.c | 63 +- src/scheme/ao_scheme_lambda.c | 12 +- src/scheme/ao_scheme_make_builtin | 19 + src/scheme/ao_scheme_make_const.c | 50 +- src/scheme/ao_scheme_mem.c | 72 +- src/scheme/ao_scheme_poly.c | 11 +- src/scheme/ao_scheme_port.c | 193 ++++ src/scheme/ao_scheme_port.scheme | 39 + src/scheme/ao_scheme_read.c | 356 ++++--- src/scheme/ao_scheme_read.h | 8 +- src/scheme/ao_scheme_rep.c | 12 +- src/scheme/ao_scheme_save.c | 21 +- src/scheme/ao_scheme_stack.c | 53 +- src/scheme/ao_scheme_string.c | 257 +++-- src/scheme/ao_scheme_string.scheme | 4 + src/scheme/ao_scheme_vector.c | 195 +++- src/scheme/test/Makefile | 2 +- src/scheme/test/ao_scheme_os.h | 14 - src/scheme/test/ao_scheme_test.c | 99 +- src/scheme/test/hanoi.scheme | 3 + src/scheme/tiny-test/Makefile | 6 +- src/scheme/tiny-test/ao_scheme_os.h | 14 - src/scheme/tiny-test/ao_scheme_test.c | 35 +- 45 files changed, 3129 insertions(+), 1312 deletions(-) create mode 100644 src/scheme/ao_scheme_advanced_syntax.scheme create mode 100644 src/scheme/ao_scheme_basic_syntax.scheme create mode 100644 src/scheme/ao_scheme_char.scheme create mode 100644 src/scheme/ao_scheme_do.scheme create mode 100644 src/scheme/ao_scheme_finish.scheme create mode 100644 src/scheme/ao_scheme_port.c create mode 100644 src/scheme/ao_scheme_port.scheme mode change 100644 => 100755 src/scheme/test/hanoi.scheme diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index bffe7d4f..cfa009bb 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -7,6 +7,9 @@ include ../stmf0/Makefile.defs include ../scheme/Makefile-inc +vpath %.scheme ../scheme +vpath ao_scheme_make_const ../scheme/make-const + NEWLIB_FULL=-lm -lc -lgcc LIBS=$(NEWLIB_FULL) @@ -30,7 +33,6 @@ ALTOS_SRC = \ ao_product.c \ ao_cmd.c \ ao_notask.c \ - ao_led.c \ ao_stdio.c \ ao_stdio_newlib.c \ ao_panic.c \ @@ -49,7 +51,7 @@ LDFLAGS=$(CFLAGS) -L$(TOPDIR)/stmf0 -Wl,-Tlambda.ld MAP=$(PROG).map NEWLIB=/local/newlib-mini -MAPFILE=-Wl,-M=$(MAP) +MAPFILE=-Wl,-Map=$(MAP) LDFLAGS=-L../stmf0 -L$(NEWLIB)/arm-none-eabi/lib/thumb/v6-m/ -Wl,-Tlambda.ld $(MAPFILE) -nostartfiles AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB @@ -70,8 +72,8 @@ $(OBJ): $(INC) ao_product.h: ao-make-product.5c ../Version $(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ -ao_scheme_const.h: ../scheme/make-const/ao_scheme_make_const ao_lambdakey_const.scheme - ../scheme/make-const/ao_scheme_make_const -d FLOAT,VECTOR,QUASI,BIGINT -o $@ ao_lambdakey_const.scheme +ao_scheme_const.h: ao_scheme_make_const ao_scheme_basic_syntax.scheme ao_scheme_finish.scheme + $^ -o $@ -d GPIO,FLOAT,VECTOR,QUASI,BIGINT,POSIX,PORT,SAVE,UNDEF load: $(PROG) stm-load $(PROG) diff --git a/src/lambdakey-v1.0/ao_lambdakey.c b/src/lambdakey-v1.0/ao_lambdakey.c index 73962e29..2bd626f1 100644 --- a/src/lambdakey-v1.0/ao_lambdakey.c +++ b/src/lambdakey-v1.0/ao_lambdakey.c @@ -16,7 +16,7 @@ #include static void scheme_cmd() { - ao_scheme_read_eval_print(); + ao_scheme_read_eval_print(stdin, stdout, true); } static const struct ao_cmds blink_cmds[] = { @@ -27,7 +27,9 @@ static const struct ao_cmds blink_cmds[] = { void main(void) { +#ifdef LEDS_AVAILABLE ao_led_init(LEDS_AVAILABLE); +#endif ao_clock_init(); ao_timer_init(); ao_usb_init(); diff --git a/src/lambdakey-v1.0/ao_lambdakey_const.scheme b/src/lambdakey-v1.0/ao_lambdakey_const.scheme index a912b8ae..a37e1a2b 100644 --- a/src/lambdakey-v1.0/ao_lambdakey_const.scheme +++ b/src/lambdakey-v1.0/ao_lambdakey_const.scheme @@ -185,7 +185,7 @@ ; simple math operators -(define zero? (macro (value) (list eqv? value 0))) +(define zero? (macro (value) (list eq? value 0))) (zero? 1) (zero? 0) @@ -247,13 +247,6 @@ (odd? -1) -(define (list-tail a b) - (if (zero? b) - a - (list-tail (cdr a) (- b 1)) - ) - ) - (define (list-ref a b) (car (list-tail a b)) ) @@ -280,7 +273,7 @@ ; ; (let* ((x 1) (y)) (set! y (+ x 1)) y) -(define let* +(define letrec (macro (a . b) ; @@ -301,7 +294,8 @@ ; expressions to evaluate (define (_v a b) - (cond ((null? a) b) (else + (cond ((null? a) b) + (else (cons (list set (list quote @@ -330,9 +324,10 @@ ) ) -(let* ((a 1) (y a)) (+ a y)) +(letrec ((a 1) (y a)) (+ a y)) -(define let let*) +(define let letrec) +(define let* letrec) ; recursive equality (define (equal? a b) @@ -376,18 +371,21 @@ (memq '(2) '((1) (2) (3))) -(define (_as a b t?) +(define (assoc a b . t?) + (if (null? t?) + (set! t? equal?) + (set! t? (car t?)) + ) (if (null? b) #f (if (t? a (caar b)) (car b) - (_as a (cdr b) t?) + (assoc a (cdr b) t?) ) ) ) -(define (assq a b) (_as a b eq?)) -(define (assoc a b) (_as a b equal?)) +(define (assq a b) (assoc a b eq?)) (assq 'a '((a 1) (b 2) (c 3))) (assoc '(c) '((a 1) (b 2) ((c) 3))) diff --git a/src/lambdakey-v1.0/ao_pins.h b/src/lambdakey-v1.0/ao_pins.h index 48b9db16..f330213d 100644 --- a/src/lambdakey-v1.0/ao_pins.h +++ b/src/lambdakey-v1.0/ao_pins.h @@ -19,23 +19,34 @@ #ifndef _AO_PINS_H_ #define _AO_PINS_H_ +#define fprintf(file, ...) ({ (void) (file); printf(__VA_ARGS__); }) +#undef putc +#define putc(c,file) ({ (void) (file); putchar(c); }) +#define fputs(s,file) ({ (void) (file); printf("%s", s); }) +#define puts(s) ({ printf("%s\n", s); }) +#undef getc +#define getc(file) ({ (void) (file); getchar(); }) + #define HAS_TASK 0 #define HAS_AO_DELAY 1 +#if 0 #define LED_PORT_ENABLE STM_RCC_AHBENR_IOPBEN #define LED_PORT (&stm_gpiob) #define LED_PIN_RED 4 #define AO_LED_RED (1 << LED_PIN_RED) #define AO_LED_PANIC AO_LED_RED +#define LEDS_AVAILABLE (AO_LED_RED) +#endif + #define AO_CMD_LEN 128 -#define AO_LISP_POOL_TOTAL 3072 -#define AO_LISP_SAVE 1 +#define AO_LISP_POOL 5120 #define AO_STACK_SIZE 1024 +#if 0 /* need HSI active to write to flash */ #define AO_NEED_HSI 1 - -#define LEDS_AVAILABLE (AO_LED_RED) +#endif #define AO_POWER_MANAGEMENT 0 diff --git a/src/lambdakey-v1.0/ao_scheme_os.h b/src/lambdakey-v1.0/ao_scheme_os.h index b3080f31..5641b476 100644 --- a/src/lambdakey-v1.0/ao_scheme_os.h +++ b/src/lambdakey-v1.0/ao_scheme_os.h @@ -56,11 +56,13 @@ ao_scheme_abort(void) ao_panic(1); } +#ifdef LEDS_AVAILABLE static inline void ao_scheme_os_led(int led) { ao_led_set(led); } +#endif #define AO_SCHEME_JIFFIES_PER_SECOND AO_HERTZ diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc index db5083df..ed3f7f5f 100644 --- a/src/scheme/Makefile-inc +++ b/src/scheme/Makefile-inc @@ -16,7 +16,8 @@ SCHEME_SRCS=\ ao_scheme_save.c \ ao_scheme_stack.c \ ao_scheme_error.c \ - ao_scheme_vector.c + ao_scheme_vector.c \ + ao_scheme_port.c SCHEME_HDRS=\ ao_scheme.h \ @@ -25,6 +26,10 @@ SCHEME_HDRS=\ ao_scheme_builtin.h SCHEME_SCHEME=\ - ao_scheme_const.scheme \ + ao_scheme_basic_syntax.scheme \ + ao_scheme_advanced_syntax.scheme \ ao_scheme_vector.scheme \ - ao_scheme_string.scheme + ao_scheme_string.scheme \ + ao_scheme_char.scheme \ + ao_scheme_port.scheme \ + ao_scheme_finish.scheme diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 68803462..9ce239a6 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -32,10 +32,10 @@ #include #include #include +#include #define AO_SCHEME_BUILTIN_FEATURES #include "ao_scheme_builtin.h" #undef AO_SCHEME_BUILTIN_FEATURES -#include #ifndef __BYTE_ORDER #include #endif @@ -43,7 +43,29 @@ typedef uint16_t ao_poly; typedef int16_t ao_signed_poly; -#if AO_SCHEME_SAVE +#ifdef AO_SCHEME_MAKE_CONST +#define AO_SCHEME_POOL_CONST 32764 +extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern((char *) n)) +#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) + +#define _ao_scheme_bool_true _bool(1) +#define _ao_scheme_bool_false _bool(0) + +#define _ao_scheme_atom_eof _atom("eof") +#define _ao_scheme_atom_else _atom("else") + +#define AO_SCHEME_BUILTIN_ATOMS +#include "ao_scheme_builtin.h" + +#else + +#include "ao_scheme_const.h" + +#ifdef AO_SCHEME_FEATURE_SAVE struct ao_scheme_os_save { ao_poly atoms; @@ -53,7 +75,7 @@ struct ao_scheme_os_save { }; #ifndef AO_SCHEME_POOL_TOTAL -#error Must define AO_SCHEME_POOL_TOTAL for AO_SCHEME_SAVE +#error Must define AO_SCHEME_POOL_TOTAL for AO_SCHEME_FEATURE_SAVE #endif #define AO_SCHEME_POOL_EXTRA (sizeof(struct ao_scheme_os_save)) @@ -67,29 +89,8 @@ ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); int ao_scheme_os_restore(void); +#endif /* AO_SCHEME_FEATURE_SAVE */ -#endif - -#ifdef AO_SCHEME_MAKE_CONST -#define AO_SCHEME_POOL_CONST 32764 -extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); -#define ao_scheme_pool ao_scheme_const -#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST - -#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern((char *) n)) -#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) - -#define _ao_scheme_bool_true _bool(1) -#define _ao_scheme_bool_false _bool(0) - -#define _ao_scheme_atom_eof _atom("eof") -#define _ao_scheme_atom_else _atom("else") - -#define AO_SCHEME_BUILTIN_ATOMS -#include "ao_scheme_builtin.h" - -#else -#include "ao_scheme_const.h" #ifndef AO_SCHEME_POOL #error Must define AO_SCHEME_POOL #endif @@ -131,7 +132,13 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #else #define _AO_SCHEME_VECTOR _AO_SCHEME_FLOAT #endif -#define AO_SCHEME_NUM_TYPE (_AO_SCHEME_VECTOR+1) +#ifdef AO_SCHEME_FEATURE_PORT +#define AO_SCHEME_PORT 14 +#define _AO_SCHEME_PORT AO_SCHEME_PORT +#else +#define _AO_SCHEME_PORT _AO_SCHEME_VECTOR +#endif +#define AO_SCHEME_NUM_TYPE (_AO_SCHEME_PORT+1) /* Leave two bits for types to use as they please */ #define AO_SCHEME_OTHER_TYPE_MASK 0x3f @@ -146,7 +153,8 @@ extern uint16_t ao_scheme_top; #define AO_SCHEME_UNDEFINED 0x08 #define AO_SCHEME_REDEFINED 0x10 #define AO_SCHEME_EOF 0x20 -#define AO_SCHEME_EXIT 0x40 +#define AO_SCHEME_FILEERROR 0x40 +#define AO_SCHEME_EXIT 0x80 extern uint8_t ao_scheme_exception; @@ -240,6 +248,15 @@ struct ao_scheme_vector { }; #endif +#ifdef AO_SCHEME_FEATURE_PORT +struct ao_scheme_port { + uint8_t type; + uint8_t stayopen; + ao_poly next; + FILE *file; +}; +#endif + #define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) #define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) @@ -551,6 +568,23 @@ ao_scheme_poly_vector(ao_poly poly) } #endif +#ifdef AO_SCHEME_FEATURE_PORT +static inline ao_poly +ao_scheme_port_poly(struct ao_scheme_port *v) +{ + return ao_scheme_poly(v, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_port * +ao_scheme_poly_port(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +extern ao_poly ao_scheme_stdin, ao_scheme_stdout, ao_scheme_stderr; + +#endif + /* memory functions */ extern uint64_t ao_scheme_collects[2]; @@ -561,6 +595,10 @@ extern uint64_t ao_scheme_loops[2]; int ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); +/* returns 1 if the object is marked */ +int +ao_scheme_marked(void *addr); + /* returns 1 if the object was already moved */ int ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); @@ -642,6 +680,18 @@ ao_scheme_vector_fetch(void) { } #endif +#ifdef AO_SCHEME_FEATURE_PORT +static inline void +ao_scheme_port_stash(struct ao_scheme_port *port) { + ao_scheme_poly_stash(ao_scheme_port_poly(port)); +} + +static inline struct ao_scheme_port * +ao_scheme_port_fetch(void) { + return ao_scheme_poly_port(ao_scheme_poly_fetch()); +} +#endif + static inline void ao_scheme_stack_stash(struct ao_scheme_stack *stack) { ao_scheme_poly_stash(ao_scheme_stack_poly(stack)); @@ -667,7 +717,7 @@ ao_scheme_frame_fetch(void) { extern const struct ao_scheme_type ao_scheme_bool_type; void -ao_scheme_bool_write(ao_poly v, bool write); +ao_scheme_bool_write(FILE *out, ao_poly v, bool write); #ifdef AO_SCHEME_MAKE_CONST extern struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; @@ -695,40 +745,25 @@ void ao_scheme_cons_free(struct ao_scheme_cons *cons); void -ao_scheme_cons_write(ao_poly, bool write); +ao_scheme_cons_write(FILE *out, ao_poly, bool write); int ao_scheme_cons_length(struct ao_scheme_cons *cons); -struct ao_scheme_cons * -ao_scheme_cons_copy(struct ao_scheme_cons *cons); - /* string */ extern const struct ao_scheme_type ao_scheme_string_type; -struct ao_scheme_string * -ao_scheme_string_copy(struct ao_scheme_string *a); - struct ao_scheme_string * ao_scheme_string_new(char *a); -struct ao_scheme_string * -ao_scheme_make_string(int32_t len, char fill); - struct ao_scheme_string * ao_scheme_atom_to_string(struct ao_scheme_atom *a); struct ao_scheme_string * ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b); -ao_poly -ao_scheme_string_pack(struct ao_scheme_cons *cons); - -ao_poly -ao_scheme_string_unpack(struct ao_scheme_string *a); - void -ao_scheme_string_write(ao_poly s, bool write); +ao_scheme_string_write(FILE *out, ao_poly s, bool write); /* atom */ extern const struct ao_scheme_type ao_scheme_atom_type; @@ -738,7 +773,7 @@ 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, bool write); +ao_scheme_atom_write(FILE *out, ao_poly a, bool write); struct ao_scheme_atom * ao_scheme_string_to_atom(struct ao_scheme_string *string); @@ -746,25 +781,28 @@ ao_scheme_string_to_atom(struct ao_scheme_string *string); struct ao_scheme_atom * ao_scheme_atom_intern(char *name); +void +ao_scheme_atom_check_references(void); + +void +ao_scheme_atom_move(void); + ao_poly * ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); ao_poly ao_scheme_atom_get(ao_poly atom); -ao_poly -ao_scheme_atom_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, bool write); +ao_scheme_int_write(FILE *out, ao_poly i, bool write); #ifdef AO_SCHEME_FEATURE_BIGINT int32_t -ao_scheme_poly_integer(ao_poly p, bool *fail); +ao_scheme_poly_integer(ao_poly p); ao_poly ao_scheme_integer_poly(int32_t i); @@ -776,14 +814,19 @@ ao_scheme_integer_typep(uint8_t t) } void -ao_scheme_bigint_write(ao_poly i, bool write); +ao_scheme_bigint_write(FILE *out, ao_poly i, bool write); extern const struct ao_scheme_type ao_scheme_bigint_type; #else -#define ao_scheme_poly_integer(a,b) ao_scheme_poly_int(a) -#define ao_scheme_integer_poly ao_scheme_int_poly +static inline int32_t ao_scheme_poly_integer(ao_poly poly) { + return ao_scheme_poly_int(poly); +} + +static inline ao_poly ao_scheme_integer_poly(int32_t i) { + return ao_scheme_int_poly(i); +} static inline int ao_scheme_integer_typep(uint8_t t) @@ -795,18 +838,14 @@ ao_scheme_integer_typep(uint8_t t) /* vector */ +#ifdef AO_SCHEME_FEATURE_VECTOR + void -ao_scheme_vector_write(ao_poly v, bool write); +ao_scheme_vector_write(FILE *OUT, ao_poly v, bool write); struct ao_scheme_vector * ao_scheme_vector_alloc(uint16_t length, ao_poly fill); -ao_poly -ao_scheme_vector_get(ao_poly v, ao_poly i); - -ao_poly -ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p); - struct ao_scheme_vector * ao_scheme_list_to_vector(struct ao_scheme_cons *cons); @@ -815,11 +854,66 @@ ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end); extern const struct ao_scheme_type ao_scheme_vector_type; +#endif /* AO_SCHEME_FEATURE_VECTOR */ + +/* port */ + +#ifdef AO_SCHEME_FEATURE_PORT + +void +ao_scheme_port_write(FILE *out, ao_poly v, bool write); + +struct ao_scheme_port * +ao_scheme_port_alloc(FILE *file, bool stayopen); + +void +ao_scheme_port_close(struct ao_scheme_port *port); + +void +ao_scheme_port_check_references(void); + +extern ao_poly ao_scheme_open_ports; + +static inline int +ao_scheme_port_getc(struct ao_scheme_port *port) +{ + if (port->file) + return getc(port->file); + return EOF; +} + +static inline int +ao_scheme_port_putc(struct ao_scheme_port *port, char c) +{ + if (port->file) + return putc(c, port->file); + return EOF; +} + +static inline int +ao_scheme_port_ungetc(struct ao_scheme_port *port, char c) +{ + if (port->file) + return ungetc(c, port->file); + return EOF; +} + +extern const struct ao_scheme_type ao_scheme_port_type; + +#endif /* AO_SCHEME_FEATURE_PORT */ + +#ifdef AO_SCHEME_FEATURE_POSIX + +void +ao_scheme_set_argv(char **argv); + +#endif + /* prim */ -void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p, bool write); +void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write); static inline void -ao_scheme_poly_write(ao_poly p, bool write) { (*ao_scheme_poly_write_func(p))(p, write); } +ao_scheme_poly_write(FILE *out, ao_poly p, bool write) { (*ao_scheme_poly_write_func(p))(out, p, write); } int ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); @@ -830,11 +924,13 @@ ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); /* eval */ +#ifdef AO_SCHEME_FEATURE_SAVE void ao_scheme_eval_clear_globals(void); int ao_scheme_eval_restart(void); +#endif ao_poly ao_scheme_eval(ao_poly p); @@ -847,14 +943,14 @@ ao_scheme_set_cond(struct ao_scheme_cons *cons); extern const struct ao_scheme_type ao_scheme_float_type; void -ao_scheme_float_write(ao_poly p, bool write); +ao_scheme_float_write(FILE *out, ao_poly p, bool write); ao_poly ao_scheme_float_get(float value); #endif #ifdef AO_SCHEME_FEATURE_FLOAT -static inline uint8_t +static inline bool ao_scheme_number_typep(uint8_t t) { return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); @@ -863,12 +959,35 @@ ao_scheme_number_typep(uint8_t t) #define ao_scheme_number_typep ao_scheme_integer_typep #endif +static inline bool +ao_scheme_is_integer(ao_poly poly) { + return ao_scheme_integer_typep(ao_scheme_poly_base_type(poly)); +} + +static inline bool +ao_scheme_is_number(ao_poly poly) { + return ao_scheme_number_typep(ao_scheme_poly_type(poly)); +} + /* builtin */ void -ao_scheme_builtin_write(ao_poly b, bool write); +ao_scheme_builtin_write(FILE *out, ao_poly b, bool write); + +ao_poly +ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons); extern const struct ao_scheme_type ao_scheme_builtin_type; +#define AO_SCHEME_ARG_OPTIONAL 0x100 +#define AO_SCHEME_ARG_NIL_OK 0x200 +#define AO_SCHEME_ARG_RET_POLY 0x400 +#define AO_SCHEME_ARG_END -1 +#define AO_SCHEME_POLY 0xff +#define AO_SCHEME_ARG_MASK 0xff + +int +ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...); + /* Check argument count */ ao_poly ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); @@ -891,11 +1010,11 @@ 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); +ao_scheme_read(FILE *in); /* rep */ ao_poly -ao_scheme_read_eval_print(void); +ao_scheme_read_eval_print(FILE *read_file, FILE *write_file, bool interactive); /* frame */ extern const struct ao_scheme_type ao_scheme_frame_type; @@ -923,8 +1042,13 @@ ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_po ao_poly ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); +#ifdef AO_SCHEME_FEATURE_UNDEF +ao_poly +ao_scheme_frame_del(struct ao_scheme_frame *frame, ao_poly atom); +#endif + void -ao_scheme_frame_write(ao_poly p, bool write); +ao_scheme_frame_write(FILE *out, ao_poly p, bool write); void ao_scheme_frame_init(void); @@ -938,7 +1062,7 @@ struct ao_scheme_lambda * ao_scheme_lambda_new(ao_poly cons); void -ao_scheme_lambda_write(ao_poly lambda, bool write); +ao_scheme_lambda_write(FILE *out, ao_poly lambda, bool write); ao_poly ao_scheme_lambda_eval(void); @@ -961,10 +1085,7 @@ void ao_scheme_stack_pop(void); void -ao_scheme_stack_clear(void); - -void -ao_scheme_stack_write(ao_poly stack, bool write); +ao_scheme_stack_write(FILE *out, ao_poly stack, bool write); ao_poly ao_scheme_stack_eval(void); @@ -972,10 +1093,10 @@ ao_scheme_stack_eval(void); /* error */ void -ao_scheme_vprintf(const char *format, va_list args); +ao_scheme_vfprintf(FILE *out, const char *format, va_list args); void -ao_scheme_printf(const char *format, ...); +ao_scheme_fprintf(FILE *out, const char *format, ...); ao_poly ao_scheme_error(int error, const char *format, ...); @@ -997,12 +1118,12 @@ int ao_scheme_stack_depth; #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 DBG(...) ao_scheme_fprintf(stdout, __VA_ARGS__) #define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_scheme_cons_write(ao_scheme_cons_poly(a), true) -#define DBG_POLY(a) ao_scheme_poly_write(a, true) +#define DBG_CONS(a) ao_scheme_cons_write(stdout, ao_scheme_cons_poly(a), true) +#define DBG_POLY(a) ao_scheme_poly_write(stdout, a, true) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) -#define DBG_STACK() ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack), true) +#define DBG_STACK() ao_scheme_stack_write(stdout, ao_scheme_stack_poly(ao_scheme_stack), true) static inline void ao_scheme_frames_dump(void) { @@ -1071,7 +1192,7 @@ extern int dbg_mem; #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)) +#define MDBG_MOVE_OUT() (--dbg_move_depth) #else diff --git a/src/scheme/ao_scheme_advanced_syntax.scheme b/src/scheme/ao_scheme_advanced_syntax.scheme new file mode 100644 index 00000000..79d4ba65 --- /dev/null +++ b/src/scheme/ao_scheme_advanced_syntax.scheme @@ -0,0 +1,402 @@ +; +; Copyright © 2018 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Advanced syntax, including vectors and floats + +(begin + (def! equal? + (lambda (a b) + (cond ((eq? a b) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b))) + ((lambda (i l) + (while (and (< i l) + (equal? (vector-ref a i) + (vector-ref b i))) + (set! i (+ i 1))) + (eq? i l) + ) + 0 + (vector-length a) + ) + ) + (else #f) + ) + ) + ) + 'equal? + ) + +(_?_ (equal? '(a b c) '(a b c)) #t) +(_?_ (equal? '(a b c) '(a b b)) #f) +(_?_ (equal? #(1 2 3) #(1 2 3)) #t) +(_?_ (equal? #(1 2 3) #(4 5 6)) #f) + +(define (_??_ a b) + (cond ((equal? a b) + a + ) + (else + (exit 1) + ) + ) + ) + +(define quasiquote + (macro (x) + (define (constant? exp) + ; A constant value is either a pair starting with quote, + ; or anything which is neither a pair nor a symbol + + (cond ((pair? exp) + (eq? (car exp) 'quote) + ) + (else + (not (symbol? exp)) + ) + ) + ) + + (define (combine-skeletons left right exp) + (cond + ((and (constant? left) (constant? right)) + (cond ((and (eqv? (eval left) (car exp)) + (eqv? (eval right) (cdr exp))) + (list 'quote exp) + ) + (else + (list 'quote (cons (eval left) (eval right))) + ) + ) + ) + ((null? right) + (list 'list left) + ) + ((and (pair? right) (eq? (car right) 'list)) + (cons 'list (cons left (cdr right))) + ) + (else + (list 'cons left right) + ) + ) + ) + + (define (expand-quasiquote exp nesting) + (cond + + ; non cons -- constants + ; themselves, others are + ; quoted + + ((not (pair? exp)) + (cond ((constant? exp) + exp + ) + (else + (list 'quote exp) + ) + ) + ) + + ; check for an unquote exp and + ; add the param unquoted + + ((and (eq? (car exp) 'unquote) (= (length exp) 2)) + (cond ((= nesting 0) + (car (cdr exp)) + ) + (else + (combine-skeletons ''unquote + (expand-quasiquote (cdr exp) (- nesting 1)) + exp)) + ) + ) + + ; nested quasi-quote -- + ; construct the right + ; expression + + ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) + (combine-skeletons ''quasiquote + (expand-quasiquote (cdr exp) (+ nesting 1)) + exp)) + + ; check for an + ; unquote-splicing member, + ; compute the expansion of the + ; value and append the rest of + ; the quasiquote result to it + + ((and (pair? (car exp)) + (eq? (car (car exp)) 'unquote-splicing) + (= (length (car exp)) 2)) + (cond ((= nesting 0) + (list 'append (car (cdr (car exp))) + (expand-quasiquote (cdr exp) nesting)) + ) + (else + (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) + (expand-quasiquote (cdr exp) nesting) + exp)) + ) + ) + + ; for other lists, just glue + ; the expansion of the first + ; element to the expansion of + ; the rest of the list + + (else (combine-skeletons (expand-quasiquote (car exp) nesting) + (expand-quasiquote (cdr exp) nesting) + exp) + ) + ) + ) + (expand-quasiquote x 0) + ) + ) + + ; `q -> (quote q) + ; `(q) -> (append (quote (q))) + ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) + ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) + + +(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) + + ; define a set of local + ; variables all at once and + ; then evaluate a list of + ; sexprs + ; + ; (let (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let ((x 1) (y)) (set! y (+ x 1)) y) + +(define let + (macro (vars . exprs) + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-vals vars) + (cond ((not (null? vars)) + (cons (cond ((null? (cdr (car vars))) ()) + (else + (car (cdr (car vars)))) + ) + (make-vals (cdr vars)))) + (else ()) + ) + ) + ; prepend the set operations + ; to the expressions + + ; build the lambda. + + `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) + ) + ) + + +(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) + +(define when (macro (test . l) `(cond (,test ,@l)))) + +(_??_ (when #t (+ 1 2)) 3) +(_??_ (when #f (+ 1 2)) #f) + +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) + +(_??_ (unless #f (+ 2 3)) 5) +(_??_ (unless #t (+ 2 3)) #f) + +(define (cdar l) (cdr (car l))) + +(_??_ (cdar '((1 2) (3 4))) '(2)) + +(define (cddr l) (cdr (cdr l))) + +(_??_ (cddr '(1 2 3)) '(3)) + +(define (caddr l) (car (cdr (cdr l)))) + +(_??_ (caddr '(1 2 3 4)) 3) + +(define (reverse list) + (define (_r old new) + (if (null? old) + new + (_r (cdr old) (cons (car old) new)) + ) + ) + (_r list ()) + ) + +(_??_ (reverse '(1 2 3)) '(3 2 1)) + +(define make-list + (lambda (a . b) + (define (_m a x) + (if (zero? a) + x + (_m (- a 1) (cons b x)) + ) + ) + (if (null? b) + (set! b #f) + (set! b (car b)) + ) + (_m a '()) + ) + ) + +(_??_ (make-list 10 'a) '(a a a a a a a a a a)) + +(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) + +(define for-each + (lambda (proc . lists) + (define (_f lists) + (cond ((null? (car lists)) #t) + (else + (apply proc (map car lists)) + (_f (map cdr lists)) + ) + ) + ) + (_f lists) + ) + ) + +(_??_ (let ((a 0)) + (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) + a + ) + 6) + +(_??_ (call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + -3) + +(define case + (macro (test . l) + ; construct the body of the + ; case, dealing with the + ; lambda version ( => lambda) + + (define (_unarrow l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)) + ) + + ; Build the case elements, which is + ; simply a list of cond clauses + + (define (_case l) + + (cond ((null? l) ()) + + ; else case + + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) + + ; regular case + + (else + (cons + `((eqv? ,(caar l) __key__) + ,@(_unarrow (cdr (car l)))) + (_case (cdr l))) + ) + ) + ) + + ; now construct the overall + ; expression, using a lambda + ; to hold the computed value + ; of the test expression + + `((lambda (__key__) + (cond ,@(_case l))) ,test) + ) + ) + +(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "one") +(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "two") +(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) "three") +(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "else") +(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "twelve") + +(define do + (macro (vars test . cmds) + (define (_step v) + (if (null? v) + '() + (if (null? (cddr (car v))) + (_step (cdr v)) + (cons `(set! ,(caar v) ,(caddr (car v))) + (_step (cdr v)) + ) + ) + ) + ) + `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) + (while (not ,(car test)) + ,@cmds + ,@(_step vars) + ) + ,@(cdr test) + ) + ) + ) + +(_??_ (do ((x 1 (+ x 1)) + (y 0) + ) + ((= x 10) y) + (set! y (+ y x)) + ) + 45) + +(_??_ (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i)) #(0 1 2 3 4)) diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c index c72a2b27..2a568ed9 100644 --- a/src/scheme/ao_scheme_atom.c +++ b/src/scheme/ao_scheme_atom.c @@ -32,34 +32,13 @@ static int atom_size(void *addr) 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; - } + MDBG_MOVE("mark atom %s\n", ((struct ao_scheme_atom *) addr)->name); + (void) addr; } 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; - } + (void) addr; } const struct ao_scheme_type ao_scheme_atom_type = { @@ -72,21 +51,74 @@ const struct ao_scheme_type ao_scheme_atom_type = { struct ao_scheme_atom *ao_scheme_atoms; static struct ao_scheme_atom * -ao_scheme_atom_find(char *name) +ao_scheme_atom_find(const char *name) { struct ao_scheme_atom *atom; +#ifdef ao_builtin_atoms + if (!ao_scheme_atoms) + ao_scheme_atoms = ao_scheme_poly_atom(ao_builtin_atoms); +#endif for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { if (!strcmp(atom->name, name)) return atom; } -#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; + return NULL; +} + +#ifdef AO_SCHEME_MAKE_CONST + +#define AO_SCHEME_BUILTIN_SYNTAX_ATOMS +#include "ao_scheme_builtin.h" +#undef AO_SCHEME_BUILTIN_SYNTAX_ATOMS + +static void +ao_scheme_atom_mark_syntax(void) +{ + unsigned a; + for (a = 0; a < sizeof(syntax_atoms)/sizeof(syntax_atoms[0]); a++) { + struct ao_scheme_atom *atom = ao_scheme_atom_find(syntax_atoms[a]); + if (atom) + ao_scheme_mark_memory(&ao_scheme_atom_type, atom); } +} + +#else +#define ao_scheme_atom_mark_syntax() #endif - return NULL; + +void +ao_scheme_atom_move(void) +{ + struct ao_scheme_atom *atom; + ao_scheme_move_memory(&ao_scheme_atom_type, (void **) (void *) &ao_scheme_atoms); + for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!ao_scheme_is_pool_addr(atom)) { + MDBG_DO(printf("atom out of pool %s\n", atom->name)); + break; + } + MDBG_DO(printf("move atom %s\n", atom->name)); + ao_scheme_poly_move(&atom->next, 0); + } +} + +void +ao_scheme_atom_check_references(void) +{ + struct ao_scheme_atom *atom; + ao_poly *prev = NULL; + + ao_scheme_atom_mark_syntax(); + for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!ao_scheme_marked(atom)) { + MDBG_DO(printf("unreferenced atom %s\n", atom->name)); + if (prev) + *prev = atom->next; + else + ao_scheme_atoms = ao_scheme_poly_atom(atom->next); + } else + prev = &atom->next; + } } static void @@ -161,17 +193,6 @@ ao_scheme_atom_get(ao_poly atom) 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) { @@ -188,9 +209,90 @@ ao_scheme_atom_def(ao_poly atom, ao_poly val) } void -ao_scheme_atom_write(ao_poly a, bool write) +ao_scheme_atom_write(FILE *out, ao_poly a, bool write) { struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); (void) write; - printf("%s", atom->name); + fprintf(out, "%s", atom->name); +} + +ao_poly +ao_scheme_do_symbolp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(_ao_scheme_atom_symbol3f, AO_SCHEME_ATOM, cons); +} + +ao_poly +ao_scheme_do_set(struct ao_scheme_cons *cons) +{ + ao_poly atom; + ao_poly val; + ao_poly *ref; + + if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, + AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + + ref = ao_scheme_atom_ref(atom, NULL); + + if (!ref) + return ao_scheme_error(AO_SCHEME_UNDEFINED, "%v: undefined atom %v", + _ao_scheme_atom_set, atom); + *ref = val; + return val; +} + +ao_poly +ao_scheme_do_def(struct ao_scheme_cons *cons) +{ + ao_poly atom; + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, + AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_atom_def(atom, val); +} + +ao_poly +ao_scheme_do_setq(struct ao_scheme_cons *cons) +{ + ao_poly atom; + ao_poly val; + ao_poly p; + + if (!ao_scheme_parse_args(_ao_scheme_atom_set21, cons, + AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (!ao_scheme_atom_ref(atom, NULL)) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: symbol %v not defined", + _ao_scheme_atom_set21, atom); + /* + * Build the macro return -- `(set (quote ,atom) ,val) + */ + ao_scheme_poly_stash(cons->cdr); + p = ao_scheme_cons(atom, AO_SCHEME_NIL); + p = ao_scheme_cons(_ao_scheme_atom_quote, p); + p = ao_scheme_cons(p, ao_scheme_poly_fetch()); + return ao_scheme_cons(_ao_scheme_atom_set, p); +} + +#ifdef AO_SCHEME_FEATURE_UNDEF +ao_poly +ao_scheme_do_undef(struct ao_scheme_cons *cons) +{ + ao_poly atom; + + if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, + AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_frame_del(ao_scheme_frame_global, atom); } +#endif diff --git a/src/scheme/ao_scheme_basic_syntax.scheme b/src/scheme/ao_scheme_basic_syntax.scheme new file mode 100644 index 00000000..563364a9 --- /dev/null +++ b/src/scheme/ao_scheme_basic_syntax.scheme @@ -0,0 +1,437 @@ +; +; Copyright © 2018 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Basic syntax placed in ROM + +(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1))))) + +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (a b) + (list + def + (list quote a) + b) + ) + ) + +(begin + (def! append + (lambda args + (def! _a + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (_a (cdr a) b))) + ) + ) + ) + + (def! _b + (lambda (l) + (cond ((null? l) l) + ((null? (cdr l)) (car l)) + (else (_a (car l) (_b (cdr l)))) + ) + ) + ) + (_b args) + ) + ) + 'append) + +(append '(a) '(b)) + + + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. + ; + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name x y z) sexprs ...) + ; + +(begin + (def! define + (macro (a . b) + ; check for alternate lambda definition form + + (cond ((pair? a) + (set! b + (cons + lambda + (cons (cdr a) b))) + (set! a (car a)) + ) + (else + (set! b (car b)) + ) + ) + (cons begin + (cons + (cons def + (cons (cons quote (cons a '())) + (cons b '()) + ) + ) + (cons + (cons quote (cons a '())) + '()) + ) + ) + ) + ) + 'define + ) + ; boolean operators + +(define or + (macro a + (def! b + (lambda (a) + (cond ((null? a) #f) + ((null? (cdr a)) + (car a)) + (else + (list + cond + (list + (car a)) + (list + 'else + (b (cdr a)) + ) + ) + ) + ) + ) + ) + (b a))) + + ; execute to resolve macros + +(_?_ (or #f #t) #t) + +(define and + (macro a + (def! b + (lambda (a) + (cond ((null? a) #t) + ((null? (cdr a)) + (car a)) + (else + (list + cond + (list + (car a) + (b (cdr a)) + ) + ) + ) + ) + ) + ) + (b a) + ) + ) + + ; execute to resolve macros + +(_?_ (and #t #f) #f) + + ; (if ) + ; (if 3 2) 'yes) 'yes) +(_?_ (if (> 3 2) 'yes 'no) 'yes) +(_?_ (if (> 2 3) 'no 'yes) 'yes) +(_?_ (if (> 2 3) 'no) #f) + +(define letrec + (macro (a . b) + + ; + ; make the list of names in the let + ; + + (define (_a a) + (cond ((not (null? a)) + (cons (car (car a)) + (_a (cdr a)))) + (else ()) + ) + ) + + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + + (define (_b a b) + (cond ((null? a) b) + (else + (cons + (list set + (list quote + (car (car a)) + ) + (cond ((null? (cdr (car a))) + () + ) + (else + (car (cdr (car a))) + ) + ) + ) + (_b (cdr a) b) + ) + ) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (_c a) + (cond ((null? a) ()) + (else (cons () (_c (cdr a)))) + ) + ) + ; build the lambda. + + (cons (cons lambda (cons (_a a) (_b a b))) (_c a)) + ) + ) + +(_?_ (letrec ((a 1) (b a)) (+ a b)) 2) + + ; letrec is sufficient for let* + +(define let* letrec) + + ; use letrec for let in basic + ; syntax + +(define let letrec) + + ; Basic recursive + ; equality. Replaced with + ; vector-capable version in + ; advanced syntax + +(define (equal? a b) + (cond ((eq? a b) #t) + ((pair? a) + (cond ((pair? b) + (cond ((equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + ) + ) + ) + ) + ) + +(_?_ (equal? '(a b c) '(a b c)) #t) +(_?_ (equal? '(a b c) '(a b b)) #f) + +(def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit 1))))) + + ; basic list accessors + +(define (caar a) (car (car a))) + +(define (cadr a) (car (cdr a))) + +(define (cdar l) (cdr (car l))) + +(_??_ (cdar '((1 2) (3 4))) '(2)) + +(define (cddr l) (cdr (cdr l))) + +(_??_ (cddr '(1 2 3)) '(3)) + +(define (caddr l) (car (cdr (cdr l)))) + +(_??_ (caddr '(1 2 3 4)) 3) + +(define (list-ref a b) + (car (list-tail a b)) + ) + +(list-ref '(1 2 3) 2) + +(define (member a b . t?) + (cond ((null? b) + #f + ) + (else + (if (null? t?) (set! t? equal?) (set! t? (car t?))) + (if (t? a (car b)) + b + (member a (cdr b) t?)) + ) + ) + ) + +(_??_ (member '(2) '((1) (2) (3))) '((2) (3))) +(_??_ (member '(4) '((1) (2) (3))) #f) + +(define (memq a b) (member a b eq?)) + +(_??_ (memq 2 '(1 2 3)) '(2 3)) +(_??_ (memq 4 '(1 2 3)) #f) +(_??_ (memq '(2) '((1) (2) (3))) #f) + +(define (assoc a b . t?) + (if (null? t?) + (set! t? equal?) + (set! t? (car t?)) + ) + (if (null? b) + #f + (if (t? a (caar b)) + (car b) + (assoc a (cdr b) t?) + ) + ) + ) + +(define (assq a b) (assoc a b eq?)) +(define assv assq) + +(_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) +(_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2)) +(_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) + +(define map + (lambda (proc . lists) + (define (_a lists) + (cond ((null? lists) ()) + (else + (cons (caar lists) (_a (cdr lists))) + ) + ) + ) + (define (_n lists) + (cond ((null? lists) ()) + (else + (cons (cdr (car lists)) (_n (cdr lists))) + ) + ) + ) + (define (_m lists) + (cond ((null? (car lists)) ()) + (else + (cons (apply proc (_a lists)) (_m (_n lists))) + ) + ) + ) + (_m lists) + ) + ) + +(_??_ (map cadr '((a b) (d e) (g h))) '(b e h)) + + ; use map as for-each in basic + ; mode + +(define for-each map) + ; simple math operators + +(define zero? (macro (value) (list eq? value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) (list > value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) (list < value 0))) + +(negative? 12) +(negative? -12) + +(define (abs a) (if (>= a 0) a (- a))) + +(abs 12) +(abs -12) + +(define max (lambda (a . b) + (while (not (null? b)) + (cond ((< a (car b)) + (set! a (car b))) + ) + (set! b (cdr b)) + ) + a) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (a . b) + (while (not (null? b)) + (cond ((> a (car b)) + (set! a (car b))) + ) + (set! b (cdr b)) + ) + a) + ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? a) (zero? (% a 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? a) (not (even? a))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + +(define (newline) (write-char #\newline)) + +(newline) + +(define (eof-object? a) + (equal? a 'eof) + ) + diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c index 88970667..05109fb9 100644 --- a/src/scheme/ao_scheme_bool.c +++ b/src/scheme/ao_scheme_bool.c @@ -38,15 +38,21 @@ const struct ao_scheme_type ao_scheme_bool_type = { }; void -ao_scheme_bool_write(ao_poly v, bool write) +ao_scheme_bool_write(FILE *out, ao_poly v, bool write) { struct ao_scheme_bool *b = ao_scheme_poly_bool(v); (void) write; if (b->value) - printf("#t"); + fprintf(out, "#t"); else - printf("#f"); + fprintf(out, "#f"); +} + +ao_poly +ao_scheme_do_booleanp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(_ao_scheme_atom_boolean3f, AO_SCHEME_BOOL, cons); } #ifdef AO_SCHEME_MAKE_CONST diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 4cb8b901..2b0c394b 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -12,9 +12,11 @@ * General Public License for more details. */ +#define _GNU_SOURCE #include "ao_scheme.h" #include #include +#include static int builtin_size(void *addr) @@ -84,33 +86,103 @@ ao_scheme_args_name(uint8_t args) #endif void -ao_scheme_builtin_write(ao_poly b, bool write) +ao_scheme_builtin_write(FILE *out, ao_poly b, bool write) { struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); (void) write; - printf("%s", ao_scheme_builtin_name(builtin->func)); + fputs(ao_scheme_builtin_name(builtin->func), out); } -ao_poly -ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) -{ - int argc = 0; +static bool +ao_scheme_typecheck(ao_poly actual, int formal_type) { + int actual_type; + + if ((formal_type & AO_SCHEME_ARG_MASK) == AO_SCHEME_POLY) + return true; + + /* allow nil? */ + if (actual == AO_SCHEME_NIL) + return (formal_type & AO_SCHEME_ARG_NIL_OK) != 0; + + actual_type = ao_scheme_poly_type(actual); + formal_type &= AO_SCHEME_ARG_MASK; + + if (actual_type == formal_type) + return true; + if (actual_type == AO_SCHEME_BUILTIN && formal_type == AO_SCHEME_LAMBDA) + return true; + +#ifdef AO_SCHEME_FEATURE_BIGINT + if (ao_scheme_integer_typep(actual_type) && formal_type == AO_SCHEME_INT) + return true; +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT + if (ao_scheme_number_typep(actual_type) && formal_type == AO_SCHEME_FLOAT) + return true; +#endif + return false; +} + +int +ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...) +{ + va_list ap; + int formal; + int argc = 0; + ao_poly car; + + va_start(ap, cons); + while ((formal = va_arg(ap, int)) != AO_SCHEME_ARG_END) { + if (formal & AO_SCHEME_ARG_OPTIONAL) + car = (ao_poly) va_arg(ap, int); + if (cons) { + car = cons->car; + cons = ao_scheme_cons_cdr(cons); + if (!ao_scheme_typecheck(car, formal)) { + ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); + return 0; + } + } else if (!(formal & AO_SCHEME_ARG_OPTIONAL)) { + goto bad_args; + } + if (formal & AO_SCHEME_ARG_RET_POLY) + formal = AO_SCHEME_POLY; - while (cons && argc <= max) { + switch (formal & AO_SCHEME_ARG_MASK) { + case AO_SCHEME_INT: +#ifdef AO_SCHEME_FEATURE_BIGINT + case AO_SCHEME_BIGINT: +#endif + *(va_arg(ap, int32_t *)) = ao_scheme_poly_integer(car); + break; +#ifdef AO_SCHEME_FEATURE_FLOAT + case AO_SCHEME_FLOAT: + *(va_arg(ap, float *)) = ao_scheme_poly_number(car); + break; +#endif + case AO_SCHEME_POLY: + *(va_arg(ap, ao_poly *)) = car; + break; + default: + *(va_arg(ap, void **)) = ao_scheme_ref(car); + break; + } argc++; - 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; + if (cons) { + bad_args: + ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid arg count", name); + return 0; + } + return 1; } -static ao_poly -ao_scheme_opt_arg(struct ao_scheme_cons *cons, int argc, ao_poly def) +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) { for (;;) { if (!cons) - return def; + return AO_SCHEME_NIL; if (argc == 0) return cons->car; cons = ao_scheme_cons_cdr(cons); @@ -118,188 +190,16 @@ ao_scheme_opt_arg(struct ao_scheme_cons *cons, int argc, ao_poly def) } } -ao_poly -ao_scheme_arg(struct ao_scheme_cons *cons, int argc) -{ - return ao_scheme_opt_arg(cons, argc, AO_SCHEME_NIL); -} - -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, "%v: arg %d invalid type %v", name, argc, car); - return _ao_scheme_bool_true; -} - -static int32_t -ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc) -{ - ao_poly p = ao_scheme_arg(cons, argc); - bool fail = false; - int32_t i = ao_scheme_poly_integer(p, &fail); - - if (fail) - (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p); - return i; -} - -static int32_t -ao_scheme_opt_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc, int def) -{ - ao_poly p = ao_scheme_opt_arg(cons, argc, ao_scheme_int_poly(def)); - bool fail = false; - int32_t i = ao_scheme_poly_integer(p, &fail); - - if (fail) - (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p); - return i; -} - -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_list_copy(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *new; - - 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; - new = ao_scheme_cons_copy(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); - return ao_scheme_cons_poly(new); -} - -ao_poly -ao_scheme_do_list_tail(struct ao_scheme_cons *cons) -{ - ao_poly list; - int32_t v; - - if (!ao_scheme_check_argc(_ao_scheme_atom_list2dtail, cons, 2, 2)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_list2dtail, cons, 0, AO_SCHEME_CONS, 1)) - return AO_SCHEME_NIL; - list = ao_scheme_arg(cons, 0); - v = ao_scheme_arg_int(_ao_scheme_atom_list2dtail, cons, 1); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - while (v > 0) { - if (!list) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: ran off end", _ao_scheme_atom_list2dtail); - if (!ao_scheme_is_cons(list)) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid list", _ao_scheme_atom_list2dtail); - list = ao_scheme_poly_cons(list)->cdr; - v--; - } - return list; -} - ao_poly ao_scheme_do_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 val; -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)) + if (!ao_scheme_parse_args(_ao_scheme_atom_quote, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) 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)); + return val; } ao_poly @@ -325,30 +225,49 @@ ao_scheme_do_while(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; } -ao_poly -ao_scheme_do_write(struct ao_scheme_cons *cons) +static ao_poly +ao_scheme_do_display_or_write(ao_poly proc, struct ao_scheme_cons *cons, bool write) { - ao_poly val = AO_SCHEME_NIL; - while (cons) { - val = cons->car; - ao_scheme_poly_write(val, true); - cons = ao_scheme_cons_cdr(cons); - if (cons) - printf(" "); +#ifndef AO_SCHEME_FEATURE_PORT + ao_poly val; + ao_poly port; + + if (!ao_scheme_parse_args(proc, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_POLY | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + ao_scheme_poly_write(stdout, val, write); +#else + ao_poly val; + struct ao_scheme_port *port; + FILE *file = stdout; + + if (!ao_scheme_parse_args(proc, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_PORT | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (port) { + file = port->file; + if (!file) + return _ao_scheme_bool_true; } + ao_scheme_poly_write(file, val, write); +#endif return _ao_scheme_bool_true; } +ao_poly +ao_scheme_do_write(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_display_or_write(_ao_scheme_atom_write, cons, true); +} + ao_poly ao_scheme_do_display(struct ao_scheme_cons *cons) { - ao_poly val = AO_SCHEME_NIL; - while (cons) { - val = cons->car; - ao_scheme_poly_write(val, false); - cons = ao_scheme_cons_cdr(cons); - } - return _ao_scheme_bool_true; + return ao_scheme_do_display_or_write(_ao_scheme_atom_display, cons, false); } static ao_poly @@ -369,14 +288,14 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) switch (op) { case builtin_minus: if (ao_scheme_integer_typep(ct)) - ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret, NULL)); + ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); #ifdef AO_SCHEME_FEATURE_FLOAT else if (ct == AO_SCHEME_FLOAT) ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); #endif break; case builtin_divide: - if (ao_scheme_poly_integer(ret, NULL) == 1) { + if (ao_scheme_poly_integer(ret) == 1) { } else { #ifdef AO_SCHEME_FEATURE_FLOAT if (ao_scheme_number_typep(ct)) { @@ -394,8 +313,8 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) } cons = ao_scheme_cons_fetch(); } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { - int32_t r = ao_scheme_poly_integer(ret, NULL); - int32_t c = ao_scheme_poly_integer(car, NULL); + int32_t r = ao_scheme_poly_integer(ret); + int32_t c = ao_scheme_poly_integer(car); #ifdef AO_SCHEME_FEATURE_FLOAT int64_t t; #endif @@ -576,8 +495,8 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) 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, NULL); - int32_t r = ao_scheme_poly_integer(right, NULL); + int32_t l = ao_scheme_poly_integer(left); + int32_t r = ao_scheme_poly_integer(right); switch (op) { case builtin_less: @@ -698,181 +617,69 @@ 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_string_ref(struct ao_scheme_cons *cons) -{ - char *string; - int32_t ref; - if (!ao_scheme_check_argc(_ao_scheme_atom_string2dref, cons, 2, 2)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_string2dref, cons, 0, AO_SCHEME_STRING, 0)) - return AO_SCHEME_NIL; - ref = ao_scheme_arg_int(_ao_scheme_atom_string2dref, cons, 1); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val; - while (*string && ref) { - ++string; - --ref; - } - if (!*string) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", - _ao_scheme_atom_string2dref, - ao_scheme_arg(cons, 0), - ao_scheme_arg(cons, 1)); - return ao_scheme_int_poly(*string); -} - -ao_poly -ao_scheme_do_string_length(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - - if (!ao_scheme_check_argc(_ao_scheme_atom_string2dlength, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_string2dlength, cons, 0, AO_SCHEME_STRING, 0)) - return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); - return ao_scheme_integer_poly(strlen(string->val)); -} - -ao_poly -ao_scheme_do_string_copy(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - - if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_string2dcopy, cons, 0, AO_SCHEME_STRING, 0)) - return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); - return ao_scheme_string_poly(ao_scheme_string_copy(string)); -} - -ao_poly -ao_scheme_do_string_set(struct ao_scheme_cons *cons) -{ - char *string; - int32_t ref; - int32_t val; - - if (!ao_scheme_check_argc(_ao_scheme_atom_string2dset21, cons, 3, 3)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_string2dset21, cons, 0, AO_SCHEME_STRING, 0)) - return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val; - ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - if (!val) - goto fail; - while (*string && ref) { - ++string; - --ref; - } - if (!*string) - goto fail; - *string = val; - return ao_scheme_int_poly(*string); -fail: - return ao_scheme_error(AO_SCHEME_INVALID, "%v: %v[%v] = %v invalid", - _ao_scheme_atom_string2dset21, - ao_scheme_arg(cons, 0), - ao_scheme_arg(cons, 1), - ao_scheme_arg(cons, 2)); -} - -ao_poly -ao_scheme_do_make_string(struct ao_scheme_cons *cons) -{ - int32_t len; - char fill; - - if (!ao_scheme_check_argc(_ao_scheme_atom_make2dstring, cons, 1, 2)) - return AO_SCHEME_NIL; - len = ao_scheme_arg_int(_ao_scheme_atom_make2dstring, cons, 0); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - fill = ao_scheme_opt_arg_int(_ao_scheme_atom_make2dstring, cons, 1, ' '); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - return ao_scheme_string_poly(ao_scheme_make_string(len, fill)); -} - ao_poly ao_scheme_do_flush_output(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) +#ifndef AO_SCHEME_FEATURE_PORT + ao_poly port; + if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, + AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - ao_scheme_os_flush(); + fflush(stdout); +#else + struct ao_scheme_port *port; + + if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, + AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + fflush(stdout); + if (port) { + if (port->file) + fflush(port->file); + } else + fflush(stdout); +#endif return _ao_scheme_bool_true; } +#ifdef AO_SCHEME_FEATURE_GPIO + ao_poly ao_scheme_do_led(struct ao_scheme_cons *cons) { int32_t led; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - return AO_SCHEME_NIL; - led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0); - if (ao_scheme_exception) + if (!ao_scheme_parse_args(_ao_scheme_atom_led, cons, + AO_SCHEME_INT, &led, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - led = ao_scheme_arg(cons, 0); - ao_scheme_os_led(ao_scheme_poly_int(led)); - return led; + ao_scheme_os_led(led); + return _ao_scheme_bool_true; } -ao_poly -ao_scheme_do_delay(struct ao_scheme_cons *cons) -{ - int32_t delay; - - if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1)) - return AO_SCHEME_NIL; - delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - ao_scheme_os_delay(delay); - return delay; -} +#endif ao_poly ao_scheme_do_eval(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) + ao_poly expr; + ao_poly env; + + if (!ao_scheme_parse_args(_ao_scheme_atom_eval, cons, + AO_SCHEME_POLY, &expr, + AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &env, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; ao_scheme_stack->state = eval_sexpr; - return cons->car; + ao_scheme_stack->frame = AO_SCHEME_NIL; + ao_scheme_frame_current = NULL; + return expr; } ao_poly ao_scheme_do_apply(struct ao_scheme_cons *cons) { - 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); } @@ -880,9 +687,27 @@ ao_scheme_do_apply(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_read(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) + FILE *file = stdin; +#ifndef AO_SCHEME_FEATURE_PORT + ao_poly port; + if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, + AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; +#else + struct ao_scheme_port *port; + + if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, + AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - return ao_scheme_read(); + if (port) { + file = port->file; + if (!file) + return _ao_scheme_atom_eof; + } +#endif + return ao_scheme_read(file); } ao_poly @@ -897,9 +722,13 @@ ao_scheme_do_collect(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_nullp(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) + if (val == AO_SCHEME_NIL) return _ao_scheme_bool_true; else return _ao_scheme_bool_false; @@ -908,317 +737,272 @@ ao_scheme_do_nullp(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_not(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) + if (val == _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 (ao_scheme_is_pair(v)) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - ao_poly -ao_scheme_do_integerp(struct ao_scheme_cons *cons) +ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons) { -#ifdef AO_SCHEME_FEATURE_BIGINT - 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; - } -#else - return ao_scheme_do_typep(AO_SCHEME_INT, cons); -#endif -} + ao_poly val; -ao_poly -ao_scheme_do_numberp(struct ao_scheme_cons *cons) -{ -#if defined(AO_SCHEME_FEATURE_BIGINT) || defined(AO_SCHEME_FEATURE_FLOAT) - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + if (!ao_scheme_parse_args(proc, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { - case AO_SCHEME_INT: -#ifdef AO_SCHEME_FEATURE_BIGINT - case AO_SCHEME_BIGINT: -#endif -#ifdef AO_SCHEME_FEATURE_FLOAT - case AO_SCHEME_FLOAT: -#endif + if (ao_scheme_poly_type(val) == type) return _ao_scheme_bool_true; - default: - return _ao_scheme_bool_false; - } -#else - return ao_scheme_do_integerp(cons); -#endif -} - -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); + return _ao_scheme_bool_false; } ao_poly ao_scheme_do_procedurep(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + switch (ao_scheme_poly_type(val)) { case AO_SCHEME_BUILTIN: case AO_SCHEME_LAMBDA: return _ao_scheme_bool_true; default: - return _ao_scheme_bool_false; - } -} - -/* 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_list3f, 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_is_cons(v)) - return _ao_scheme_bool_false; - v = ao_scheme_poly_cons(v)->cdr; + return _ao_scheme_bool_false; } } -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_atom_to_string(ao_scheme_poly_atom(ao_scheme_arg(cons, 0)))); -} - -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_string_to_atom(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)) +#ifndef AO_SCHEME_FEATURE_PORT + ao_poly port; + if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, + AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; c = getchar(); - return ao_scheme_int_poly(c); +#else + struct ao_scheme_port *port; + + if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, + AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (port) + c = ao_scheme_port_getc(port); + else + c = getchar(); +#endif + if (c == EOF) + return _ao_scheme_atom_eof; + return ao_scheme_integer_poly(c); } ao_poly ao_scheme_do_write_char(struct ao_scheme_cons *cons) { - 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)) + int32_t c; +#ifndef AO_SCHEME_FEATURE_PORT + ao_poly port; + if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, + AO_SCHEME_INT, &c, + AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0), NULL)); + putchar(c); +#else + struct ao_scheme_port *port; + if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, + AO_SCHEME_INT, &c, + AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (port) + ao_scheme_port_putc(port, c); + else + putchar(c); +#endif return _ao_scheme_bool_true; } ao_poly ao_scheme_do_exit(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_exit, cons, + AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_true, &val, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; ao_scheme_exception |= AO_SCHEME_EXIT; - return _ao_scheme_bool_true; + return val; } +#ifdef AO_SCHEME_FEATURE_TIME + 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)) + if (!ao_scheme_parse_args(_ao_scheme_atom_current2djiffy, cons, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - jiffy = ao_scheme_os_jiffy(); - return (ao_scheme_int_poly(jiffy)); + return ao_scheme_integer_poly(ao_scheme_os_jiffy()); } ao_poly -ao_scheme_do_current_second(struct ao_scheme_cons *cons) +ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) { - int second; - - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + if (!ao_scheme_parse_args(_ao_scheme_atom_jiffies2dper2dsecond, cons, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; - return (ao_scheme_int_poly(second)); + return ao_scheme_integer_poly(AO_SCHEME_JIFFIES_PER_SECOND); } ao_poly -ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) +ao_scheme_do_delay(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + int32_t delay; + + if (!ao_scheme_parse_args(_ao_scheme_atom_delay, cons, + AO_SCHEME_INT, &delay, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); + ao_scheme_os_delay(delay); + return cons->car; } +#endif -#ifdef AO_SCHEME_FEATURE_VECTOR +#ifdef AO_SCHEME_FEATURE_POSIX -ao_poly -ao_scheme_do_vector(struct ao_scheme_cons *cons) +#include + +static char **ao_scheme_argv; + +void +ao_scheme_set_argv(char **argv) { - return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); + ao_scheme_argv = argv; } ao_poly -ao_scheme_do_make_vector(struct ao_scheme_cons *cons) +ao_scheme_do_command_line(struct ao_scheme_cons *cons) { - int32_t k; + ao_poly args = AO_SCHEME_NIL; + ao_poly arg; + int i; - if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 1, 2)) + if (!ao_scheme_parse_args(_ao_scheme_atom_command2dline, cons, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_opt_arg(cons, 1, _ao_scheme_bool_false))); -} -ao_poly -ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0)) - return AO_SCHEME_NIL; - return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); + for (i = 0; ao_scheme_argv[i]; i++); + + while (--i >= 0) { + ao_scheme_poly_stash(args); + arg = ao_scheme_string_poly(ao_scheme_string_new(ao_scheme_argv[i])); + args = ao_scheme_poly_fetch(); + if (!arg) + return AO_SCHEME_NIL; + args = ao_scheme_cons(arg, args); + if (!args) + return AO_SCHEME_NIL; + } + return args; } ao_poly -ao_scheme_do_vector_set(struct ao_scheme_cons *cons) +ao_scheme_do_get_environment_variables(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0)) + ao_poly envs = AO_SCHEME_NIL; + ao_poly env; + int i; + + if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariables, cons, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2)); + for (i = 0; environ[i]; i++); + + while (--i >= 0) { + ao_scheme_poly_stash(envs); + env = ao_scheme_string_poly(ao_scheme_string_new(environ[i])); + envs = ao_scheme_poly_fetch(); + if (!env) + return AO_SCHEME_NIL; + envs = ao_scheme_cons(env, envs); + if (!envs) + return AO_SCHEME_NIL; + } + return envs; } ao_poly -ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) +ao_scheme_do_get_environment_variable(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0)) + struct ao_scheme_string *name; + char *val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariable, cons, + AO_SCHEME_STRING, &name, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); + val = secure_getenv(name->val); + if (!val) + return _ao_scheme_bool_false; + return ao_scheme_string_poly(ao_scheme_string_new(val)); } ao_poly -ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) +ao_scheme_do_file_existsp(struct ao_scheme_cons *cons) { - int start, end; + struct ao_scheme_string *name; - if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 3)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) - return AO_SCHEME_NIL; - start = ao_scheme_opt_arg_int(_ao_scheme_atom_vector2d3elist, cons, 1, ao_scheme_int_poly(0)); - if (ao_scheme_exception) + if (!ao_scheme_parse_args(_ao_scheme_atom_file2dexists3f, cons, + AO_SCHEME_STRING, &name, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - end = ao_scheme_opt_arg_int(_ao_scheme_atom_vector2d3elist, cons, 2, ao_scheme_int_poly(-1)); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)), - start, - end)); + if (access(name->val, F_OK) == 0) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; } ao_poly -ao_scheme_do_vector_length(struct ao_scheme_cons *cons) +ao_scheme_do_delete_file(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) + struct ao_scheme_string *name; + + if (!ao_scheme_parse_args(_ao_scheme_atom_delete2dfile, cons, + AO_SCHEME_STRING, &name, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length); + if (unlink(name->val) == 0) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; } ao_poly -ao_scheme_do_vectorp(struct ao_scheme_cons *cons) +ao_scheme_do_current_second(struct ao_scheme_cons *cons) { - return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons); + int32_t second; + + if (!ao_scheme_parse_args(_ao_scheme_atom_current2dsecond, cons, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + second = (int32_t) time(NULL); + return ao_scheme_integer_poly(second); } -#endif /* AO_SCHEME_FEATURE_VECTOR */ +#endif /* AO_SCHEME_FEATURE_POSIX */ #define AO_SCHEME_BUILTIN_FUNCS #include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index 7298add7..8f9a6381 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -41,8 +41,8 @@ all f_lambda greater_equal >= string>=? all f_lambda flush_output flush-output TIME f_lambda delay GPIO f_lambda led -all f_lambda save -all f_lambda restore +SAVE f_lambda save +SAVE f_lambda restore all f_lambda call_cc call-with-current-continuation call/cc all f_lambda collect all f_lambda nullp null? @@ -62,7 +62,6 @@ all f_lambda string_to_symbol string->symbol all f_lambda stringp string? all f_lambda string_ref string-ref all f_lambda string_set string-set! -all f_lambda string_copy string-copy all f_lambda string_length string-length all f_lambda make_string make-string all f_lambda procedurep procedure? @@ -71,7 +70,6 @@ all f_lambda read_char read-char all f_lambda write_char write-char all f_lambda exit TIME f_lambda current_jiffy current-jiffy -TIME f_lambda current_second current-second TIME f_lambda jiffies_per_second jiffies-per-second FLOAT f_lambda finitep finite? FLOAT f_lambda infinitep infinite? @@ -85,3 +83,18 @@ VECTOR f_lambda list_to_vector list->vector VECTOR f_lambda vector_to_list vector->list VECTOR f_lambda vector_length vector-length VECTOR f_lambda vectorp vector? +PORT f_lambda portp port? +PORT f_lambda port_openp port-open? +PORT f_lambda open_input_file open-input-file +PORT f_lambda open_output_file open-output-file +PORT f_lambda close_port close-port +PORT f_lambda current_input_port current-input-port +PORT f_lambda current_output_port current-output-port +PORT f_lambda current_error_port current-error-port +POSIX f_lambda command_line command-line +POSIX f_lambda get_environment_variables get-environment-variables +POSIX f_lambda get_environment_variable get-environment-variable +POSIX f_lambda file_existsp file-exists? +POSIX f_lambda delete_file delete-file +POSIX f_lambda current_second current-second +UNDEF f_lambda undef diff --git a/src/scheme/ao_scheme_char.scheme b/src/scheme/ao_scheme_char.scheme new file mode 100644 index 00000000..c0353834 --- /dev/null +++ b/src/scheme/ao_scheme_char.scheme @@ -0,0 +1,80 @@ +; +; Copyright © 2018 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Char primitives placed in ROM + +(define char? integer?) + +(_??_ (char? #\q) #t) +(_??_ (char? "h") #f) + +(define (char-upper-case? c) (<= #\A c #\Z)) + +(_??_ (char-upper-case? #\a) #f) +(_??_ (char-upper-case? #\B) #t) +(_??_ (char-upper-case? #\0) #f) +(_??_ (char-upper-case? #\space) #f) + +(define (char-lower-case? c) (<= #\a c #\a)) + +(_??_ (char-lower-case? #\a) #t) +(_??_ (char-lower-case? #\B) #f) +(_??_ (char-lower-case? #\0) #f) +(_??_ (char-lower-case? #\space) #f) + +(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) + +(_??_ (char-alphabetic? #\a) #t) +(_??_ (char-alphabetic? #\B) #t) +(_??_ (char-alphabetic? #\0) #f) +(_??_ (char-alphabetic? #\space) #f) + +(define (char-numeric? c) (<= #\0 c #\9)) + +(_??_ (char-numeric? #\a) #f) +(_??_ (char-numeric? #\B) #f) +(_??_ (char-numeric? #\0) #t) +(_??_ (char-numeric? #\space) #f) + +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) + +(_??_ (char-whitespace? #\a) #f) +(_??_ (char-whitespace? #\B) #f) +(_??_ (char-whitespace? #\0) #f) +(_??_ (char-whitespace? #\space) #t) + +(define char->integer (macro (v) v)) +(define integer->char char->integer) + +(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(_??_ (char-upcase #\a) #\A) +(_??_ (char-upcase #\B) #\B) +(_??_ (char-upcase #\0) #\0) +(_??_ (char-upcase #\space) #\space) + +(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) + +(_??_ (char-downcase #\a) #\a) +(_??_ (char-downcase #\B) #\b) +(_??_ (char-downcase #\0) #\0) +(_??_ (char-downcase #\space) #\space) + +(define (digit-value c) + (if (char-numeric? c) + (- c #\0) + #f) + ) + +(_??_ (digit-value #\1) 1) +(_??_ (digit-value #\a) #f) diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index a9ff5acd..a6e697b2 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -124,7 +124,7 @@ ao_scheme_cons(ao_poly car, ao_poly cdr) return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); } -struct ao_scheme_cons * +static struct ao_scheme_cons * ao_scheme_cons_copy(struct ao_scheme_cons *cons) { struct ao_scheme_cons *head = NULL; @@ -175,7 +175,7 @@ ao_scheme_cons_free(struct ao_scheme_cons *cons) } void -ao_scheme_cons_write(ao_poly c, bool write) +ao_scheme_cons_write(FILE *out, ao_poly c, bool write) { struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); struct ao_scheme_cons *clear = cons; @@ -183,34 +183,34 @@ ao_scheme_cons_write(ao_poly c, bool write) int written = 0; ao_scheme_print_start(); - printf("("); + fprintf(out, "("); while (cons) { if (written != 0) - printf(" "); + fprintf(out, " "); /* Note if there's recursion in printing. Not * as good as actual references, but at least * we don't infinite loop... */ if (ao_scheme_print_mark_addr(cons)) { - printf("..."); + fprintf(out, "..."); break; } - ao_scheme_poly_write(cons->car, write); + ao_scheme_poly_write(out, cons->car, write); /* keep track of how many pairs have been printed */ written++; cdr = cons->cdr; if (!ao_scheme_is_cons(cdr)) { - printf(" . "); - ao_scheme_poly_write(cdr, write); + fprintf(out, " . "); + ao_scheme_poly_write(out, cdr, write); break; } cons = ao_scheme_poly_cons(cdr); } - printf(")"); + fprintf(out, ")"); if (ao_scheme_print_stop()) { @@ -234,3 +234,169 @@ ao_scheme_cons_length(struct ao_scheme_cons *cons) } return len; } + +ao_poly +ao_scheme_do_car(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *pair; + + if (!ao_scheme_parse_args(_ao_scheme_atom_car, cons, + AO_SCHEME_CONS, &pair, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return pair->car; +} + +ao_poly +ao_scheme_do_cdr(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *pair; + + if (!ao_scheme_parse_args(_ao_scheme_atom_cdr, cons, + AO_SCHEME_CONS, &pair, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return pair->cdr; +} + +ao_poly +ao_scheme_do_cons(struct ao_scheme_cons *cons) +{ + ao_poly car, cdr; + + if (!ao_scheme_parse_args(_ao_scheme_atom_cons, cons, + AO_SCHEME_POLY, &car, + AO_SCHEME_POLY, &cdr, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_cons(car, cdr); +} + +ao_poly +ao_scheme_do_last(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *pair; + + if (!ao_scheme_parse_args(_ao_scheme_atom_last, cons, + AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + while (pair) { + if (!pair->cdr) + return pair->car; + pair = ao_scheme_cons_cdr(pair); + } + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_length(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *pair; + if (!ao_scheme_parse_args(_ao_scheme_atom_length, cons, + AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_integer_poly(ao_scheme_cons_length(pair)); +} + +ao_poly +ao_scheme_do_list_copy(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *pair; + + if (!ao_scheme_parse_args(_ao_scheme_atom_list2dcopy, cons, + AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_cons_poly(ao_scheme_cons_copy(pair)); +} + +ao_poly +ao_scheme_do_list_tail(struct ao_scheme_cons *cons) +{ + ao_poly list; + int32_t v; + + if (!ao_scheme_parse_args(_ao_scheme_atom_list2dtail, cons, + AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK | AO_SCHEME_ARG_RET_POLY, &list, + AO_SCHEME_INT, &v, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + + while (v > 0) { + if (!list) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: ran off end", _ao_scheme_atom_list2dtail); + if (!ao_scheme_is_cons(list)) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid list", _ao_scheme_atom_list2dtail); + list = ao_scheme_poly_cons(list)->cdr; + v--; + } + return list; +} + +ao_poly +ao_scheme_do_pairp(struct ao_scheme_cons *cons) +{ + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (ao_scheme_is_pair(val)) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_scheme_do_listp(struct ao_scheme_cons *cons) +{ + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + for (;;) { + if (val == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + if (!ao_scheme_is_cons(val)) + return _ao_scheme_bool_false; + val = ao_scheme_poly_cons(val)->cdr; + } +} + +ao_poly +ao_scheme_do_set_car(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *pair; + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons, + AO_SCHEME_CONS, &pair, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + pair->car = val; + return val; +} + +ao_poly +ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *pair; + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons, + AO_SCHEME_CONS, &pair, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + pair->cdr = val; + return val; +} + diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme index 107d60a6..17dc51a9 100644 --- a/src/scheme/ao_scheme_const.scheme +++ b/src/scheme/ao_scheme_const.scheme @@ -13,7 +13,7 @@ ; ; Lisp code placed in ROM -(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit))))) +(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1))))) ; return a list containing all of the arguments (def (quote list) (lambda l l)) @@ -502,7 +502,7 @@ ; ; (let* ((x 1) (y)) (set! y (+ x 1)) y) -(define let* +(define letrec (macro (vars . exprs) ; @@ -553,7 +553,11 @@ ) ) -(_??_ (let* ((x 1) (y x)) (+ x y)) 2) +(_??_ (letrec ((x 1) (y x)) (+ x y)) 2) + + ; letrec is sufficient for let* + +(define let* letrec) (define when (macro (test . l) `(cond (,test ,@l)))) @@ -767,20 +771,25 @@ ) ) -(for-each display '("hello" " " "world" "\n")) +(_??_ (let ((a 0)) + (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) + a + ) + 6) + (define (newline) (write-char #\newline)) (newline) -(call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (write "test" x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) +(_??_ (call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + -3) ; `q -> (quote q) @@ -813,7 +822,7 @@ ) (repeat 2 (write 'hello)) -(repeat (x 3) (write 'goodbye x)) +(repeat (x 3) (write (list 'goodbye x))) (define case (macro (test . l) @@ -860,11 +869,11 @@ ) ) -(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "one") -(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "two") -(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x) "three")) (12 "twelve") (else "else")) "three") -(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "else") -(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "twelve") +(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "one") +(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "two") +(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) "three") +(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "else") +(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "twelve") (define do (macro (vars test . cmds) @@ -889,13 +898,18 @@ ) ) -(do ((x 1 (+ x 1))) - ((= x 10) "done") - (display "x: ") - (write x) - (newline) +(define (eof-object? a) + (equal? a 'eof) ) +(_??_ (do ((x 1 (+ x 1)) + (y 0) + ) + ((= x 10) y) + (set! y (+ y x)) + ) + 45) + (_??_ (do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) diff --git a/src/scheme/ao_scheme_do.scheme b/src/scheme/ao_scheme_do.scheme new file mode 100644 index 00000000..063e4a38 --- /dev/null +++ b/src/scheme/ao_scheme_do.scheme @@ -0,0 +1,34 @@ +(define do + (macro (vars test . cmds) + (define (_step v) + (if (null? v) + '() + (if (null? (cddr (car v))) + (_step (cdr v)) + (cons `(set! ,(caar v) ,(caddr (car v))) + (_step (cdr v)) + ) + ) + ) + ) + `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) + (while (not ,(car test)) + ,@cmds + ,@(_step vars) + ) + ,@(cdr test) + ) + ) + ) + +(do ((x 1 (+ x 1))) + ((= x 10) "done") + (display "x: ") + (write x) + (newline) + ) + +(do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i)) diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c index 6ca63f75..f97eb003 100644 --- a/src/scheme/ao_scheme_error.c +++ b/src/scheme/ao_scheme_error.c @@ -16,7 +16,7 @@ #include void -ao_scheme_vprintf(const char *format, va_list args) +ao_scheme_vfprintf(FILE *out, const char *format, va_list args) { char c; @@ -24,38 +24,38 @@ ao_scheme_vprintf(const char *format, va_list args) if (c == '%') { switch (c = *format++) { case 'v': - ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int), true); + ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), true); break; case 'V': - ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int), false); + ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), false); break; case 'p': - printf("%p", va_arg(args, void *)); + fprintf(out, "%p", va_arg(args, void *)); break; case 'd': - printf("%d", va_arg(args, int)); + fprintf(out, "%d", va_arg(args, int)); break; case 'x': - printf("%x", va_arg(args, int)); + fprintf(out, "%x", va_arg(args, int)); break; case 's': - printf("%s", va_arg(args, char *)); + fprintf(out, "%s", va_arg(args, char *)); break; default: - putchar(c); + putc(c, out); break; } } else - putchar(c); + putc(c, out); } } void -ao_scheme_printf(const char *format, ...) +ao_scheme_fprintf(FILE *out, const char *format, ...) { va_list args; va_start(args, format); - ao_scheme_vprintf(format, args); + ao_scheme_vfprintf(out, format, args); va_end(args); } @@ -66,13 +66,13 @@ ao_scheme_error(int error, const char *format, ...) ao_scheme_exception |= error; va_start(args, format); - ao_scheme_vprintf(format, args); + ao_scheme_vfprintf(stdout, 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)); + ao_scheme_fprintf(stdout, "Value: %v\n", ao_scheme_v); + ao_scheme_fprintf(stdout, "Frame: %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); printf("Stack:\n"); - ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack), true); - ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); + ao_scheme_stack_write(stdout, ao_scheme_stack_poly(ao_scheme_stack), true); + ao_scheme_fprintf(stdout, "Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); return AO_SCHEME_NIL; } diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c index 91f6a84f..9536cb91 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -271,8 +271,10 @@ ao_scheme_eval_exec(void) } ao_scheme_v = v; - ao_scheme_stack->values = AO_SCHEME_NIL; - ao_scheme_stack->values_tail = AO_SCHEME_NIL; + if (ao_scheme_stack->state != eval_exec) { + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + } DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); break; @@ -530,6 +532,7 @@ const char * const ao_scheme_state_names[] = { [eval_macro] = "macro", }; +#ifdef AO_SCHEME_FEATURE_SAVE /* * Called at restore time to reset all execution state */ @@ -547,6 +550,7 @@ ao_scheme_eval_restart(void) { return ao_scheme_stack_push(); } +#endif /* AO_SCHEME_FEATURE_SAVE */ ao_poly ao_scheme_eval(ao_poly _v) @@ -559,12 +563,11 @@ ao_scheme_eval(ao_poly _v) 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; - } + if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) + break; } DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); + ao_scheme_stack = NULL; ao_scheme_frame_current = NULL; return ao_scheme_v; } diff --git a/src/scheme/ao_scheme_finish.scheme b/src/scheme/ao_scheme_finish.scheme new file mode 100644 index 00000000..fde04fb3 --- /dev/null +++ b/src/scheme/ao_scheme_finish.scheme @@ -0,0 +1,17 @@ +; +; Copyright © 2018 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Finish setting up ROM lisp code + +(undef '_?_) +(undef '_??_) diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index d8501548..483035f9 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -46,22 +46,22 @@ const struct ao_scheme_type ao_scheme_float_type = { #endif void -ao_scheme_float_write(ao_poly p, bool write) +ao_scheme_float_write(FILE *out, ao_poly p, bool write) { struct ao_scheme_float *f = ao_scheme_poly_float(p); float v = f->value; (void) write; if (isnanf(v)) - printf("+nan.0"); + fputs("+nan.0", out); else if (isinff(v)) { if (v < 0) - printf("-"); + putc('-', out); else - printf("+"); - printf("inf.0"); + putc('+', out); + fputs("inf.0", out); } else - printf (FLOAT_FORMAT, v); + fprintf(out, FLOAT_FORMAT, v); } float @@ -95,9 +95,13 @@ ao_scheme_float_get(float value) ao_poly ao_scheme_do_inexactp(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT) + if (ao_scheme_poly_type(val) == AO_SCHEME_FLOAT) return _ao_scheme_bool_true; return _ao_scheme_bool_false; } @@ -105,18 +109,19 @@ ao_scheme_do_inexactp(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_finitep(struct ao_scheme_cons *cons) { - ao_poly value; + ao_poly val; float f; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - value = ao_scheme_arg(cons, 0); - switch (ao_scheme_poly_type(value)) { + switch (ao_scheme_poly_type(val)) { case AO_SCHEME_INT: case AO_SCHEME_BIGINT: return _ao_scheme_bool_true; case AO_SCHEME_FLOAT: - f = ao_scheme_poly_float(value)->value; + f = ao_scheme_poly_float(val)->value; if (!isnan(f) && !isinf(f)) return _ao_scheme_bool_true; } @@ -126,15 +131,16 @@ ao_scheme_do_finitep(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_infinitep(struct ao_scheme_cons *cons) { - ao_poly value; + ao_poly val; float f; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - value = ao_scheme_arg(cons, 0); - switch (ao_scheme_poly_type(value)) { + switch (ao_scheme_poly_type(val)) { case AO_SCHEME_FLOAT: - f = ao_scheme_poly_float(value)->value; + f = ao_scheme_poly_float(val)->value; if (isinf(f)) return _ao_scheme_bool_true; } @@ -144,13 +150,12 @@ ao_scheme_do_infinitep(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_sqrt(struct ao_scheme_cons *cons) { - ao_poly value; + float f; - if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1)) + if (!ao_scheme_parse_args(_ao_scheme_atom_sqrt, cons, + AO_SCHEME_FLOAT, &f, + AO_SCHEME_ARG_END)) 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))); + return ao_scheme_float_get(sqrtf(f)); } #endif diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index 9ae5bb72..e4da279b 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -36,12 +36,12 @@ frame_vals_mark(void *addr) for (f = 0; f < vals->size; f++) { struct ao_scheme_val *v = &vals->vals[f]; + ao_scheme_poly_mark(v->atom, 0); ao_scheme_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d ", + MDBG_MOVE("frame mark atom %s %d val %d at %d\n", ao_scheme_poly_atom(v->atom)->name, MDBG_OFFSET(ao_scheme_ref(v->atom)), MDBG_OFFSET(ao_scheme_ref(v->val)), f); - MDBG_DO(printf("\n")); } } @@ -140,16 +140,16 @@ const struct ao_scheme_type ao_scheme_frame_type = { int ao_scheme_frame_print_indent; static void -ao_scheme_frame_indent(int extra) +ao_scheme_frame_indent(FILE *out, int extra) { int i; - putchar('\n'); + putc('\n', out); for (i = 0; i < ao_scheme_frame_print_indent+extra; i++) - putchar('\t'); + putc('\t', out); } void -ao_scheme_frame_write(ao_poly p, bool write) +ao_scheme_frame_write(FILE *out, ao_poly p, bool write) { struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); struct ao_scheme_frame *clear = frame; @@ -161,23 +161,23 @@ ao_scheme_frame_write(ao_poly p, bool write) struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); if (written != 0) - printf(", "); + fputs(", ", out); if (ao_scheme_print_mark_addr(frame)) { - printf("recurse..."); + fputs("recurse...", out); break; } - putchar('{'); + putc('{', out); written++; for (f = 0; f < frame->num; f++) { - ao_scheme_frame_indent(1); - ao_scheme_poly_write(vals->vals[f].atom, write); - printf(" = "); - ao_scheme_poly_write(vals->vals[f].val, write); + ao_scheme_frame_indent(out, 1); + ao_scheme_poly_write(out, vals->vals[f].atom, write); + fputs(" = ", out); + ao_scheme_poly_write(out, vals->vals[f].val, write); } frame = ao_scheme_poly_frame(frame->prev); - ao_scheme_frame_indent(0); - putchar('}'); + ao_scheme_frame_indent(out, 0); + putc('}', out); } if (ao_scheme_print_stop()) { while (written--) { @@ -345,6 +345,41 @@ ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) return val; } +#ifdef AO_SCHEME_FEATURE_UNDEF +ao_poly +ao_scheme_frame_del(struct ao_scheme_frame *frame, ao_poly atom) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = ao_scheme_frame_find(frame, frame->num, atom); + int f = frame->num; + struct ao_scheme_frame *moved_frame; + + if (l >= frame->num) + return _ao_scheme_bool_false; + + if (vals->vals[l].atom != atom) + return _ao_scheme_bool_false; + + /* squash the deleted entry */ + memmove(&vals->vals[l], + &vals->vals[l+1], + (f - l) * sizeof (struct ao_scheme_val)); + + /* allocate a smaller vals array */ + ao_scheme_frame_stash(frame); + moved_frame = ao_scheme_frame_realloc(frame, f - 1); + frame = ao_scheme_frame_fetch(); + + /* + * We couldn't allocate a smaller frame, so just + * ignore the last value in the array + */ + if (!moved_frame) + frame->num = f - 1; + return _ao_scheme_bool_true; +} +#endif + struct ao_scheme_frame *ao_scheme_frame_global; struct ao_scheme_frame *ao_scheme_frame_current; diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c index 01b571c0..2c9e45a0 100644 --- a/src/scheme/ao_scheme_int.c +++ b/src/scheme/ao_scheme_int.c @@ -15,28 +15,73 @@ #include "ao_scheme.h" void -ao_scheme_int_write(ao_poly p, bool write) +ao_scheme_int_write(FILE *out, ao_poly p, bool write) { int i = ao_scheme_poly_int(p); (void) write; - printf("%d", i); + fprintf(out, "%d", i); +} + +ao_poly +ao_scheme_do_integerp(struct ao_scheme_cons *cons) +{ +#ifdef AO_SCHEME_FEATURE_BIGINT + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(val)) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +#else + return ao_scheme_do_typep(_ao_scheme_atom_integer3f, AO_SCHEME_INT, cons); +#endif +} + +ao_poly +ao_scheme_do_numberp(struct ao_scheme_cons *cons) +{ +#if defined(AO_SCHEME_FEATURE_BIGINT) || defined(AO_SCHEME_FEATURE_FLOAT) + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(val)) { + case AO_SCHEME_INT: +#ifdef AO_SCHEME_FEATURE_BIGINT + case AO_SCHEME_BIGINT: +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT + case AO_SCHEME_FLOAT: +#endif + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +#else + return ao_scheme_do_integerp(cons); +#endif } #ifdef AO_SCHEME_FEATURE_BIGINT int32_t -ao_scheme_poly_integer(ao_poly p, bool *fail) +ao_scheme_poly_integer(ao_poly p) { - if (fail) - *fail = false; switch (ao_scheme_poly_base_type(p)) { case AO_SCHEME_INT: return ao_scheme_poly_int(p); case AO_SCHEME_BIGINT: return ao_scheme_poly_bigint(p)->value; } - if (fail) - *fail = true; return 0; } @@ -77,11 +122,11 @@ const struct ao_scheme_type ao_scheme_bigint_type = { }; void -ao_scheme_bigint_write(ao_poly p, bool write) +ao_scheme_bigint_write(FILE *out, ao_poly p, bool write) { struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); (void) write; - printf("%d", bi->value); + fprintf(out, "%d", bi->value); } #endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c index e818d7b0..18470efe 100644 --- a/src/scheme/ao_scheme_lambda.c +++ b/src/scheme/ao_scheme_lambda.c @@ -50,19 +50,19 @@ const struct ao_scheme_type ao_scheme_lambda_type = { }; void -ao_scheme_lambda_write(ao_poly poly, bool write) +ao_scheme_lambda_write(FILE *out, ao_poly poly, bool write) { struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly); struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code); - printf("("); - printf("%s", ao_scheme_args_name(lambda->args)); + putc('(', out); + fputs(ao_scheme_args_name(lambda->args), out); while (cons) { - printf(" "); - ao_scheme_poly_write(cons->car, write); + putc(' ', out); + ao_scheme_poly_write(out, cons->car, write); cons = ao_scheme_poly_cons(cons->cdr); } - printf(")"); + putc(')', out); } static ao_poly diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin index a4d8326f..5b76944f 100644 --- a/src/scheme/ao_scheme_make_builtin +++ b/src/scheme/ao_scheme_make_builtin @@ -227,6 +227,22 @@ dump_atom_names(builtin_t[*] builtins) { printf("#endif /* AO_SCHEME_BUILTIN_ATOM_NAMES */\n"); } +void +dump_syntax_atoms(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_SYNTAX_ATOMS\n"); + printf("#undef AO_SCHEME_BUILTIN_SYNTAX_ATOMS\n"); + printf("static const char *syntax_atoms[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (is_atom(builtins[i])) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf("\t\"%s\",\n", builtins[i].lisp_names[j]); + } + } + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_SYNTAX_ATOMS */\n"); +} + bool has_feature(string[*] features, string feature) { @@ -245,7 +261,9 @@ dump_features(builtin_t[*] builtins) { string feature = builtins[i].feature; if (!has_feature(features, feature)) { features[dim(features)] = feature; + printf("#ifndef AO_SCHEME_NO_FEATURE_%s\n", feature); printf("#define AO_SCHEME_FEATURE_%s\n", feature); + printf("#endif /* AO_SCHEME_NO_FEATURE_%s */\n", feature); } } } @@ -269,6 +287,7 @@ void main() { dump_consts(builtins); dump_atoms(builtins); dump_atom_names(builtins); + dump_syntax_atoms(builtins); dump_features(builtins); } } diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c index ae3afaa3..8561bf0b 100644 --- a/src/scheme/ao_scheme_make_const.c +++ b/src/scheme/ao_scheme_make_const.c @@ -270,18 +270,19 @@ ao_scheme_seen_builtin(struct ao_scheme_builtin *b) } static int -ao_scheme_read_eval_abort(void) +ao_scheme_read_eval_abort(FILE *read_file) { - ao_poly in, out = AO_SCHEME_NIL; + ao_poly in; + for(;;) { - in = ao_scheme_read(); + in = ao_scheme_read(read_file); if (in == _ao_scheme_atom_eof) break; - out = ao_scheme_eval(in); - if (ao_scheme_exception) + (void) ao_scheme_eval(in); + if (ao_scheme_exception) { + ao_scheme_fprintf(stderr, "make_const failed on %v\n", in); return 0; - ao_scheme_poly_write(out, true); - putchar ('\n'); + } } return 1; } @@ -307,8 +308,11 @@ ao_scheme_add_feature(struct feature **list, char *name) } static bool -ao_scheme_has_feature(struct feature *list, const char *name) +_ao_scheme_has_feature(struct feature *list, const char *name, bool skip_undef) { + if (skip_undef && !strcmp(name, "UNDEF")) + return false; + while (list) { if (!strcmp(list->name, name)) return true; @@ -317,6 +321,18 @@ ao_scheme_has_feature(struct feature *list, const char *name) return false; } +static bool +ao_scheme_has_undef(struct feature *list) +{ + return _ao_scheme_has_feature(list, "UNDEF", false); +} + +static bool +ao_scheme_has_feature(struct feature *list, const char *name) +{ + return _ao_scheme_has_feature(list, name, true); +} + static void ao_scheme_add_features(struct feature **list, const char *names) { @@ -430,7 +446,7 @@ main(int argc, char **argv) perror(argv[optind]); exit(1); } - if (!ao_scheme_read_eval_abort()) { + if (!ao_scheme_read_eval_abort(in)) { fprintf(stderr, "eval failed\n"); exit(1); } @@ -438,6 +454,14 @@ main(int argc, char **argv) optind++; } + if (!ao_scheme_has_undef(enable) && ao_scheme_has_undef(disable)) { + struct ao_scheme_cons cons; + + cons.car = _ao_scheme_atom_undef; + cons.cdr = AO_SCHEME_NIL; + ao_scheme_do_undef(&cons); + } + /* Reduce to referenced values */ ao_scheme_collect(AO_SCHEME_COLLECT_FULL); @@ -446,10 +470,10 @@ main(int argc, char **argv) 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, true); - printf("\n"); + fprintf(stderr, "error: function %s contains unresolved macro: ", + ao_scheme_poly_atom(vals->vals[f].atom)->name); + ao_scheme_poly_write(stderr, val, true); + fprintf(stderr, "\n"); exit(1); } diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index c9215072..94cbdfc1 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -213,10 +213,6 @@ static const struct ao_scheme_root ao_scheme_root[] = { .type = NULL, .addr = (void **) (void *) &stash_poly[5] }, - { - .type = &ao_scheme_atom_type, - .addr = (void **) &ao_scheme_atoms - }, { .type = &ao_scheme_frame_type, .addr = (void **) &ao_scheme_frame_global, @@ -245,6 +241,20 @@ static const struct ao_scheme_root ao_scheme_root[] = { .type = &ao_scheme_cons_type, .addr = (void **) &ao_scheme_read_stack, }, +#ifdef AO_SCHEME_FEATURE_PORT + { + .type = NULL, + .addr = (void **) (void *) &ao_scheme_stdin, + }, + { + .type = NULL, + .addr = (void **) (void *) &ao_scheme_stdout, + }, + { + .type = NULL, + .addr = (void **) (void *) &ao_scheme_stderr, + }, +#endif #ifdef AO_SCHEME_MAKE_CONST { .type = &ao_scheme_bool_type, @@ -297,7 +307,7 @@ struct ao_scheme_chunk { }; }; -#define AO_SCHEME_NCHUNK 64 +#define AO_SCHEME_NCHUNK (AO_SCHEME_POOL / 64) static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; @@ -489,6 +499,27 @@ dump_busy(void) #define DUMP_BUSY() #endif +#if MDBG_DUMP +static void +dump_atoms(int show_marked) +{ + struct ao_scheme_atom *atom; + + printf("atoms {\n"); + for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { + printf("\t%d: %s", MDBG_OFFSET(atom), atom->name); + if (show_marked) + printf(" %s", ao_scheme_marked(atom) ? "referenced" : "unreferenced"); + printf("\n"); + } + printf("}\n"); + +} +#define DUMP_ATOMS(a) dump_atoms(a) +#else +#define DUMP_ATOMS(a) +#endif + static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { [AO_SCHEME_CONS] = &ao_scheme_cons_type, [AO_SCHEME_INT] = NULL, @@ -510,6 +541,9 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = #ifdef AO_SCHEME_FEATURE_VECTOR [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, #endif +#ifdef AO_SCHEME_FEATURE_PORT + [AO_SCHEME_PORT] = &ao_scheme_port_type, +#endif }; static int @@ -553,7 +587,7 @@ ao_scheme_collect(uint8_t style) #endif MDBG_MOVE("collect %lu\n", ao_scheme_collects[style]); - MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + MDBG_DO(ao_scheme_frame_write(stdout, ao_scheme_frame_poly(ao_scheme_frame_global), true)); MDBG_DO(++ao_scheme_collecting); ao_scheme_reset_stack(); @@ -584,6 +618,11 @@ ao_scheme_collect(uint8_t style) reset_chunks(); walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +#ifdef AO_SCHEME_FEATURE_PORT + ao_scheme_port_check_references(); +#endif + ao_scheme_atom_check_references(); + #if DBG_MEM_RECORD ao_scheme_record_free(mark_record); mark_record = ao_scheme_record_save(); @@ -591,6 +630,7 @@ ao_scheme_collect(uint8_t style) ao_scheme_record_compare("mark", move_record, mark_record); #endif + DUMP_ATOMS(1); DUMP_BUSY(); /* Find the first moving object */ @@ -660,6 +700,13 @@ ao_scheme_collect(uint8_t style) if (chunk_first < chunk_last) { /* Relocate all references to the objects */ walk(ao_scheme_move, ao_scheme_poly_move); + ao_scheme_atom_move(); +#ifdef AO_SCHEME_FEATURE_PORT + /* the set of open ports gets relocated but not marked, so + * just deal with it separately + */ + ao_scheme_poly_move(&ao_scheme_open_ports, 0); +#endif #if DBG_MEM_RECORD ao_scheme_record_free(move_record); @@ -667,6 +714,7 @@ ao_scheme_collect(uint8_t style) if (mark_record && move_record) ao_scheme_record_compare("move", mark_record, move_record); #endif + DUMP_ATOMS(0); } #if DBG_MEM_STATS @@ -764,7 +812,7 @@ static int ao_scheme_mark(const struct ao_scheme_type *type, void *addr) { int ret; - MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE("mark offset %d\n", MDBG_OFFSET(addr)); MDBG_MOVE_IN(); ret = ao_scheme_mark_memory(type, addr); if (!ret) { @@ -813,7 +861,7 @@ ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) ao_scheme_abort(); #endif - MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE("poly_mark offset %d\n", MDBG_OFFSET(addr)); MDBG_MOVE_IN(); ret = ao_scheme_mark_memory(lisp_type, addr); if (!ret) { @@ -947,6 +995,14 @@ ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) return ret; } +int +ao_scheme_marked(void *addr) +{ + if (!ao_scheme_is_pool_addr(addr)) + return 1; + return busy(ao_scheme_busy, pool_offset(addr)); +} + #if DBG_MEM static void ao_scheme_validate(void) diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 0cffc196..8a92c9f2 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -14,13 +14,13 @@ #include "ao_scheme.h" -static void ao_scheme_invalid_write(ao_poly p, bool write) { - printf("??? type %d poly 0x%04x ???", ao_scheme_poly_type (p), p); +static void ao_scheme_invalid_write(FILE *out, ao_poly p, bool write) { + fprintf(out, "??? type %d poly 0x%04x ???", ao_scheme_poly_type (p), p); (void) write; ao_scheme_abort(); } -static void (*const ao_scheme_write_funcs[AO_SCHEME_NUM_TYPE]) (ao_poly p, bool write) = { +static void (*const ao_scheme_write_funcs[AO_SCHEME_NUM_TYPE]) (FILE *out, ao_poly p, bool write) = { [AO_SCHEME_CONS] = ao_scheme_cons_write, #ifdef AO_SCHEME_FEATURE_BIGINT [AO_SCHEME_BIGINT] = ao_scheme_bigint_write, @@ -40,9 +40,12 @@ static void (*const ao_scheme_write_funcs[AO_SCHEME_NUM_TYPE]) (ao_poly p, bool #ifdef AO_SCHEME_FEATURE_VECTOR [AO_SCHEME_VECTOR] = ao_scheme_vector_write, #endif +#ifdef AO_SCHEME_FEATURE_PORT + [AO_SCHEME_PORT] = ao_scheme_port_write, +#endif }; -void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p, bool write) +void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write) { uint8_t type = ao_scheme_poly_type(p); diff --git a/src/scheme/ao_scheme_port.c b/src/scheme/ao_scheme_port.c new file mode 100644 index 00000000..b5e5d8dc --- /dev/null +++ b/src/scheme/ao_scheme_port.c @@ -0,0 +1,193 @@ +/* + * Copyright © 2018 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +#ifdef AO_SCHEME_FEATURE_PORT + +static void port_mark(void *addr) +{ + (void) addr; +} + +static int port_size(void *addr) +{ + (void) addr; + return sizeof(struct ao_scheme_port); +} + +static void port_move(void *addr) +{ + struct ao_scheme_port *port = addr; + + (void) ao_scheme_poly_move(&port->next, 0); +} + +const struct ao_scheme_type ao_scheme_port_type = { + .mark = port_mark, + .size = port_size, + .move = port_move, + .name = "port", +}; + +void +ao_scheme_port_write(FILE *out, ao_poly v, bool write) +{ + (void) write; + ao_scheme_fprintf(out, "#port<%d>", fileno(ao_scheme_poly_port(v)->file)); +} + +ao_poly ao_scheme_stdin, ao_scheme_stdout, ao_scheme_stderr; + +ao_poly ao_scheme_open_ports; + +void +ao_scheme_port_check_references(void) +{ + struct ao_scheme_port *p; + + for (p = ao_scheme_poly_port(ao_scheme_open_ports); p; p = ao_scheme_poly_port(p->next)) { + if (!ao_scheme_marked(p)) + ao_scheme_port_close(p); + } +} + +struct ao_scheme_port * +ao_scheme_port_alloc(FILE *file, bool stayopen) +{ + struct ao_scheme_port *p; + + p = ao_scheme_alloc(sizeof (struct ao_scheme_port)); + if (!p) + return NULL; + p->type = AO_SCHEME_PORT; + p->stayopen = stayopen; + p->file = file; + p->next = ao_scheme_open_ports; + ao_scheme_open_ports = ao_scheme_port_poly(p); + return p; +} + +void +ao_scheme_port_close(struct ao_scheme_port *port) +{ + ao_poly *prev; + struct ao_scheme_port *ref; + + if (port->file && !port->stayopen) { + fclose(port->file); + port->file = NULL; + for (prev = &ao_scheme_open_ports; (ref = ao_scheme_poly_port(*prev)); prev = &ref->next) + if (ref == port) { + *prev = port->next; + break; + } + } +} + +ao_poly +ao_scheme_do_portp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(_ao_scheme_atom_port3f, AO_SCHEME_PORT, cons); +} + +ao_poly +ao_scheme_do_port_openp(struct ao_scheme_cons *cons) +{ + struct ao_scheme_port *port; + + if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons, + AO_SCHEME_PORT, &port, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return port->file ? _ao_scheme_bool_true : _ao_scheme_bool_false; +} + +static ao_poly +ao_scheme_do_open_file(ao_poly proc, struct ao_scheme_cons *cons, const char *mode) +{ + FILE *file; + struct ao_scheme_string *name; + + if (!ao_scheme_parse_args(proc, cons, + AO_SCHEME_STRING, &name, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + file = fopen(name->val, mode); + if (!file) + return ao_scheme_error(AO_SCHEME_FILEERROR, + "%v: no such file \"%v\"", + proc, name); + return ao_scheme_port_poly(ao_scheme_port_alloc(file, false)); +} + +ao_poly +ao_scheme_do_open_input_file(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_open_file(_ao_scheme_atom_open2dinput2dfile, cons, "r"); +} + +ao_poly +ao_scheme_do_open_output_file(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_open_file(_ao_scheme_atom_open2doutput2dfile, cons, "w"); +} + +ao_poly +ao_scheme_do_close_port(struct ao_scheme_cons *cons) +{ + struct ao_scheme_port *port; + + if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons, + AO_SCHEME_PORT, &port, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + ao_scheme_port_close(port); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_current_input_port(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_parse_args(_ao_scheme_atom_current2dinput2dport, cons, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (!ao_scheme_stdin) + ao_scheme_stdin = ao_scheme_port_poly(ao_scheme_port_alloc(stdin, true)); + return ao_scheme_stdin; +} + +ao_poly +ao_scheme_do_current_output_port(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_parse_args(_ao_scheme_atom_current2doutput2dport, cons, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (!ao_scheme_stdout) + ao_scheme_stdout = ao_scheme_port_poly(ao_scheme_port_alloc(stdout, true)); + return ao_scheme_stdout; +} + +ao_poly +ao_scheme_do_current_error_port(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_parse_args(_ao_scheme_atom_current2derror2dport, cons, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (!ao_scheme_stderr) + ao_scheme_stderr = ao_scheme_port_poly(ao_scheme_port_alloc(stderr, true)); + return ao_scheme_stderr; +} + +#endif /* AO_SCHEME_FEATURE_PORT */ diff --git a/src/scheme/ao_scheme_port.scheme b/src/scheme/ao_scheme_port.scheme new file mode 100644 index 00000000..e4fa06cc --- /dev/null +++ b/src/scheme/ao_scheme_port.scheme @@ -0,0 +1,39 @@ +; +; Copyright © 2018 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; port functions placed in ROM + + +(define newline + (lambda args + (if (null? args) + (write-char #\newline) + (write-char #\newline (car args)) + ) + ) + ) + +(newline) +(newline (open-output-file "/dev/null")) + +(define (load name) + (let ((p (open-input-file name)) + (e)) + (while (not (eof-object? (set! e (read p)))) + (write (eval e)) (newline) + ) + (close-port p) + ) + ) + +(load "/dev/null") diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index f7e95a63..a26965f2 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -18,147 +18,147 @@ #include static const uint16_t lex_classes[128] = { - IGNORE, /* ^@ */ - IGNORE, /* ^A */ - IGNORE, /* ^B */ - IGNORE, /* ^C */ - IGNORE, /* ^D */ - IGNORE, /* ^E */ - IGNORE, /* ^F */ - IGNORE, /* ^G */ - IGNORE, /* ^H */ - WHITE, /* ^I */ - WHITE, /* ^J */ - WHITE, /* ^K */ - WHITE, /* ^L */ - WHITE, /* ^M */ - IGNORE, /* ^N */ - IGNORE, /* ^O */ - IGNORE, /* ^P */ - IGNORE, /* ^Q */ - IGNORE, /* ^R */ - IGNORE, /* ^S */ - IGNORE, /* ^T */ - IGNORE, /* ^U */ - IGNORE, /* ^V */ - IGNORE, /* ^W */ - IGNORE, /* ^X */ - IGNORE, /* ^Y */ - IGNORE, /* ^Z */ - IGNORE, /* ^[ */ - IGNORE, /* ^\ */ - IGNORE, /* ^] */ - IGNORE, /* ^^ */ - IGNORE, /* ^_ */ - PRINTABLE|WHITE, /* */ - PRINTABLE, /* ! */ - PRINTABLE|STRINGC, /* " */ - PRINTABLE, /* # */ - PRINTABLE, /* $ */ - PRINTABLE, /* % */ - PRINTABLE, /* & */ - PRINTABLE|SPECIAL, /* ' */ - PRINTABLE|SPECIAL, /* ( */ - PRINTABLE|SPECIAL, /* ) */ - PRINTABLE, /* * */ - PRINTABLE|SIGN, /* + */ + IGNORE, /* ^@ */ + IGNORE, /* ^A */ + IGNORE, /* ^B */ + IGNORE, /* ^C */ + IGNORE, /* ^D */ + IGNORE, /* ^E */ + IGNORE, /* ^F */ + IGNORE, /* ^G */ + IGNORE, /* ^H */ + WHITE, /* ^I */ + WHITE, /* ^J */ + WHITE, /* ^K */ + WHITE, /* ^L */ + WHITE, /* ^M */ + IGNORE, /* ^N */ + IGNORE, /* ^O */ + IGNORE, /* ^P */ + IGNORE, /* ^Q */ + IGNORE, /* ^R */ + IGNORE, /* ^S */ + IGNORE, /* ^T */ + IGNORE, /* ^U */ + IGNORE, /* ^V */ + IGNORE, /* ^W */ + IGNORE, /* ^X */ + IGNORE, /* ^Y */ + IGNORE, /* ^Z */ + IGNORE, /* ^[ */ + IGNORE, /* ^\ */ + IGNORE, /* ^] */ + IGNORE, /* ^^ */ + IGNORE, /* ^_ */ + PRINTABLE|WHITE, /* */ + PRINTABLE, /* ! */ + PRINTABLE|STRINGC, /* " */ + PRINTABLE, /* # */ + PRINTABLE, /* $ */ + PRINTABLE, /* % */ + PRINTABLE, /* & */ + PRINTABLE|SPECIAL, /* ' */ + PRINTABLE|SPECIAL, /* ( */ + PRINTABLE|SPECIAL, /* ) */ + PRINTABLE, /* * */ + PRINTABLE|SIGN, /* + */ PRINTABLE|SPECIAL_QUASI, /* , */ - PRINTABLE|SIGN, /* - */ - PRINTABLE|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|HEX_LETTER, /* A */ - PRINTABLE|HEX_LETTER, /* B */ - PRINTABLE|HEX_LETTER, /* C */ - PRINTABLE|HEX_LETTER, /* D */ - PRINTABLE|FLOATC|HEX_LETTER,/* E */ - PRINTABLE|HEX_LETTER, /* 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, /* ^ */ - PRINTABLE, /* _ */ + PRINTABLE|SIGN, /* - */ + PRINTABLE|SPECIAL|FLOATC, /* . */ + PRINTABLE, /* / */ + PRINTABLE|DIGIT, /* 0 */ + PRINTABLE|DIGIT, /* 1 */ + PRINTABLE|DIGIT, /* 2 */ + PRINTABLE|DIGIT, /* 3 */ + PRINTABLE|DIGIT, /* 4 */ + PRINTABLE|DIGIT, /* 5 */ + PRINTABLE|DIGIT, /* 6 */ + PRINTABLE|DIGIT, /* 7 */ + PRINTABLE|DIGIT, /* 8 */ + PRINTABLE|DIGIT, /* 9 */ + PRINTABLE, /* : */ + PRINTABLE|COMMENT, /* ; */ + PRINTABLE, /* < */ + PRINTABLE, /* = */ + PRINTABLE, /* > */ + PRINTABLE, /* ? */ + PRINTABLE, /* @ */ + PRINTABLE|ALPHA|HEX_LETTER, /* A */ + PRINTABLE|ALPHA|HEX_LETTER, /* B */ + PRINTABLE|ALPHA|HEX_LETTER, /* C */ + PRINTABLE|ALPHA|HEX_LETTER, /* D */ + PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/* E */ + PRINTABLE|ALPHA|HEX_LETTER, /* F */ + PRINTABLE|ALPHA, /* G */ + PRINTABLE|ALPHA, /* H */ + PRINTABLE|ALPHA, /* I */ + PRINTABLE|ALPHA, /* J */ + PRINTABLE|ALPHA, /* K */ + PRINTABLE|ALPHA, /* L */ + PRINTABLE|ALPHA, /* M */ + PRINTABLE|ALPHA, /* N */ + PRINTABLE|ALPHA, /* O */ + PRINTABLE|ALPHA, /* P */ + PRINTABLE|ALPHA, /* Q */ + PRINTABLE|ALPHA, /* R */ + PRINTABLE|ALPHA, /* S */ + PRINTABLE|ALPHA, /* T */ + PRINTABLE|ALPHA, /* U */ + PRINTABLE|ALPHA, /* V */ + PRINTABLE|ALPHA, /* W */ + PRINTABLE|ALPHA, /* X */ + PRINTABLE|ALPHA, /* Y */ + PRINTABLE|ALPHA, /* Z */ + PRINTABLE, /* [ */ + PRINTABLE, /* \ */ + PRINTABLE, /* ] */ + PRINTABLE, /* ^ */ + PRINTABLE, /* _ */ PRINTABLE|SPECIAL_QUASI, /* ` */ - PRINTABLE|HEX_LETTER, /* a */ - PRINTABLE|HEX_LETTER, /* b */ - PRINTABLE|HEX_LETTER, /* c */ - PRINTABLE|HEX_LETTER, /* d */ - PRINTABLE|FLOATC|HEX_LETTER,/* e */ - PRINTABLE|HEX_LETTER, /* 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, /* ^? */ + PRINTABLE|ALPHA|HEX_LETTER, /* a */ + PRINTABLE|ALPHA|HEX_LETTER, /* b */ + PRINTABLE|ALPHA|HEX_LETTER, /* c */ + PRINTABLE|ALPHA|HEX_LETTER, /* d */ + PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/* e */ + PRINTABLE|ALPHA|HEX_LETTER, /* f */ + PRINTABLE|ALPHA, /* g */ + PRINTABLE|ALPHA, /* h */ + PRINTABLE|ALPHA, /* i */ + PRINTABLE|ALPHA, /* j */ + PRINTABLE|ALPHA, /* k */ + PRINTABLE|ALPHA, /* l */ + PRINTABLE|ALPHA, /* m */ + PRINTABLE|ALPHA, /* n */ + PRINTABLE|ALPHA, /* o */ + PRINTABLE|ALPHA, /* p */ + PRINTABLE|ALPHA, /* q */ + PRINTABLE|ALPHA, /* r */ + PRINTABLE|ALPHA, /* s */ + PRINTABLE|ALPHA, /* t */ + PRINTABLE|ALPHA, /* u */ + PRINTABLE|ALPHA, /* v */ + PRINTABLE|ALPHA, /* w */ + PRINTABLE|ALPHA, /* x */ + PRINTABLE|ALPHA, /* y */ + PRINTABLE|ALPHA, /* z */ + PRINTABLE, /* { */ + PRINTABLE, /* | */ + PRINTABLE, /* } */ + PRINTABLE, /* ~ */ + IGNORE, /* ^? */ }; static int lex_unget_c; static inline int -lex_get(void) +lex_get(FILE *in) { int c; if (lex_unget_c) { c = lex_unget_c; lex_unget_c = 0; } else { - c = ao_scheme_getc(); + c = getc(in); } return c; } @@ -173,11 +173,11 @@ lex_unget(int c) static uint16_t lex_class; static int -lexc(void) +lexc(FILE *in) { int c; do { - c = lex_get(); + c = lex_get(in); if (c == EOF) { c = 0; lex_class = ENDOFFILE; @@ -190,14 +190,15 @@ lexc(void) } static int -lex_quoted(void) +lex_quoted(FILE *in) { int c; int v; int count; - c = lex_get(); + c = lex_get(in); if (c == EOF) { + eof: lex_class = ENDOFFILE; return 0; } @@ -229,9 +230,9 @@ lex_quoted(void) v = c - '0'; count = 1; while (count <= 3) { - c = lex_get(); + c = lex_get(in); if (c == EOF) - return EOF; + goto eof; c &= 0x7f; if (c < '0' || '7' < c) { lex_unget(c); @@ -254,17 +255,16 @@ static char token_string[AO_SCHEME_TOKEN_MAX]; static int32_t token_int; static int token_len; -static inline void add_token(int c) { - if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) - token_string[token_len++] = c; +static void start_token(void) { + token_len = 0; } -static inline void del_token(void) { - if (token_len > 0) - token_len--; +static void add_token(int c) { + if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) + token_string[token_len++] = c; } -static inline void end_token(void) { +static void end_token(void) { token_string[token_len] = '\0'; } @@ -287,20 +287,18 @@ static const struct namedfloat namedfloats[] = { #endif static int -parse_int(int base) +parse_int(FILE *in, int base) { int cval; int c; token_int = 0; for (;;) { - c = lexc(); + c = lexc(in); if ((lex_class & HEX_DIGIT) == 0) { lex_unget(c); - end_token(); return NUM; } - add_token(c); if ('0' <= c && c <= '9') cval = c - '0'; else @@ -311,13 +309,13 @@ parse_int(int base) } static int -_lex(void) +_lex(FILE *in) { int c; - token_len = 0; + start_token(); for (;;) { - c = lexc(); + c = lexc(in); if (lex_class & ENDOFFILE) return END; @@ -325,16 +323,14 @@ _lex(void) continue; if (lex_class & COMMENT) { - while ((c = lexc()) != '\n') { + while ((c = lexc(in)) != '\n') { if (lex_class & ENDOFFILE) return END; } continue; } - if (lex_class & (SPECIAL|DOTC)) { - add_token(c); - end_token(); + if (lex_class & SPECIAL) { switch (c) { case '(': case '[': @@ -350,10 +346,8 @@ _lex(void) case '`': return QUASIQUOTE; case ',': - c = lexc(); + c = lexc(in); if (c == '@') { - add_token(c); - end_token(); return UNQUOTE_SPLICING; } else { lex_unget(c); @@ -363,31 +357,25 @@ _lex(void) } } if (c == '#') { - c = lexc(); + c = lexc(in); switch (c) { case 't': - add_token(c); - end_token(); - return BOOL; + return TRUE_TOKEN; case 'f': - add_token(c); - end_token(); - return BOOL; + return FALSE_TOKEN; #ifdef AO_SCHEME_FEATURE_VECTOR case '(': return OPEN_VECTOR; #endif case '\\': for (;;) { - int alphabetic; - c = lexc(); - alphabetic = (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')); + c = lexc(in); if (token_len == 0) { add_token(c); - if (!alphabetic) + if (!(lex_class & ALPHA)) break; } else { - if (alphabetic) + if (lex_class & ALPHA) add_token(c); else { lex_unget(c); @@ -414,18 +402,18 @@ _lex(void) } return NUM; case 'x': - return parse_int(16); + return parse_int(in, 16); case 'o': - return parse_int(8); + return parse_int(in, 8); case 'b': - return parse_int(2); + return parse_int(in, 2); } } if (lex_class & STRINGC) { for (;;) { - c = lexc(); + c = lexc(in); if (c == '\\') - c = lex_quoted(); + c = lex_quoted(in); if (lex_class & (STRINGC|ENDOFFILE)) { end_token(); return STRING; @@ -479,7 +467,7 @@ _lex(void) } } add_token (c); - c = lexc (); + c = lexc (in); if ((lex_class & (NOTNAME)) #ifdef AO_SCHEME_FEATURE_FLOAT && (c != '.' || !isfloat) @@ -488,8 +476,6 @@ _lex(void) #ifdef AO_SCHEME_FEATURE_FLOAT unsigned int u; #endif -// if (lex_class & ENDOFFILE) -// clearerr (f); lex_unget(c); end_token (); if (isint && hasdigit) { @@ -515,9 +501,9 @@ _lex(void) } } -static inline int lex(void) +static inline int lex(FILE *in) { - int parse_token = _lex(); + int parse_token = _lex(in); RDBGI("token %d \"%s\"\n", parse_token, token_string); return parse_token; } @@ -585,7 +571,7 @@ pop_read_stack(void) #endif ao_poly -ao_scheme_read(void) +ao_scheme_read(FILE *in) { struct ao_scheme_atom *atom; struct ao_scheme_string *string; @@ -596,7 +582,7 @@ ao_scheme_read(void) read_state = 0; ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = NULL; for (;;) { - parse_token = lex(); + parse_token = lex(in); while (is_open(parse_token)) { #ifdef AO_SCHEME_FEATURE_VECTOR if (parse_token == OPEN_VECTOR) @@ -606,7 +592,7 @@ ao_scheme_read(void) return AO_SCHEME_NIL; ao_scheme_read_list++; read_state = 0; - parse_token = lex(); + parse_token = lex(in); } switch (parse_token) { @@ -631,11 +617,11 @@ ao_scheme_read(void) v = ao_scheme_float_get(token_float); break; #endif - case BOOL: - if (token_string[0] == 't') - v = _ao_scheme_bool_true; - else - v = _ao_scheme_bool_false; + case TRUE_TOKEN: + v = _ao_scheme_bool_true; + break; + case FALSE_TOKEN: + v = _ao_scheme_bool_false; break; case STRING: string = ao_scheme_string_new(token_string); diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index 209a3a87..34739c9e 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -35,9 +35,10 @@ # define FLOAT 10 #endif # define DOT 11 -# define BOOL 12 +# define TRUE_TOKEN 12 +# define FALSE_TOKEN 13 #ifdef AO_SCHEME_FEATURE_VECTOR -# define OPEN_VECTOR 13 +# define OPEN_VECTOR 14 #endif /* @@ -51,7 +52,8 @@ #else # define SPECIAL_QUASI 0 #endif -# define DOTC 0x0004 /* . */ +# +# define ALPHA 0x0004 /* A-Z a-z */ # define WHITE 0x0008 /* ' ' \t \n */ # define DIGIT 0x0010 /* [0-9] */ # define SIGN 0x0020 /* +- */ diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c index b35ba5b8..49ab0559 100644 --- a/src/scheme/ao_scheme_rep.c +++ b/src/scheme/ao_scheme_rep.c @@ -15,13 +15,15 @@ #include "ao_scheme.h" ao_poly -ao_scheme_read_eval_print(void) +ao_scheme_read_eval_print(FILE *read_file, FILE *write_file, bool interactive) { ao_poly in, out = AO_SCHEME_NIL; ao_scheme_exception = 0; for(;;) { - in = ao_scheme_read(); + if (interactive) + fputs("> ", write_file); + in = ao_scheme_read(read_file); if (in == _ao_scheme_atom_eof) break; out = ao_scheme_eval(in); @@ -30,8 +32,10 @@ ao_scheme_read_eval_print(void) break; ao_scheme_exception = 0; } else { - ao_scheme_poly_write(out, true); - putchar ('\n'); + if (write_file) { + ao_scheme_poly_write(write_file, out, true); + putc('\n', write_file); + } } } return out; diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c index 3a595d71..0ef547d8 100644 --- a/src/scheme/ao_scheme_save.c +++ b/src/scheme/ao_scheme_save.c @@ -14,17 +14,17 @@ #include "ao_scheme.h" +#ifdef AO_SCHEME_FEATURE_SAVE ao_poly ao_scheme_do_save(struct ao_scheme_cons *cons) { -#ifdef AO_SCHEME_SAVE +#ifndef AO_SCHEME_MAKE_CONST struct ao_scheme_os_save *os; -#endif - if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + if (!ao_scheme_parse_args(_ao_scheme_atom_save, cons, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; -#ifdef AO_SCHEME_SAVE os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; ao_scheme_collect(AO_SCHEME_COLLECT_FULL); @@ -35,6 +35,8 @@ ao_scheme_do_save(struct ao_scheme_cons *cons) if (ao_scheme_os_save()) return _ao_scheme_bool_true; +#else + (void) cons; #endif return _ao_scheme_bool_false; } @@ -42,14 +44,13 @@ ao_scheme_do_save(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_restore(struct ao_scheme_cons *cons) { -#ifdef AO_SCHEME_SAVE +#ifndef AO_SCHEME_MAKE_CONST struct ao_scheme_os_save save; struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; -#endif - if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + if (!ao_scheme_parse_args(_ao_scheme_atom_restore, cons, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; -#ifdef AO_SCHEME_SAVE os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) @@ -79,6 +80,10 @@ ao_scheme_do_restore(struct ao_scheme_cons *cons) return _ao_scheme_bool_true; } +#else + (void) cons; #endif return _ao_scheme_bool_false; } + +#endif /* AO_SCHEME_FEATURE_SAVE */ diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c index 863df3ca..d3b5d4b7 100644 --- a/src/scheme/ao_scheme_stack.c +++ b/src/scheme/ao_scheme_stack.c @@ -28,11 +28,11 @@ 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); + ao_scheme_poly_mark(stack->sexprs, 1); + ao_scheme_poly_mark(stack->values, 1); /* no need to mark values_tail */ ao_scheme_poly_mark(stack->frame, 0); - ao_scheme_poly_mark(stack->list, 0); + ao_scheme_poly_mark(stack->list, 1); stack = ao_scheme_poly_stack(stack->prev); if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) break; @@ -47,11 +47,11 @@ stack_move(void *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->sexprs, 1); + (void) ao_scheme_poly_move(&stack->values, 1); (void) ao_scheme_poly_move(&stack->values_tail, 0); (void) ao_scheme_poly_move(&stack->frame, 0); - (void) ao_scheme_poly_move(&stack->list, 0); + (void) ao_scheme_poly_move(&stack->list, 1); prev = ao_scheme_poly_stack(stack->prev); if (!prev) break; @@ -150,15 +150,7 @@ ao_scheme_stack_pop(void) } 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, bool write) +ao_scheme_stack_write(FILE *out, ao_poly poly, bool write) { struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); struct ao_scheme_stack *clear = s; @@ -169,15 +161,15 @@ ao_scheme_stack_write(ao_poly poly, bool write) ao_scheme_frame_print_indent += 2; while (s) { if (ao_scheme_print_mark_addr(s)) { - printf("[recurse...]"); + fputs("[recurse...]", out); break; } written++; - printf("\t[\n"); - ao_scheme_printf("\t\texpr: %v\n", s->list); - ao_scheme_printf("\t\tvalues: %v\n", s->values); - ao_scheme_printf("\t\tframe: %v\n", s->frame); - printf("\t]\n"); + fputs("\t[\n", out); + ao_scheme_fprintf(out, "\t\texpr: %v\n", s->list); + ao_scheme_fprintf(out, "\t\tvalues: %v\n", s->values); + ao_scheme_fprintf(out, "\t\tframe: %v\n", s->frame); + fputs("\t]\n", out); s = ao_scheme_poly_stack(s->prev); } ao_scheme_frame_print_indent -= 2; @@ -258,21 +250,19 @@ 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)) + if (!ao_scheme_parse_args(_ao_scheme_atom_call2fcc, cons, + AO_SCHEME_LAMBDA|AO_SCHEME_ARG_RET_POLY, &v, + AO_SCHEME_ARG_END)) return AO_SCHEME_NIL; - 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); + ao_scheme_poly_stash(v); /* Note that the whole call chain now has * a reference to it which may escape */ new = ao_scheme_stack_copy(ao_scheme_stack); if (!new) return AO_SCHEME_NIL; + v = ao_scheme_poly_fetch(); /* re-fetch cons after the allocation */ cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); @@ -283,8 +273,7 @@ ao_scheme_do_call_cc(struct ao_scheme_cons *cons) 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; + + ao_scheme_stack->state = eval_exec; + return v; } diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index 2c636d7a..c49e1e32 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -55,33 +55,6 @@ ao_scheme_string_alloc(int len) return s; } -struct ao_scheme_string * -ao_scheme_string_copy(struct ao_scheme_string *a) -{ - int alen = strlen(a->val); - struct ao_scheme_string *r; - - ao_scheme_string_stash(a); - r = ao_scheme_string_alloc(alen); - a = ao_scheme_string_fetch(); - if (!r) - return NULL; - strcpy(r->val, a->val); - return r; -} - -struct ao_scheme_string * -ao_scheme_make_string(int32_t len, char fill) -{ - struct ao_scheme_string *r; - - r = ao_scheme_string_alloc(len); - if (!r) - return NULL; - memset(r->val, fill, len); - return r; -} - struct ao_scheme_string * ao_scheme_string_new(char *a) { @@ -128,111 +101,247 @@ ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) return r; } -ao_poly +static ao_poly ao_scheme_string_pack(struct ao_scheme_cons *cons) { - struct ao_scheme_string *r; - char *rval; + struct ao_scheme_string *string; + char *s; int len; len = ao_scheme_cons_length(cons); ao_scheme_cons_stash(cons); - r = ao_scheme_string_alloc(len); + string = ao_scheme_string_alloc(len); cons = ao_scheme_cons_fetch(); - if (!r) + if (!string) return AO_SCHEME_NIL; - rval = r->val; + s = string->val; while (cons) { - bool fail = false; ao_poly car = cons->car; - *rval++ = ao_scheme_poly_integer(car, &fail); - if (fail) - return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); + int32_t c; + if (!ao_scheme_is_integer(car) || (c = ao_scheme_poly_integer(car)) == 0) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: Invalid %v", _ao_scheme_atom_list2d3estring, car); + *s++ = c; cons = ao_scheme_cons_cdr(cons); } - return ao_scheme_string_poly(r); + return ao_scheme_string_poly(string); } -ao_poly +static ao_poly ao_scheme_string_unpack(struct ao_scheme_string *a) { - struct ao_scheme_cons *cons = NULL, *tail = NULL; - int c; - int i; + ao_poly cons = AO_SCHEME_NIL; + int i; - for (i = 0; (c = a->val[i]); i++) { - struct ao_scheme_cons *n; - ao_scheme_cons_stash(cons); - ao_scheme_cons_stash(tail); + for (i = strlen(a->val); --i >= 0;) { ao_scheme_string_stash(a); - n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); + cons = ao_scheme_cons(ao_scheme_int_poly(a->val[i]), cons); a = ao_scheme_string_fetch(); - tail = ao_scheme_cons_fetch(); - cons = ao_scheme_cons_fetch(); - - if (!n) { - cons = NULL; + if (!cons) break; - } - if (tail) - tail->cdr = ao_scheme_cons_poly(n); - else - cons = n; - tail = n; } - return ao_scheme_cons_poly(cons); + return cons; } void -ao_scheme_string_write(ao_poly p, bool write) +ao_scheme_string_write(FILE *out, ao_poly p, bool write) { struct ao_scheme_string *s = ao_scheme_poly_string(p); char *sval = s->val; char c; if (write) { - putchar('"'); + putc('"', out); while ((c = *sval++)) { switch (c) { case '\a': - printf("\\a"); + fputs("\\a", out); break; case '\b': - printf("\\b"); + fputs("\\b", out); break; case '\t': - printf ("\\t"); + fputs("\\t", out); break; case '\n': - printf ("\\n"); + fputs("\\n", out); break; case '\r': - printf ("\\r"); + fputs("\\r", out); break; case '\f': - printf("\\f"); + fputs("\\f", out); break; case '\v': - printf("\\v"); + fputs("\\v", out); break; case '\"': - printf("\\\""); + fputs("\\\"", out); break; case '\\': - printf("\\\\"); + fputs("\\\\", out); break; default: if (c < ' ') - printf("\\%03o", c); + fprintf(out, "\\%03o", c); else - putchar(c); + putc(c, out); break; } } - putchar('"'); + putc('"', out); } else { while ((c = *sval++)) - putchar(c); + putc(c, out); } } + +ao_poly +ao_scheme_do_stringp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(_ao_scheme_atom_string3f, AO_SCHEME_STRING, cons); +} + +ao_poly +ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *list; + + if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3estring, cons, + AO_SCHEME_CONS, &list, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_string_pack(list); +} + +ao_poly +ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) +{ + struct ao_scheme_string *string; + + if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3elist, cons, + AO_SCHEME_STRING, &string, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_string_unpack(string); +} + +static char * +ao_scheme_string_ref(struct ao_scheme_string *string, int32_t r) +{ + char *s = string->val; + while (*s && r) { + ++s; + --r; + } + return s; +} + +ao_poly +ao_scheme_do_string_ref(struct ao_scheme_cons *cons) +{ + struct ao_scheme_string *string; + int32_t ref; + char *s; + + if (!ao_scheme_parse_args(_ao_scheme_atom_string2dref, cons, + AO_SCHEME_STRING, &string, + AO_SCHEME_INT, &ref, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + + s = ao_scheme_string_ref(string, ref); + if (!*s) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", + _ao_scheme_atom_string2dref, + cons->car, + ao_scheme_arg(cons, 1)); + return ao_scheme_integer_poly(*s); +} + +ao_poly +ao_scheme_do_string_length(struct ao_scheme_cons *cons) +{ + struct ao_scheme_string *string; + + if (!ao_scheme_parse_args(_ao_scheme_atom_string2dlength, cons, + AO_SCHEME_STRING, &string, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_integer_poly(strlen(string->val)); +} + +ao_poly +ao_scheme_do_string_set(struct ao_scheme_cons *cons) +{ + struct ao_scheme_string *string; + int32_t ref; + int32_t val; + char *s; + + if (!ao_scheme_parse_args(_ao_scheme_atom_string2dset21, cons, + AO_SCHEME_STRING, &string, + AO_SCHEME_INT, &ref, + AO_SCHEME_INT, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (!val) + goto fail; + s = ao_scheme_string_ref(string, ref); + if (!*s) + goto fail; + *s = val; + return ao_scheme_integer_poly(val); +fail: + return ao_scheme_error(AO_SCHEME_INVALID, "%v: %v[%v] = %v invalid", + _ao_scheme_atom_string2dset21, + ao_scheme_arg(cons, 0), + ao_scheme_arg(cons, 1), + ao_scheme_arg(cons, 2)); +} + +ao_poly +ao_scheme_do_make_string(struct ao_scheme_cons *cons) +{ + int32_t len; + int32_t fill; + struct ao_scheme_string *string; + + if (!ao_scheme_parse_args(_ao_scheme_atom_make2dstring, cons, + AO_SCHEME_INT, &len, + AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(' '), &fill, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (!fill) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: fill 0 invalid", + _ao_scheme_atom_make2dstring); + string = ao_scheme_string_alloc(len); + if (!string) + return AO_SCHEME_NIL; + memset(string->val, fill, len); + return ao_scheme_string_poly(string); +} + +ao_poly +ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) +{ + struct ao_scheme_atom *atom; + + if (!ao_scheme_parse_args(_ao_scheme_atom_symbol2d3estring, cons, + AO_SCHEME_ATOM, &atom, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_string_poly(ao_scheme_atom_to_string(atom)); +} + +ao_poly +ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) +{ + struct ao_scheme_string *string; + + if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3esymbol, cons, + AO_SCHEME_STRING, &string, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_atom_poly(ao_scheme_string_to_atom(string)); +} diff --git a/src/scheme/ao_scheme_string.scheme b/src/scheme/ao_scheme_string.scheme index 10e6fa4f..feeca37b 100644 --- a/src/scheme/ao_scheme_string.scheme +++ b/src/scheme/ao_scheme_string.scheme @@ -13,6 +13,10 @@ ; ; string functions placed in ROM +(define string (lambda chars (list->string chars))) + +(_??_ (string #\a #\b #\c) "abc") + (define string-map (lambda (proc . strings) ; result length is min of arg lengths diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index 083823f3..a716ca0c 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -72,66 +72,57 @@ ao_scheme_vector_alloc(uint16_t length, ao_poly fill) return vector; } +struct vl { + struct ao_scheme_vector *vector; + struct vl *prev; +}; + +static struct vl *vl; +static unsigned int vd; + void -ao_scheme_vector_write(ao_poly v, bool write) +ao_scheme_vector_write(FILE *out, ao_poly v, bool write) { struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); - unsigned int i; + unsigned int i, j; int was_marked = 0; + struct vl *ve; + + ++vd; + for (ve = vl; ve; ve = ve->prev) + if (ve->vector == vector) + abort(); + + ve = malloc(sizeof (struct vl)); + ve->prev = vl; + ve->vector = vector; + vl = ve; ao_scheme_print_start(); was_marked = ao_scheme_print_mark_addr(vector); if (was_marked) { - printf ("..."); + fputs("...", out); } else { - printf("#("); + fputs("#(\n", out); for (i = 0; i < vector->length; i++) { - if (i != 0) - printf(" "); - ao_scheme_poly_write(vector->vals[i], write); + printf("%3d: ", i); + for (j = 0; j < vd; j++) + printf("."); + ao_scheme_poly_write(out, vector->vals[i], write); + printf("\n"); } + printf(" "); + for (j = 0; j < vd; j++) + printf("."); printf(")"); } if (ao_scheme_print_stop() && !was_marked) ao_scheme_print_clear_addr(vector); -} - -static int32_t -ao_scheme_vector_offset(struct ao_scheme_vector *vector, ao_poly i) -{ - bool fail; - int32_t offset = ao_scheme_poly_integer(i, &fail); - - if (fail) - ao_scheme_error(AO_SCHEME_INVALID, "vector index %v not integer", i); - if (offset < 0 || vector->length <= offset) { - ao_scheme_error(AO_SCHEME_INVALID, "vector index %v out of range (max %d)", - i, vector->length); - offset = -1; - } - return offset; -} - -ao_poly -ao_scheme_vector_get(ao_poly v, ao_poly i) -{ - struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); - int32_t offset = ao_scheme_vector_offset(vector, i); - - if (offset < 0) - return AO_SCHEME_NIL; - return vector->vals[offset]; -} - -ao_poly -ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p) -{ - struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); - int32_t offset = ao_scheme_vector_offset(vector, i); - - if (offset < 0) - return AO_SCHEME_NIL; - return vector->vals[offset] = p; + if (vl != ve) + abort(); + vl = ve->prev; + free(ve); + --vd; } struct ao_scheme_vector * @@ -181,4 +172,118 @@ ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end) return cons; } +ao_poly +ao_scheme_do_vector(struct ao_scheme_cons *cons) +{ + return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); +} + +ao_poly +ao_scheme_do_make_vector(struct ao_scheme_cons *cons) +{ + int32_t len; + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_make2dvector, cons, + AO_SCHEME_INT, &len, + AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_false, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_vector_poly(ao_scheme_vector_alloc(len, val)); +} + +static bool +ao_scheme_check_vector(ao_poly proc, struct ao_scheme_vector *vector, int32_t offset) +{ + if (offset < 0 || vector->length <= offset) { + (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: vector index %d out of range (max %d)", + proc, + offset, vector->length); + return false; + } + return true; +} + +ao_poly +ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) +{ + struct ao_scheme_vector *vector; + int32_t offset; + + if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dref, cons, + AO_SCHEME_VECTOR, &vector, + AO_SCHEME_INT, &offset, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dref, vector, offset)) + return AO_SCHEME_NIL; + return vector->vals[offset]; +} + +ao_poly +ao_scheme_do_vector_set(struct ao_scheme_cons *cons) +{ + struct ao_scheme_vector *vector; + int32_t offset; + ao_poly val; + + if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dset21, cons, + AO_SCHEME_VECTOR, &vector, + AO_SCHEME_INT, &offset, + AO_SCHEME_POLY, &val, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dset21, vector, offset)) + return AO_SCHEME_NIL; + vector->vals[offset] = val; + return val; +} + +ao_poly +ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *pair; + + if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3evector, cons, + AO_SCHEME_CONS|AO_SCHEME_ARG_NIL_OK, &pair, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_vector_poly(ao_scheme_list_to_vector(pair)); +} + +ao_poly +ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) +{ + struct ao_scheme_vector *vector; + int32_t start, end; + + if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons, + AO_SCHEME_VECTOR, &vector, + AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(0), &start, + AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(-1), &end, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + if (end == -1) + end = vector->length; + return ao_scheme_cons_poly(ao_scheme_vector_to_list(vector, start, end)); +} + +ao_poly +ao_scheme_do_vector_length(struct ao_scheme_cons *cons) +{ + struct ao_scheme_vector *vector; + + if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons, + AO_SCHEME_VECTOR, &vector, + AO_SCHEME_ARG_END)) + return AO_SCHEME_NIL; + return ao_scheme_integer_poly(vector->length); +} + +ao_poly +ao_scheme_do_vectorp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(_ao_scheme_atom_vector3f, AO_SCHEME_VECTOR, cons); +} + #endif /* AO_SCHEME_FEATURE_VECTOR */ diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index 8858f0f6..686d809b 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -23,7 +23,7 @@ ao-scheme: $(OBJS) $(OBJS): $(HDRS) ao_scheme_const.h: ao_scheme_make_const $(SCHEME_SCHEME) - $^ -o $@ + $^ -o $@ -d GPIO clean:: rm -f $(OBJS) ao-scheme ao_scheme_const.h diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h index b225b2e8..9836d534 100644 --- a/src/scheme/test/ao_scheme_os.h +++ b/src/scheme/test/ao_scheme_os.h @@ -23,14 +23,6 @@ #include #define AO_SCHEME_POOL_TOTAL 32768 -#define AO_SCHEME_SAVE 1 - -extern int ao_scheme_getc(void); - -static inline void -ao_scheme_os_flush(void) { - fflush(stdout); -} static inline void ao_scheme_abort(void) @@ -38,12 +30,6 @@ 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 diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 45068369..ed10d3be 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -14,9 +14,8 @@ #include "ao_scheme.h" #include - -static FILE *ao_scheme_file; -static int newline = 1; +#include +#include static char save_file[] = "scheme.image"; @@ -69,43 +68,86 @@ ao_scheme_os_restore(void) return 1; } -int -ao_scheme_getc(void) +static const struct option options[] = { + { .name = "load", .has_arg = 1, .val = 'l' }, + { 0, 0, 0, 0 }, +}; + +static void usage(char *program) { - int c; + fprintf(stderr, "usage: %s [--load= ...] \n", program); +} - if (ao_scheme_file) - return getc(ao_scheme_file); +static void +check_exit(ao_poly v) +{ + if (ao_scheme_exception & AO_SCHEME_EXIT) { + int ret; + + if (v == _ao_scheme_bool_true) + ret = 0; + else { + ret = 1; + if (ao_scheme_is_integer(v)) + ret = ao_scheme_poly_integer(v); + } + exit(ret); + } +} - if (newline) { - if (ao_scheme_read_list) - printf("+ "); - else - printf("> "); - newline = 0; +static void +run_file(char *name) +{ + FILE *in; + int c; + ao_poly v; + + in = fopen(name, "r"); + if (!in) { + perror(name); + exit(1); } - c = getchar(); - if (c == '\n') - newline = 1; - return c; + c = getc(in); + if (c == '#') { + do { + c = getc(in); + } while (c != EOF && c != '\n'); + } else { + ungetc(c, in); + } + v = ao_scheme_read_eval_print(in, NULL, false); + fclose(in); + check_exit(v); } int main (int argc, char **argv) { - (void) argc; - - while (*++argv) { - ao_scheme_file = fopen(*argv, "r"); - if (!ao_scheme_file) { - perror(*argv); + int o; + + while ((o = getopt_long(argc, argv, "?l:", options, NULL)) != -1) { + switch (o) { + case '?': + usage(argv[0]); + exit(0); + case 'l': + ao_scheme_set_argv(&argv[argc]); + run_file(optarg); + break; + default: + usage(argv[0]); exit(1); } - ao_scheme_read_eval_print(); - fclose(ao_scheme_file); - ao_scheme_file = NULL; } - ao_scheme_read_eval_print(); + ao_scheme_set_argv(argv + optind); + if (argv[optind]) { + run_file(argv[optind]); + } else { + ao_poly v; + v = ao_scheme_read_eval_print(stdin, stdout, true); + check_exit(v); + putchar('\n'); + } #ifdef DBG_MEM_STATS printf ("collects: full: %lu incremental %lu\n", @@ -138,4 +180,5 @@ main (int argc, char **argv) (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); #endif + return 0; } diff --git a/src/scheme/test/hanoi.scheme b/src/scheme/test/hanoi.scheme old mode 100644 new mode 100755 index c4ae7378..0180de1e --- a/src/scheme/test/hanoi.scheme +++ b/src/scheme/test/hanoi.scheme @@ -1,3 +1,4 @@ +#!/home/keithp/bin/ao-scheme ; ; Towers of Hanoi ; @@ -172,3 +173,5 @@ (_hanoi len 0 1 2) #t ) + +(unless (null? (command-line)) (hanoi 6)) diff --git a/src/scheme/tiny-test/Makefile b/src/scheme/tiny-test/Makefile index 6b1fe003..ca71a665 100644 --- a/src/scheme/tiny-test/Makefile +++ b/src/scheme/tiny-test/Makefile @@ -3,6 +3,8 @@ include ../Makefile-inc vpath %.o . vpath %.c .. vpath %.h .. +vpath %.scheme .. +vpath ao_scheme_make_const ../make-const DEFS= @@ -18,8 +20,8 @@ ao-scheme-tiny: $(OBJS) $(OBJS): $(HDRS) -ao_scheme_const.h: ../make-const/ao_scheme_make_const ao_scheme_tiny_const.scheme - ../make-const/ao_scheme_make_const -o $@ -d FLOAT,VECTOR,QUASI,BIGINT ao_scheme_tiny_const.scheme +ao_scheme_const.h: ao_scheme_make_const ao_scheme_basic_syntax.scheme ao_scheme_finish.scheme + $^ -o $@ -d FLOAT,VECTOR,QUASI,BIGINT,PORT,POSIX,GPIO,UNDEF clean:: rm -f $(OBJS) ao-scheme-tiny ao_scheme_const.h diff --git a/src/scheme/tiny-test/ao_scheme_os.h b/src/scheme/tiny-test/ao_scheme_os.h index b9f3e31f..17d66ae3 100644 --- a/src/scheme/tiny-test/ao_scheme_os.h +++ b/src/scheme/tiny-test/ao_scheme_os.h @@ -23,14 +23,6 @@ #include #define AO_SCHEME_POOL_TOTAL 4096 -#define AO_SCHEME_SAVE 1 - -extern int ao_scheme_getc(void); - -static inline void -ao_scheme_os_flush(void) { - fflush(stdout); -} static inline void ao_scheme_abort(void) @@ -38,12 +30,6 @@ 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 diff --git a/src/scheme/tiny-test/ao_scheme_test.c b/src/scheme/tiny-test/ao_scheme_test.c index 45068369..89b8e5fa 100644 --- a/src/scheme/tiny-test/ao_scheme_test.c +++ b/src/scheme/tiny-test/ao_scheme_test.c @@ -15,9 +15,6 @@ #include "ao_scheme.h" #include -static FILE *ao_scheme_file; -static int newline = 1; - static char save_file[] = "scheme.image"; int @@ -69,43 +66,21 @@ ao_scheme_os_restore(void) return 1; } -int -ao_scheme_getc(void) -{ - int c; - - if (ao_scheme_file) - return getc(ao_scheme_file); - - if (newline) { - if (ao_scheme_read_list) - 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) { + FILE *in = fopen(*argv, "r"); + if (!in) { perror(*argv); exit(1); } - ao_scheme_read_eval_print(); - fclose(ao_scheme_file); - ao_scheme_file = NULL; + ao_scheme_read_eval_print(in, stdout, false); + fclose(in); } - ao_scheme_read_eval_print(); + ao_scheme_read_eval_print(stdin, stdout, true); #ifdef DBG_MEM_STATS printf ("collects: full: %lu incremental %lu\n", -- 2.30.2