From fccb5105b79d5b9e2ed052ce5459028015c01741 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 3 Jan 2018 14:53:48 -0800 Subject: altos/scheme: Add support for hex, octal and binary constants Signed-off-by: Keith Packard --- src/scheme/ao_scheme_read.c | 54 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 42 insertions(+), 12 deletions(-) (limited to 'src/scheme/ao_scheme_read.c') diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index e93466fc..9174de5e 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -83,12 +83,12 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* > */ PRINTABLE, /* ? */ PRINTABLE, /* @ */ - PRINTABLE, /* A */ - PRINTABLE, /* B */ - PRINTABLE, /* C */ - PRINTABLE, /* D */ - PRINTABLE|FLOATC, /* E */ - PRINTABLE, /* F */ + 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 */ @@ -115,12 +115,12 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* ^ */ PRINTABLE, /* _ */ PRINTABLE|SPECIAL_QUASI, /* ` */ - PRINTABLE, /* a */ - PRINTABLE, /* b */ - PRINTABLE, /* c */ - PRINTABLE, /* d */ - PRINTABLE|FLOATC, /* e */ - PRINTABLE, /* f */ + 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 */ @@ -284,6 +284,30 @@ static const struct namedfloat namedfloats[] = { #define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) #endif +static int +parse_int(int base) +{ + int cval; + int c; + + token_int = 0; + for (;;) { + c = lexc(); + 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 + cval = (c | ('a' - 'A')) - 'a' + 10; + token_int = token_int * base + cval; + } + return NUM; +} + static int _lex(void) { @@ -387,6 +411,12 @@ _lex(void) continue; } return NUM; + case 'x': + return parse_int(16); + case 'o': + return parse_int(8); + case 'b': + return parse_int(2); } } if (lex_class & STRINGC) { -- cgit v1.2.3 From 2bcc178f3cbfd346b134bb3fe700b0512f340fea Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 3 Jan 2018 14:56:15 -0800 Subject: altos/scheme: fix parsing of vector followed by list The 'parsing a vector' state value wasn't getting cleared at the end of the vector, so that (#(1 2) (3 4) returned (#(1 2) #(3 4) Signed-off-by: Keith Packard --- src/scheme/ao_scheme_read.c | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) (limited to 'src/scheme/ao_scheme_read.c') diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 9174de5e..7d540aa5 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -53,7 +53,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|WHITE, /* */ PRINTABLE, /* ! */ PRINTABLE|STRINGC, /* " */ - PRINTABLE|POUND, /* # */ + PRINTABLE, /* # */ PRINTABLE, /* $ */ PRINTABLE, /* % */ PRINTABLE, /* & */ @@ -360,7 +360,7 @@ _lex(void) #endif } } - if (lex_class & POUND) { + if (c == '#') { c = lexc(); switch (c) { case 't': @@ -516,7 +516,7 @@ _lex(void) static inline int lex(void) { int parse_token = _lex(); - RDBGI("token %d (%s)\n", parse_token, token_string); + RDBGI("token %d \"%s\"\n", parse_token, token_string); return parse_token; } @@ -565,10 +565,11 @@ pop_read_stack(void) ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr)) ; } else { - ao_scheme_read_cons = 0; - ao_scheme_read_cons_tail = 0; - ao_scheme_read_stack = 0; read_state = ao_scheme_read_state; + ao_scheme_read_cons = NULL; + ao_scheme_read_cons_tail = NULL; + ao_scheme_read_stack = NULL; + ao_scheme_read_state = 0; } RDBG_OUT(); RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); @@ -591,7 +592,7 @@ ao_scheme_read(void) ao_scheme_read_list = 0; read_state = 0; - ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; + ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = NULL; for (;;) { parse_token = lex(); while (is_open(parse_token)) { @@ -677,8 +678,10 @@ ao_scheme_read(void) --ao_scheme_read_list; read_state = pop_read_stack(); #ifdef AO_SCHEME_FEATURE_VECTOR - if (read_state & READ_SAW_VECTOR) + if (read_state & READ_SAW_VECTOR) { v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); + read_state &= ~READ_SAW_VECTOR; + } #endif break; case DOT: -- cgit v1.2.3 From d34f01110d8770ac99556901143a54c3d492cde0 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 4 Jan 2018 02:27:11 -0800 Subject: altos/scheme: Accept more escaped character constants Allow all those specified in r7rs Signed-off-by: Keith Packard --- src/scheme/ao_scheme_read.c | 20 +++++++++++--------- src/scheme/ao_scheme_read.h | 5 ++--- 2 files changed, 13 insertions(+), 12 deletions(-) (limited to 'src/scheme/ao_scheme_read.c') diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 7d540aa5..f7e95a63 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -110,7 +110,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* Y */ PRINTABLE, /* Z */ PRINTABLE, /* [ */ - PRINTABLE|BACKSLASH, /* \ */ + PRINTABLE, /* \ */ PRINTABLE, /* ] */ PRINTABLE, /* ^ */ PRINTABLE, /* _ */ @@ -204,18 +204,20 @@ lex_quoted(void) lex_class = 0; c &= 0x7f; switch (c) { - case 'n': - return '\n'; - case 'f': - return '\f'; + case 'a': + return '\a'; case 'b': return '\b'; + case 't': + return '\t'; + case 'n': + return '\n'; case 'r': return '\r'; + case 'f': + return '\f'; case 'v': return '\v'; - case 't': - return '\t'; case '0': case '1': case '2': @@ -422,7 +424,7 @@ _lex(void) if (lex_class & STRINGC) { for (;;) { c = lexc(); - if (lex_class & BACKSLASH) + if (c == '\\') c = lex_quoted(); if (lex_class & (STRINGC|ENDOFFILE)) { end_token(); @@ -636,7 +638,7 @@ ao_scheme_read(void) v = _ao_scheme_bool_false; break; case STRING: - string = ao_scheme_string_make(token_string); + string = ao_scheme_string_new(token_string); if (string) v = ao_scheme_string_poly(string); else diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index d0b9b36a..209a3a87 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -63,9 +63,8 @@ # define ENDOFFILE 0x0080 /* end of file */ # define COMMENT 0x0100 /* ; */ # define IGNORE 0x0200 /* \0 - ' ' */ -# define BACKSLASH 0x0400 /* \ */ -# define STRINGC 0x0800 /* " */ -# define HEX_LETTER 0x1000 /* a-f A-F */ +# define STRINGC 0x0400 /* " */ +# define HEX_LETTER 0x0800 /* a-f A-F */ # define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) # define INTEGER (DIGIT|SIGN) -- cgit v1.2.3 From 16061947d4376b41e596d87f97ec53ec29d17644 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 6 Jan 2018 17:29:10 -0800 Subject: 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 (limited to 'src/scheme/ao_scheme_read.c') 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", -- cgit v1.2.3 From b446d9657cad0ff45f6f65c774d82cb9f2f65088 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 6 Jan 2018 18:11:19 -0800 Subject: altos/lambdakey-v1.0: Switch back to command buffered input Instead of just reading from stdin with no echo or editing. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/ao_lambdakey.c | 2 +- src/lambdakey-v1.0/ao_scheme_os.h | 8 ++------ src/scheme/ao_scheme_read.c | 6 +++++- 3 files changed, 8 insertions(+), 8 deletions(-) (limited to 'src/scheme/ao_scheme_read.c') diff --git a/src/lambdakey-v1.0/ao_lambdakey.c b/src/lambdakey-v1.0/ao_lambdakey.c index 2bd626f1..f1a2aa38 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(stdin, stdout, true); + ao_scheme_read_eval_print(stdin, stdout, false); } static const struct ao_cmds blink_cmds[] = { diff --git a/src/lambdakey-v1.0/ao_scheme_os.h b/src/lambdakey-v1.0/ao_scheme_os.h index 5641b476..6a2ab819 100644 --- a/src/lambdakey-v1.0/ao_scheme_os.h +++ b/src/lambdakey-v1.0/ao_scheme_os.h @@ -30,7 +30,7 @@ #endif static inline int -ao_scheme_getc() { +_ao_scheme_getc() { static uint8_t at_eol; int c; @@ -44,11 +44,7 @@ ao_scheme_getc() { return c; } -static inline void -ao_scheme_os_flush(void) -{ - flush(); -} +#define ao_scheme_getc(f) ({ (void) (f); _ao_scheme_getc(); }) static inline void ao_scheme_abort(void) diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index a26965f2..f9630d39 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -150,6 +150,10 @@ static const uint16_t lex_classes[128] = { static int lex_unget_c; +#ifndef ao_scheme_getc +#define ao_scheme_getc(f) getc(f) +#endif + static inline int lex_get(FILE *in) { @@ -158,7 +162,7 @@ lex_get(FILE *in) c = lex_unget_c; lex_unget_c = 0; } else { - c = getc(in); + c = ao_scheme_getc(in); } return c; } -- cgit v1.2.3 From 4b52fc6eea9a478cb3dd42dcd32c92838df39734 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 8 Jan 2018 13:46:17 -0800 Subject: altos/scheme: Allow unicode in lexer This just passes any bytes with the high bit set through the system so programs can include UTF-8 in strings and symbols. What the heck. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_read.c | 5 +++-- src/scheme/ao_scheme_string.c | 6 ++++-- 2 files changed, 7 insertions(+), 4 deletions(-) (limited to 'src/scheme/ao_scheme_read.c') diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index f9630d39..3575ff3f 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -186,8 +186,9 @@ lexc(FILE *in) c = 0; lex_class = ENDOFFILE; } else { - c &= 0x7f; - lex_class = lex_classes[c]; + lex_class = PRINTABLE; + if (c <= 0x7f) + lex_class = lex_classes[c]; } } while (lex_class & IGNORE); return c; diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index c49e1e32..2c6d0960 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -47,6 +47,8 @@ ao_scheme_string_alloc(int len) { struct ao_scheme_string *s; + if (len < 0) + return NULL; s = ao_scheme_alloc(len + 2); if (!s) return NULL; @@ -182,8 +184,8 @@ ao_scheme_string_write(FILE *out, ao_poly p, bool write) fputs("\\\\", out); break; default: - if (c < ' ') - fprintf(out, "\\%03o", c); + if ((uint8_t) c < ' ') + fprintf(out, "\\%03o", (uint8_t) c); else putc(c, out); break; -- cgit v1.2.3 From f26cc1a677f577da533425a15485fcaa24626b23 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 10 Jan 2018 23:11:40 -0800 Subject: altos/scheme: Move ao-scheme to a separate repository This way it can be incorporated into multiple operating systems more easily. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 12 +- src/scheme/.gitignore | 2 - src/scheme/Makefile | 25 - src/scheme/Makefile-inc | 35 - src/scheme/Makefile-scheme | 4 - src/scheme/README | 10 - src/scheme/ao_scheme.h | 1207 ---------------------- src/scheme/ao_scheme_advanced_syntax.scheme | 388 ------- src/scheme/ao_scheme_atom.c | 298 ------ src/scheme/ao_scheme_basic_syntax.scheme | 414 -------- src/scheme/ao_scheme_bool.c | 80 -- src/scheme/ao_scheme_builtin.c | 1008 ------------------ src/scheme/ao_scheme_builtin.txt | 100 -- src/scheme/ao_scheme_char.scheme | 80 -- src/scheme/ao_scheme_cons.c | 402 ------- src/scheme/ao_scheme_const.scheme | 916 ---------------- src/scheme/ao_scheme_do.scheme | 34 - src/scheme/ao_scheme_error.c | 78 -- src/scheme/ao_scheme_eval.c | 573 ---------- src/scheme/ao_scheme_finish.scheme | 17 - src/scheme/ao_scheme_float.c | 161 --- src/scheme/ao_scheme_frame.c | 391 ------- src/scheme/ao_scheme_int.c | 132 --- src/scheme/ao_scheme_lambda.c | 208 ---- src/scheme/ao_scheme_lex.c | 16 - src/scheme/ao_scheme_make_builtin | 318 ------ src/scheme/ao_scheme_make_const.c | 543 ---------- src/scheme/ao_scheme_mem.c | 1117 -------------------- src/scheme/ao_scheme_poly.c | 74 -- src/scheme/ao_scheme_port.c | 193 ---- src/scheme/ao_scheme_port.scheme | 43 - src/scheme/ao_scheme_read.c | 727 ------------- src/scheme/ao_scheme_read.h | 76 -- src/scheme/ao_scheme_rep.c | 42 - src/scheme/ao_scheme_save.c | 89 -- src/scheme/ao_scheme_stack.c | 279 ----- src/scheme/ao_scheme_string.c | 349 ------- src/scheme/ao_scheme_string.scheme | 156 --- src/scheme/ao_scheme_vector.c | 284 ----- src/scheme/ao_scheme_vector.scheme | 192 ---- src/scheme/make-const/.gitignore | 1 - src/scheme/make-const/Makefile | 26 - src/scheme/make-const/ao_scheme_os.h | 63 -- src/scheme/test/.gitignore | 1 - src/scheme/test/Makefile | 33 - src/scheme/test/ao_scheme_os.h | 53 - src/scheme/test/ao_scheme_test.c | 188 ---- src/scheme/test/ao_scheme_test.scheme | 175 ---- src/scheme/test/hanoi.scheme | 177 ---- src/scheme/tiny-test/.gitignore | 1 - src/scheme/tiny-test/Makefile | 32 - src/scheme/tiny-test/ao_scheme_os.h | 53 - src/scheme/tiny-test/ao_scheme_tiny_const.scheme | 389 ------- src/scheme/tiny-test/ao_scheme_tiny_test.scheme | 56 - src/stmf0/Makefile-stmf0.defs | 2 +- 55 files changed, 8 insertions(+), 12315 deletions(-) delete mode 100644 src/scheme/.gitignore delete mode 100644 src/scheme/Makefile delete mode 100644 src/scheme/Makefile-inc delete mode 100644 src/scheme/Makefile-scheme delete mode 100644 src/scheme/README delete mode 100644 src/scheme/ao_scheme.h delete mode 100644 src/scheme/ao_scheme_advanced_syntax.scheme delete mode 100644 src/scheme/ao_scheme_atom.c delete mode 100644 src/scheme/ao_scheme_basic_syntax.scheme delete mode 100644 src/scheme/ao_scheme_bool.c delete mode 100644 src/scheme/ao_scheme_builtin.c delete mode 100644 src/scheme/ao_scheme_builtin.txt delete mode 100644 src/scheme/ao_scheme_char.scheme delete mode 100644 src/scheme/ao_scheme_cons.c delete mode 100644 src/scheme/ao_scheme_const.scheme delete mode 100644 src/scheme/ao_scheme_do.scheme delete mode 100644 src/scheme/ao_scheme_error.c delete mode 100644 src/scheme/ao_scheme_eval.c delete mode 100644 src/scheme/ao_scheme_finish.scheme delete mode 100644 src/scheme/ao_scheme_float.c delete mode 100644 src/scheme/ao_scheme_frame.c delete mode 100644 src/scheme/ao_scheme_int.c delete mode 100644 src/scheme/ao_scheme_lambda.c delete mode 100644 src/scheme/ao_scheme_lex.c delete mode 100644 src/scheme/ao_scheme_make_builtin delete mode 100644 src/scheme/ao_scheme_make_const.c delete mode 100644 src/scheme/ao_scheme_mem.c delete mode 100644 src/scheme/ao_scheme_poly.c delete mode 100644 src/scheme/ao_scheme_port.c delete mode 100644 src/scheme/ao_scheme_port.scheme delete mode 100644 src/scheme/ao_scheme_read.c delete mode 100644 src/scheme/ao_scheme_read.h delete mode 100644 src/scheme/ao_scheme_rep.c delete mode 100644 src/scheme/ao_scheme_save.c delete mode 100644 src/scheme/ao_scheme_stack.c delete mode 100644 src/scheme/ao_scheme_string.c delete mode 100644 src/scheme/ao_scheme_string.scheme delete mode 100644 src/scheme/ao_scheme_vector.c delete mode 100644 src/scheme/ao_scheme_vector.scheme delete mode 100644 src/scheme/make-const/.gitignore delete mode 100644 src/scheme/make-const/Makefile delete mode 100644 src/scheme/make-const/ao_scheme_os.h delete mode 100644 src/scheme/test/.gitignore delete mode 100644 src/scheme/test/Makefile delete mode 100644 src/scheme/test/ao_scheme_os.h delete mode 100644 src/scheme/test/ao_scheme_test.c delete mode 100644 src/scheme/test/ao_scheme_test.scheme delete mode 100755 src/scheme/test/hanoi.scheme delete mode 100644 src/scheme/tiny-test/.gitignore delete mode 100644 src/scheme/tiny-test/Makefile delete mode 100644 src/scheme/tiny-test/ao_scheme_os.h delete mode 100644 src/scheme/tiny-test/ao_scheme_tiny_const.scheme delete mode 100644 src/scheme/tiny-test/ao_scheme_tiny_test.scheme (limited to 'src/scheme/ao_scheme_read.c') diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 9d30c521..33c68cf5 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -5,10 +5,9 @@ include ../stmf0/Makefile.defs -include ../scheme/Makefile-inc +aoschemelib=$(shell pkg-config --variable=aoschemelib ao-scheme) -vpath %.scheme ../scheme -vpath ao_scheme_make_const ../scheme/make-const +include $(aoschemelib)/Makefile-scheme NEWLIB_FULL=-lm -lc -lgcc @@ -54,7 +53,7 @@ MAP=$(PROG).map NEWLIB=/local/newlib-mini MAPFILE=-Wl,-Map=$(MAP) LDFLAGS=-L../stmf0 -L$(NEWLIB)/arm-none-eabi/lib/thumb/v6-m/ -Wl,-Tlambda.ld $(MAPFILE) -nostartfiles -AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB +AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I$(aoschemelib) -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB PROGNAME=lambdakey-v1.0 PROG=$(PROGNAME)-$(VERSION).elf @@ -63,6 +62,9 @@ HEX=$(PROGNAME)-$(VERSION).ihx SRC=$(ALTOS_SRC) ao_lambdakey.c OBJ=$(SRC:.c=.o) +bletch: + echo lib is $(aoschemelib) + all: $(PROG) $(HEX) $(PROG): Makefile $(OBJ) lambda.ld @@ -73,7 +75,7 @@ $(OBJ): $(INC) ao_product.h: ao-make-product.5c ../Version $(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ -ao_scheme_const.h: ao_scheme_make_const ao_scheme_basic_syntax.scheme +ao_scheme_const.h: ao-scheme-make-const ao_scheme_basic_syntax.scheme $^ -o $@ -d FLOAT,VECTOR,QUASI,BIGINT,POSIX,PORT,SAVE,UNDEF load: $(PROG) diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore deleted file mode 100644 index ee72cb9d..00000000 --- a/src/scheme/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -ao_scheme_const.h -ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile deleted file mode 100644 index be312754..00000000 --- a/src/scheme/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -all: ao_scheme_builtin.h make-const/ao_scheme_make_const test/ao-scheme tiny-test/ao-scheme-tiny - -clean: - +cd make-const && make clean - +cd test && make clean - +cd tiny-test && make clean - rm -f ao_scheme_builtin.h - -ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt - nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ - -make-const/ao_scheme_make_const: FRC ao_scheme_builtin.h - +cd make-const && make ao_scheme_make_const - -test/ao-scheme: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const - +cd test && make - -tiny-test/ao-scheme-tiny: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const - +cd tiny-test && make - -install: all - +cd test && make install - +cd tiny-test && make install - -FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc deleted file mode 100644 index ed3f7f5f..00000000 --- a/src/scheme/Makefile-inc +++ /dev/null @@ -1,35 +0,0 @@ -SCHEME_SRCS=\ - ao_scheme_mem.c \ - ao_scheme_cons.c \ - ao_scheme_string.c \ - ao_scheme_atom.c \ - ao_scheme_int.c \ - ao_scheme_poly.c \ - ao_scheme_bool.c \ - ao_scheme_float.c \ - ao_scheme_builtin.c \ - ao_scheme_read.c \ - ao_scheme_frame.c \ - ao_scheme_lambda.c \ - ao_scheme_eval.c \ - ao_scheme_rep.c \ - ao_scheme_save.c \ - ao_scheme_stack.c \ - ao_scheme_error.c \ - ao_scheme_vector.c \ - ao_scheme_port.c - -SCHEME_HDRS=\ - ao_scheme.h \ - ao_scheme_os.h \ - ao_scheme_read.h \ - ao_scheme_builtin.h - -SCHEME_SCHEME=\ - ao_scheme_basic_syntax.scheme \ - ao_scheme_advanced_syntax.scheme \ - ao_scheme_vector.scheme \ - ao_scheme_string.scheme \ - ao_scheme_char.scheme \ - ao_scheme_port.scheme \ - ao_scheme_finish.scheme diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme deleted file mode 100644 index b9018e19..00000000 --- a/src/scheme/Makefile-scheme +++ /dev/null @@ -1,4 +0,0 @@ -include ../scheme/Makefile-inc - -ao_scheme_const.h: $(SCHEME_SRCS) $(SCHEME_HDRS) - +cd ../scheme && make $@ diff --git a/src/scheme/README b/src/scheme/README deleted file mode 100644 index a18457fd..00000000 --- a/src/scheme/README +++ /dev/null @@ -1,10 +0,0 @@ -This follows the R7RS with the following known exceptions: - -* No vectors or bytevectors -* Characters are just numbers -* No dynamic-wind or exceptions -* No environments -* No ports -* No syntax-rules -* No record types -* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h deleted file mode 100644 index 9ce239a6..00000000 --- a/src/scheme/ao_scheme.h +++ /dev/null @@ -1,1207 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_SCHEME_H_ -#define _AO_SCHEME_H_ - -#ifndef DBG_MEM -#define DBG_MEM 0 -#endif -#ifndef DBG_EVAL -#define DBG_EVAL 0 -#endif -#ifndef DBG_READ -#define DBG_READ 0 -#endif -#ifndef DBG_FREE_CONS -#define DBG_FREE_CONS 0 -#endif -#define NDEBUG 1 - -#include -#include -#include -#include -#define AO_SCHEME_BUILTIN_FEATURES -#include "ao_scheme_builtin.h" -#undef AO_SCHEME_BUILTIN_FEATURES -#ifndef __BYTE_ORDER -#include -#endif - -typedef uint16_t ao_poly; -typedef int16_t ao_signed_poly; - -#ifdef AO_SCHEME_MAKE_CONST -#define AO_SCHEME_POOL_CONST 32764 -extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); -#define ao_scheme_pool ao_scheme_const -#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST - -#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern((char *) n)) -#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) - -#define _ao_scheme_bool_true _bool(1) -#define _ao_scheme_bool_false _bool(0) - -#define _ao_scheme_atom_eof _atom("eof") -#define _ao_scheme_atom_else _atom("else") - -#define AO_SCHEME_BUILTIN_ATOMS -#include "ao_scheme_builtin.h" - -#else - -#include "ao_scheme_const.h" - -#ifdef AO_SCHEME_FEATURE_SAVE - -struct ao_scheme_os_save { - ao_poly atoms; - ao_poly globals; - uint16_t const_checksum; - uint16_t const_checksum_inv; -}; - -#ifndef AO_SCHEME_POOL_TOTAL -#error Must define AO_SCHEME_POOL_TOTAL for AO_SCHEME_FEATURE_SAVE -#endif - -#define AO_SCHEME_POOL_EXTRA (sizeof(struct ao_scheme_os_save)) -#define AO_SCHEME_POOL ((int) (AO_SCHEME_POOL_TOTAL - AO_SCHEME_POOL_EXTRA)) - -int -ao_scheme_os_save(void); - -int -ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); - -int -ao_scheme_os_restore(void); -#endif /* AO_SCHEME_FEATURE_SAVE */ - -#ifndef AO_SCHEME_POOL -#error Must define AO_SCHEME_POOL -#endif -#ifndef AO_SCHEME_POOL_EXTRA -#define AO_SCHEME_POOL_EXTRA 0 -#endif -extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); -#endif - -/* Primitive types */ -#define AO_SCHEME_CONS 0 -#define AO_SCHEME_INT 1 -#define AO_SCHEME_BIGINT 2 -#define AO_SCHEME_OTHER 3 - -#define AO_SCHEME_TYPE_MASK 0x0003 -#define AO_SCHEME_TYPE_SHIFT 2 -#define AO_SCHEME_REF_MASK 0x7ffc -#define AO_SCHEME_CONST 0x8000 - -/* These have a type value at the start of the struct */ -#define AO_SCHEME_ATOM 4 -#define AO_SCHEME_BUILTIN 5 -#define AO_SCHEME_FRAME 6 -#define AO_SCHEME_FRAME_VALS 7 -#define AO_SCHEME_LAMBDA 8 -#define AO_SCHEME_STACK 9 -#define AO_SCHEME_BOOL 10 -#define AO_SCHEME_STRING 11 -#ifdef AO_SCHEME_FEATURE_FLOAT -#define AO_SCHEME_FLOAT 12 -#define _AO_SCHEME_FLOAT AO_SCHEME_FLOAT -#else -#define _AO_SCHEME_FLOAT 12 -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR -#define AO_SCHEME_VECTOR 13 -#define _AO_SCHEME_VECTOR AO_SCHEME_VECTOR -#else -#define _AO_SCHEME_VECTOR _AO_SCHEME_FLOAT -#endif -#ifdef AO_SCHEME_FEATURE_PORT -#define AO_SCHEME_PORT 14 -#define _AO_SCHEME_PORT AO_SCHEME_PORT -#else -#define _AO_SCHEME_PORT _AO_SCHEME_VECTOR -#endif -#define AO_SCHEME_NUM_TYPE (_AO_SCHEME_PORT+1) - -/* Leave two bits for types to use as they please */ -#define AO_SCHEME_OTHER_TYPE_MASK 0x3f - -#define AO_SCHEME_NIL 0 - -extern uint16_t ao_scheme_top; - -#define AO_SCHEME_OOM 0x01 -#define AO_SCHEME_DIVIDE_BY_ZERO 0x02 -#define AO_SCHEME_INVALID 0x04 -#define AO_SCHEME_UNDEFINED 0x08 -#define AO_SCHEME_REDEFINED 0x10 -#define AO_SCHEME_EOF 0x20 -#define AO_SCHEME_FILEERROR 0x40 -#define AO_SCHEME_EXIT 0x80 - -extern uint8_t ao_scheme_exception; - -static inline int -ao_scheme_is_const(ao_poly poly) { - return poly & AO_SCHEME_CONST; -} - -static inline int -ao_scheme_is_const_addr(const void *addr) { - const uint8_t *a = addr; - return (ao_scheme_const <= a) && (a < ao_scheme_const + AO_SCHEME_POOL_CONST); -} - -static inline int -ao_scheme_is_pool_addr(const void *addr) { - const uint8_t *a = addr; - return (ao_scheme_pool <= a) && (a < ao_scheme_pool + AO_SCHEME_POOL); -} - -void * -ao_scheme_ref(ao_poly poly); - -ao_poly -ao_scheme_poly(const void *addr, ao_poly type); - -struct ao_scheme_type { - int (*size)(void *addr); - void (*mark)(void *addr); - void (*move)(void *addr); - char name[]; -}; - -struct ao_scheme_cons { - ao_poly car; - ao_poly cdr; -}; - -struct ao_scheme_atom { - uint8_t type; - uint8_t pad[1]; - ao_poly next; - char name[]; -}; - -struct ao_scheme_string { - uint8_t type; - char val[]; -}; - -struct ao_scheme_val { - ao_poly atom; - ao_poly val; -}; - -struct ao_scheme_frame_vals { - uint8_t type; - uint8_t size; - struct ao_scheme_val vals[]; -}; - -struct ao_scheme_frame { - uint8_t type; - uint8_t num; - ao_poly prev; - ao_poly vals; -}; - -struct ao_scheme_bool { - uint8_t type; - uint8_t value; - uint16_t pad; -}; - - -#ifdef AO_SCHEME_FEATURE_FLOAT -struct ao_scheme_float { - uint8_t type; - uint8_t pad1; - uint16_t pad2; - float value; -}; -#endif - -#ifdef AO_SCHEME_FEATURE_VECTOR -struct ao_scheme_vector { - uint8_t type; - uint8_t pad1; - uint16_t length; - ao_poly vals[]; -}; -#endif - -#ifdef AO_SCHEME_FEATURE_PORT -struct ao_scheme_port { - uint8_t type; - uint8_t stayopen; - ao_poly next; - FILE *file; -}; -#endif - -#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) -#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) - -#ifdef AO_SCHEME_FEATURE_BIGINT - -struct ao_scheme_bigint { - uint32_t value; -}; - -#define AO_SCHEME_MIN_BIGINT INT32_MIN -#define AO_SCHEME_MAX_BIGINT INT32_MAX - -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -/* Set on type when the frame escapes the lambda */ -#define AO_SCHEME_FRAME_MARK 0x80 - -static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { - return f->type & AO_SCHEME_FRAME_MARK; -} - -static inline struct ao_scheme_frame * -ao_scheme_poly_frame(ao_poly poly) { - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_frame_poly(struct ao_scheme_frame *frame) { - return ao_scheme_poly(frame, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_frame_vals * -ao_scheme_poly_frame_vals(ao_poly poly) { - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_frame_vals_poly(struct ao_scheme_frame_vals *vals) { - return ao_scheme_poly(vals, AO_SCHEME_OTHER); -} - -enum eval_state { - eval_sexpr, /* Evaluate an sexpr */ - eval_val, /* Value computed */ - eval_formal, /* Formal computed */ - eval_exec, /* Start a lambda evaluation */ - eval_apply, /* Execute apply */ - eval_cond, /* Start next cond clause */ - eval_cond_test, /* Check cond condition */ - eval_begin, /* Start next begin entry */ - eval_while, /* Start while condition */ - eval_while_test, /* Check while condition */ - eval_macro, /* Finished with macro generation */ -}; - -struct ao_scheme_stack { - uint8_t type; /* AO_SCHEME_STACK */ - uint8_t state; /* enum eval_state */ - ao_poly prev; /* previous stack frame */ - ao_poly sexprs; /* expressions to evaluate */ - ao_poly values; /* values computed */ - ao_poly values_tail; /* end of the values list for easy appending */ - ao_poly frame; /* current lookup frame */ - ao_poly list; /* most recent function call */ -}; - -#define AO_SCHEME_STACK_MARK 0x80 /* set on type when a reference has been taken */ - -static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { - return s->type & AO_SCHEME_STACK_MARK; -} - -static inline void ao_scheme_stack_mark(struct ao_scheme_stack *s) { - s->type |= AO_SCHEME_STACK_MARK; -} - -static inline struct ao_scheme_stack * -ao_scheme_poly_stack(ao_poly p) -{ - return ao_scheme_ref(p); -} - -static inline ao_poly -ao_scheme_stack_poly(struct ao_scheme_stack *stack) -{ - return ao_scheme_poly(stack, AO_SCHEME_OTHER); -} - -extern ao_poly ao_scheme_v; - -#define AO_SCHEME_FUNC_LAMBDA 0 -#define AO_SCHEME_FUNC_NLAMBDA 1 -#define AO_SCHEME_FUNC_MACRO 2 - -#define AO_SCHEME_FUNC_FREE_ARGS 0x80 -#define AO_SCHEME_FUNC_MASK 0x7f - -#define AO_SCHEME_FUNC_F_LAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_LAMBDA) -#define AO_SCHEME_FUNC_F_NLAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_NLAMBDA) -#define AO_SCHEME_FUNC_F_MACRO (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_MACRO) - -struct ao_scheme_builtin { - uint8_t type; - uint8_t args; - uint16_t func; -}; - -#define AO_SCHEME_BUILTIN_ID -#include "ao_scheme_builtin.h" - -typedef ao_poly (*ao_scheme_func_t)(struct ao_scheme_cons *cons); - -extern const ao_scheme_func_t ao_scheme_builtins[]; - -static inline ao_scheme_func_t -ao_scheme_func(struct ao_scheme_builtin *b) -{ - return ao_scheme_builtins[b->func]; -} - -struct ao_scheme_lambda { - uint8_t type; - uint8_t args; - ao_poly code; - ao_poly frame; -}; - -static inline struct ao_scheme_lambda * -ao_scheme_poly_lambda(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_lambda_poly(struct ao_scheme_lambda *lambda) -{ - return ao_scheme_poly(lambda, AO_SCHEME_OTHER); -} - -static inline void * -ao_scheme_poly_other(ao_poly poly) { - return ao_scheme_ref(poly); -} - -static inline uint8_t -ao_scheme_other_type(void *other) { -#if DBG_MEM - if ((*((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK) >= AO_SCHEME_NUM_TYPE) - ao_scheme_abort(); -#endif - return *((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK; -} - -static inline ao_poly -ao_scheme_other_poly(const void *other) -{ - return ao_scheme_poly(other, AO_SCHEME_OTHER); -} - -static inline int -ao_scheme_size_round(int size) -{ - return (size + 3) & ~3; -} - -static inline int -ao_scheme_size(const struct ao_scheme_type *type, void *addr) -{ - return ao_scheme_size_round(type->size(addr)); -} - -#define AO_SCHEME_OTHER_POLY(other) ((ao_poly)(other) + AO_SCHEME_OTHER) - -static inline int ao_scheme_poly_base_type(ao_poly poly) { - return poly & AO_SCHEME_TYPE_MASK; -} - -static inline int ao_scheme_poly_type(ao_poly poly) { - int type = poly & AO_SCHEME_TYPE_MASK; - if (type == AO_SCHEME_OTHER) - return ao_scheme_other_type(ao_scheme_poly_other(poly)); - return type; -} - -static inline int -ao_scheme_is_cons(ao_poly poly) { - return (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); -} - -static inline int -ao_scheme_is_pair(ao_poly poly) { - return poly != AO_SCHEME_NIL && (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); -} - -static inline struct ao_scheme_cons * -ao_scheme_poly_cons(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_cons_poly(struct ao_scheme_cons *cons) -{ - return ao_scheme_poly(cons, AO_SCHEME_CONS); -} - -static inline int32_t -ao_scheme_poly_int(ao_poly poly) -{ - return (int32_t) ((ao_signed_poly) poly >> AO_SCHEME_TYPE_SHIFT); -} - -static inline ao_poly -ao_scheme_int_poly(int32_t i) -{ - return ((ao_poly) i << 2) | AO_SCHEME_INT; -} - -#ifdef AO_SCHEME_FEATURE_BIGINT -static inline struct ao_scheme_bigint * -ao_scheme_poly_bigint(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) -{ - return ao_scheme_poly(bi, AO_SCHEME_BIGINT); -} -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -static inline struct ao_scheme_string * -ao_scheme_poly_string(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_string_poly(struct ao_scheme_string *s) -{ - return ao_scheme_poly(s, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_atom * -ao_scheme_poly_atom(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_atom_poly(struct ao_scheme_atom *a) -{ - return ao_scheme_poly(a, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_builtin * -ao_scheme_poly_builtin(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_builtin_poly(struct ao_scheme_builtin *b) -{ - return ao_scheme_poly(b, AO_SCHEME_OTHER); -} - -static inline ao_poly -ao_scheme_bool_poly(struct ao_scheme_bool *b) -{ - return ao_scheme_poly(b, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_bool * -ao_scheme_poly_bool(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -#ifdef AO_SCHEME_FEATURE_FLOAT -static inline ao_poly -ao_scheme_float_poly(struct ao_scheme_float *f) -{ - return ao_scheme_poly(f, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_float * -ao_scheme_poly_float(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -float -ao_scheme_poly_number(ao_poly p); -#endif - -#ifdef AO_SCHEME_FEATURE_VECTOR -static inline ao_poly -ao_scheme_vector_poly(struct ao_scheme_vector *v) -{ - return ao_scheme_poly(v, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_vector * -ao_scheme_poly_vector(ao_poly poly) -{ - return ao_scheme_ref(poly); -} -#endif - -#ifdef AO_SCHEME_FEATURE_PORT -static inline ao_poly -ao_scheme_port_poly(struct ao_scheme_port *v) -{ - return ao_scheme_poly(v, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_port * -ao_scheme_poly_port(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -extern ao_poly ao_scheme_stdin, ao_scheme_stdout, ao_scheme_stderr; - -#endif - -/* memory functions */ - -extern uint64_t ao_scheme_collects[2]; -extern uint64_t ao_scheme_freed[2]; -extern uint64_t ao_scheme_loops[2]; - -/* returns 1 if the object was already marked */ -int -ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); - -/* returns 1 if the object is marked */ -int -ao_scheme_marked(void *addr); - -/* returns 1 if the object was already moved */ -int -ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); - -void * -ao_scheme_alloc(int size); - -/* Marks an object as being printed, returns 1 if it was already marked */ -int -ao_scheme_print_mark_addr(void *addr); - -void -ao_scheme_print_clear_addr(void *addr); - -/* Notes that printing has started */ -void -ao_scheme_print_start(void); - -/* Notes that printing has ended, returns 1 if printing is still happening */ -int -ao_scheme_print_stop(void); - -#define AO_SCHEME_COLLECT_FULL 1 -#define AO_SCHEME_COLLECT_INCREMENTAL 0 - -int -ao_scheme_collect(uint8_t style); - -#if DBG_FREE_CONS -void -ao_scheme_cons_check(struct ao_scheme_cons *cons); -#endif - -void -ao_scheme_poly_stash(ao_poly poly); - -ao_poly -ao_scheme_poly_fetch(void); - -static inline void -ao_scheme_cons_stash(struct ao_scheme_cons *cons) { - ao_scheme_poly_stash(ao_scheme_cons_poly(cons)); -} - -static inline struct ao_scheme_cons * -ao_scheme_cons_fetch(void) { - return ao_scheme_poly_cons(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_atom_stash(struct ao_scheme_atom *atom) { - ao_scheme_poly_stash(ao_scheme_atom_poly(atom)); -} - -static inline struct ao_scheme_atom * -ao_scheme_atom_fetch(void) { - return ao_scheme_poly_atom(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_string_stash(struct ao_scheme_string *string) { - ao_scheme_poly_stash(ao_scheme_string_poly(string)); -} - -static inline struct ao_scheme_string * -ao_scheme_string_fetch(void) { - return ao_scheme_poly_string(ao_scheme_poly_fetch()); -} - -#ifdef AO_SCHEME_FEATURE_VECTOR -static inline void -ao_scheme_vector_stash(struct ao_scheme_vector *vector) { - ao_scheme_poly_stash(ao_scheme_vector_poly(vector)); -} - -static inline struct ao_scheme_vector * -ao_scheme_vector_fetch(void) { - return ao_scheme_poly_vector(ao_scheme_poly_fetch()); -} -#endif - -#ifdef AO_SCHEME_FEATURE_PORT -static inline void -ao_scheme_port_stash(struct ao_scheme_port *port) { - ao_scheme_poly_stash(ao_scheme_port_poly(port)); -} - -static inline struct ao_scheme_port * -ao_scheme_port_fetch(void) { - return ao_scheme_poly_port(ao_scheme_poly_fetch()); -} -#endif - -static inline void -ao_scheme_stack_stash(struct ao_scheme_stack *stack) { - ao_scheme_poly_stash(ao_scheme_stack_poly(stack)); -} - -static inline struct ao_scheme_stack * -ao_scheme_stack_fetch(void) { - return ao_scheme_poly_stack(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_frame_stash(struct ao_scheme_frame *frame) { - ao_scheme_poly_stash(ao_scheme_frame_poly(frame)); -} - -static inline struct ao_scheme_frame * -ao_scheme_frame_fetch(void) { - return ao_scheme_poly_frame(ao_scheme_poly_fetch()); -} - -/* bool */ - -extern const struct ao_scheme_type ao_scheme_bool_type; - -void -ao_scheme_bool_write(FILE *out, ao_poly v, bool write); - -#ifdef AO_SCHEME_MAKE_CONST -extern struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; - -struct ao_scheme_bool * -ao_scheme_bool_get(uint8_t value); -#endif - -/* cons */ -extern const struct ao_scheme_type ao_scheme_cons_type; - -struct ao_scheme_cons * -ao_scheme_cons_cons(ao_poly car, ao_poly cdr); - -/* Return a cons or NULL for a proper list, else error */ -struct ao_scheme_cons * -ao_scheme_cons_cdr(struct ao_scheme_cons *cons); - -ao_poly -ao_scheme_cons(ao_poly car, ao_poly cdr); - -extern struct ao_scheme_cons *ao_scheme_cons_free_list; - -void -ao_scheme_cons_free(struct ao_scheme_cons *cons); - -void -ao_scheme_cons_write(FILE *out, ao_poly, bool write); - -int -ao_scheme_cons_length(struct ao_scheme_cons *cons); - -/* string */ -extern const struct ao_scheme_type ao_scheme_string_type; - -struct ao_scheme_string * -ao_scheme_string_new(char *a); - -struct ao_scheme_string * -ao_scheme_atom_to_string(struct ao_scheme_atom *a); - -struct ao_scheme_string * -ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b); - -void -ao_scheme_string_write(FILE *out, ao_poly s, bool write); - -/* atom */ -extern const struct ao_scheme_type ao_scheme_atom_type; - -extern struct ao_scheme_atom *ao_scheme_atoms; -extern struct ao_scheme_frame *ao_scheme_frame_global; -extern struct ao_scheme_frame *ao_scheme_frame_current; - -void -ao_scheme_atom_write(FILE *out, ao_poly a, bool write); - -struct ao_scheme_atom * -ao_scheme_string_to_atom(struct ao_scheme_string *string); - -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name); - -void -ao_scheme_atom_check_references(void); - -void -ao_scheme_atom_move(void); - -ao_poly * -ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); - -ao_poly -ao_scheme_atom_get(ao_poly atom); - -ao_poly -ao_scheme_atom_def(ao_poly atom, ao_poly val); - -/* int */ -void -ao_scheme_int_write(FILE *out, ao_poly i, bool write); - -#ifdef AO_SCHEME_FEATURE_BIGINT -int32_t -ao_scheme_poly_integer(ao_poly p); - -ao_poly -ao_scheme_integer_poly(int32_t i); - -static inline int -ao_scheme_integer_typep(uint8_t t) -{ - return (t == AO_SCHEME_INT) || (t == AO_SCHEME_BIGINT); -} - -void -ao_scheme_bigint_write(FILE *out, ao_poly i, bool write); - -extern const struct ao_scheme_type ao_scheme_bigint_type; - -#else - -static inline int32_t ao_scheme_poly_integer(ao_poly poly) { - return ao_scheme_poly_int(poly); -} - -static inline ao_poly ao_scheme_integer_poly(int32_t i) { - return ao_scheme_int_poly(i); -} - -static inline int -ao_scheme_integer_typep(uint8_t t) -{ - return (t == AO_SCHEME_INT); -} - -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -/* vector */ - -#ifdef AO_SCHEME_FEATURE_VECTOR - -void -ao_scheme_vector_write(FILE *OUT, ao_poly v, bool write); - -struct ao_scheme_vector * -ao_scheme_vector_alloc(uint16_t length, ao_poly fill); - -struct ao_scheme_vector * -ao_scheme_list_to_vector(struct ao_scheme_cons *cons); - -struct ao_scheme_cons * -ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end); - -extern const struct ao_scheme_type ao_scheme_vector_type; - -#endif /* AO_SCHEME_FEATURE_VECTOR */ - -/* port */ - -#ifdef AO_SCHEME_FEATURE_PORT - -void -ao_scheme_port_write(FILE *out, ao_poly v, bool write); - -struct ao_scheme_port * -ao_scheme_port_alloc(FILE *file, bool stayopen); - -void -ao_scheme_port_close(struct ao_scheme_port *port); - -void -ao_scheme_port_check_references(void); - -extern ao_poly ao_scheme_open_ports; - -static inline int -ao_scheme_port_getc(struct ao_scheme_port *port) -{ - if (port->file) - return getc(port->file); - return EOF; -} - -static inline int -ao_scheme_port_putc(struct ao_scheme_port *port, char c) -{ - if (port->file) - return putc(c, port->file); - return EOF; -} - -static inline int -ao_scheme_port_ungetc(struct ao_scheme_port *port, char c) -{ - if (port->file) - return ungetc(c, port->file); - return EOF; -} - -extern const struct ao_scheme_type ao_scheme_port_type; - -#endif /* AO_SCHEME_FEATURE_PORT */ - -#ifdef AO_SCHEME_FEATURE_POSIX - -void -ao_scheme_set_argv(char **argv); - -#endif - -/* prim */ -void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write); - -static inline void -ao_scheme_poly_write(FILE *out, ao_poly p, bool write) { (*ao_scheme_poly_write_func(p))(out, p, write); } - -int -ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); - -/* returns 1 if the object has already been moved */ -int -ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); - -/* eval */ - -#ifdef AO_SCHEME_FEATURE_SAVE -void -ao_scheme_eval_clear_globals(void); - -int -ao_scheme_eval_restart(void); -#endif - -ao_poly -ao_scheme_eval(ao_poly p); - -ao_poly -ao_scheme_set_cond(struct ao_scheme_cons *cons); - -/* float */ -#ifdef AO_SCHEME_FEATURE_FLOAT -extern const struct ao_scheme_type ao_scheme_float_type; - -void -ao_scheme_float_write(FILE *out, ao_poly p, bool write); - -ao_poly -ao_scheme_float_get(float value); -#endif - -#ifdef AO_SCHEME_FEATURE_FLOAT -static inline bool -ao_scheme_number_typep(uint8_t t) -{ - return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); -} -#else -#define ao_scheme_number_typep ao_scheme_integer_typep -#endif - -static inline bool -ao_scheme_is_integer(ao_poly poly) { - return ao_scheme_integer_typep(ao_scheme_poly_base_type(poly)); -} - -static inline bool -ao_scheme_is_number(ao_poly poly) { - return ao_scheme_number_typep(ao_scheme_poly_type(poly)); -} - -/* builtin */ -void -ao_scheme_builtin_write(FILE *out, ao_poly b, bool write); - -ao_poly -ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons); - -extern const struct ao_scheme_type ao_scheme_builtin_type; - -#define AO_SCHEME_ARG_OPTIONAL 0x100 -#define AO_SCHEME_ARG_NIL_OK 0x200 -#define AO_SCHEME_ARG_RET_POLY 0x400 -#define AO_SCHEME_ARG_END -1 -#define AO_SCHEME_POLY 0xff -#define AO_SCHEME_ARG_MASK 0xff - -int -ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...); - -/* Check argument count */ -ao_poly -ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); - -/* Check argument type */ -ao_poly -ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok); - -/* Fetch an arg (nil if off the end) */ -ao_poly -ao_scheme_arg(struct ao_scheme_cons *cons, int argc); - -char * -ao_scheme_args_name(uint8_t args); - -/* read */ -extern int ao_scheme_read_list; -extern struct ao_scheme_cons *ao_scheme_read_cons; -extern struct ao_scheme_cons *ao_scheme_read_cons_tail; -extern struct ao_scheme_cons *ao_scheme_read_stack; - -ao_poly -ao_scheme_read(FILE *in); - -/* rep */ -ao_poly -ao_scheme_read_eval_print(FILE *read_file, FILE *write_file, bool interactive); - -/* frame */ -extern const struct ao_scheme_type ao_scheme_frame_type; -extern const struct ao_scheme_type ao_scheme_frame_vals_type; - -#define AO_SCHEME_FRAME_FREE 6 - -extern struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; - -ao_poly -ao_scheme_frame_mark(struct ao_scheme_frame *frame); - -ao_poly * -ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom); - -struct ao_scheme_frame * -ao_scheme_frame_new(int num); - -void -ao_scheme_frame_free(struct ao_scheme_frame *frame); - -void -ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val); - -ao_poly -ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); - -#ifdef AO_SCHEME_FEATURE_UNDEF -ao_poly -ao_scheme_frame_del(struct ao_scheme_frame *frame, ao_poly atom); -#endif - -void -ao_scheme_frame_write(FILE *out, ao_poly p, bool write); - -void -ao_scheme_frame_init(void); - -/* lambda */ -extern const struct ao_scheme_type ao_scheme_lambda_type; - -extern const char * const ao_scheme_state_names[]; - -struct ao_scheme_lambda * -ao_scheme_lambda_new(ao_poly cons); - -void -ao_scheme_lambda_write(FILE *out, ao_poly lambda, bool write); - -ao_poly -ao_scheme_lambda_eval(void); - -/* stack */ - -extern const struct ao_scheme_type ao_scheme_stack_type; -extern struct ao_scheme_stack *ao_scheme_stack; -extern struct ao_scheme_stack *ao_scheme_stack_free_list; - -extern int ao_scheme_frame_print_indent; - -void -ao_scheme_stack_reset(struct ao_scheme_stack *stack); - -int -ao_scheme_stack_push(void); - -void -ao_scheme_stack_pop(void); - -void -ao_scheme_stack_write(FILE *out, ao_poly stack, bool write); - -ao_poly -ao_scheme_stack_eval(void); - -/* error */ - -void -ao_scheme_vfprintf(FILE *out, const char *format, va_list args); - -void -ao_scheme_fprintf(FILE *out, const char *format, ...); - -ao_poly -ao_scheme_error(int error, const char *format, ...); - -/* builtins */ - -#define AO_SCHEME_BUILTIN_DECLS -#include "ao_scheme_builtin.h" - -/* debugging macros */ - -#if DBG_EVAL || DBG_READ -int ao_scheme_stack_depth; -#endif - -#if DBG_EVAL -#define DBG_DO(a) a -#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf(" "); } while(0) -#define DBG_IN() (++ao_scheme_stack_depth) -#define DBG_OUT() (--ao_scheme_stack_depth) -#define DBG_RESET() (ao_scheme_stack_depth = 0) -#define DBG(...) ao_scheme_fprintf(stdout, __VA_ARGS__) -#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_scheme_cons_write(stdout, ao_scheme_cons_poly(a), true) -#define DBG_POLY(a) ao_scheme_poly_write(stdout, a, true) -#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) -#define DBG_STACK() ao_scheme_stack_write(stdout, ao_scheme_stack_poly(ao_scheme_stack), true) -static inline void -ao_scheme_frames_dump(void) -{ - struct ao_scheme_stack *s; - DBGI(".. current frame: "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - for (s = ao_scheme_stack; s; s = ao_scheme_poly_stack(s->prev)) { - DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); - } -} -#define DBG_FRAMES() ao_scheme_frames_dump() -#else -#define DBG_DO(a) -#define DBG_INDENT() -#define DBG_IN() -#define DBG_OUT() -#define DBG(...) -#define DBGI(...) -#define DBG_CONS(a) -#define DBG_POLY(a) -#define DBG_RESET() -#define DBG_STACK() -#define DBG_FRAMES() -#endif - -#if DBG_READ -#define RDBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); ao_scheme_printf(__VA_ARGS__); } while (0) -#define RDBG_IN() (++ao_scheme_stack_depth) -#define RDBG_OUT() (--ao_scheme_stack_depth) -#else -#define RDBGI(...) -#define RDBG_IN() -#define RDBG_OUT() -#endif - -static inline int -ao_scheme_mdbg_offset(void *a) -{ - uint8_t *u = a; - - if (u == 0) - return -1; - - if (ao_scheme_pool <= u && u < ao_scheme_pool + AO_SCHEME_POOL) - return u - ao_scheme_pool; - -#ifndef AO_SCHEME_MAKE_CONST - if (ao_scheme_const <= u && u < ao_scheme_const + AO_SCHEME_POOL_CONST) - return - (int) (u - ao_scheme_const); -#endif - return -2; -} - -#define MDBG_OFFSET(a) ao_scheme_mdbg_offset(a) - -#if DBG_MEM - -#define DBG_MEM_START 1 - -#include -extern int dbg_move_depth; -#define MDBG_DUMP 1 - -extern int dbg_mem; - -#define MDBG_DO(a) a -#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) -#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) -#define MDBG_MOVE_IN() (dbg_move_depth++) -#define MDBG_MOVE_OUT() (--dbg_move_depth) - -#else - -#define MDBG_DO(a) -#define MDBG_MOVE(...) -#define MDBG_MORE(...) -#define MDBG_MOVE_IN() -#define MDBG_MOVE_OUT() - -#endif - -#endif /* _AO_SCHEME_H_ */ diff --git a/src/scheme/ao_scheme_advanced_syntax.scheme b/src/scheme/ao_scheme_advanced_syntax.scheme deleted file mode 100644 index 4cddc803..00000000 --- a/src/scheme/ao_scheme_advanced_syntax.scheme +++ /dev/null @@ -1,388 +0,0 @@ -; -; Copyright © 2018 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Advanced syntax, including vectors and floats - -(begin - (def! equal? - (lambda (a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b))) - ((lambda (i l) - (while (and (< i l) - (equal? (vector-ref a i) - (vector-ref b i))) - (set! i (+ i 1))) - (eq? i l) - ) - 0 - (vector-length a) - ) - ) - (else #f) - ) - ) - ) - 'equal? - ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) -(equal? #(1 2 3) #(1 2 3)) -(equal? #(1 2 3) #(4 5 6)) - -(define quasiquote - (macro (x) - (define (constant? exp) - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - - (define (combine-skeletons left right exp) - (cond - ((and (constant? left) (constant? right)) - (cond ((and (eqv? (eval left) (car exp)) - (eqv? (eval right) (cdr exp))) - (list 'quote exp) - ) - (else - (list 'quote (cons (eval left) (eval right))) - ) - ) - ) - ((null? right) - (list 'list left) - ) - ((and (pair? right) (eq? (car right) 'list)) - (cons 'list (cons left (cdr right))) - ) - (else - (list 'cons left right) - ) - ) - ) - - (define (expand-quasiquote exp nesting) - (cond - - ; non cons -- constants - ; themselves, others are - ; quoted - - ((not (pair? exp)) - (cond ((constant? exp) - exp - ) - (else - (list 'quote exp) - ) - ) - ) - - ; check for an unquote exp and - ; add the param unquoted - - ((and (eq? (car exp) 'unquote) (= (length exp) 2)) - (cond ((= nesting 0) - (car (cdr exp)) - ) - (else - (combine-skeletons ''unquote - (expand-quasiquote (cdr exp) (- nesting 1)) - exp)) - ) - ) - - ; nested quasi-quote -- - ; construct the right - ; expression - - ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) - (combine-skeletons ''quasiquote - (expand-quasiquote (cdr exp) (+ nesting 1)) - exp)) - - ; check for an - ; unquote-splicing member, - ; compute the expansion of the - ; value and append the rest of - ; the quasiquote result to it - - ((and (pair? (car exp)) - (eq? (car (car exp)) 'unquote-splicing) - (= (length (car exp)) 2)) - (cond ((= nesting 0) - (list 'append (car (cdr (car exp))) - (expand-quasiquote (cdr exp) nesting)) - ) - (else - (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) - (expand-quasiquote (cdr exp) nesting) - exp)) - ) - ) - - ; for other lists, just glue - ; the expansion of the first - ; element to the expansion of - ; the rest of the list - - (else (combine-skeletons (expand-quasiquote (car exp) nesting) - (expand-quasiquote (cdr exp) nesting) - exp) - ) - ) - ) - (expand-quasiquote x 0) - ) - ) - - ; `q -> (quote q) - ; `(q) -> (append (quote (q))) - ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) - ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) - - ; define a set of local - ; variables all at once and - ; then evaluate a list of - ; sexprs - ; - ; (let (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let ((x 1) (y)) (set! y (+ x 1)) y) - -(define let - (macro (vars . exprs) - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-vals vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ; prepend the set operations - ; to the expressions - - ; build the lambda. - - `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) - ) - ) - - -(let ((x 1) (y)) (set! y 2) (+ x y)) - -(define assv assq) - -(assv 'b '((a 1) (b 2) (c 3))) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(when #t (+ 1 2)) -(when #f (+ 1 2)) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(unless #f (+ 2 3)) -(unless #t (+ 2 3)) - -(define (cdar l) (cdr (car l))) - -(cdar '((1 2) (3 4))) - -(define (cddr l) (cdr (cdr l))) - -(cddr '(1 2 3)) - -(define (caddr l) (car (cdr (cdr l)))) - -(caddr '(1 2 3 4)) - -(define (reverse list) - (define (_r old new) - (if (null? old) - new - (_r (cdr old) (cons (car old) new)) - ) - ) - (_r list ()) - ) - -(reverse '(1 2 3)) - -(define make-list - (lambda (a . b) - (define (_m a x) - (if (zero? a) - x - (_m (- a 1) (cons b x)) - ) - ) - (if (null? b) - (set! b #f) - (set! b (car b)) - ) - (_m a '()) - ) - ) - -(make-list 10 'a) - -(make-list 10) - -(define for-each - (lambda (proc . lists) - (define (_f lists) - (cond ((null? (car lists)) #t) - (else - (apply proc (map car lists)) - (_f (map cdr lists)) - ) - ) - ) - (_f lists) - ) - ) - -(let ((a 0)) - (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) - a - ) - -(call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - -(define case - (macro (test . l) - ; construct the body of the - ; case, dealing with the - ; lambda version ( => lambda) - - (define (_unarrow l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)) - ) - - ; Build the case elements, which is - ; simply a list of cond clauses - - (define (_case l) - - (cond ((null? l) ()) - - ; else case - - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) - - ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - ) - ) - - ; now construct the overall - ; expression, using a lambda - ; to hold the computed value - ; of the test expression - - `((lambda (__key__) - (cond ,@(_case l))) ,test) - ) - ) - -(case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) -(case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) -(case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) -(case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) - -(define do - (macro (vars test . cmds) - (define (_step v) - (if (null? v) - '() - (if (null? (cddr (car v))) - (_step (cdr v)) - (cons `(set! ,(caar v) ,(caddr (car v))) - (_step (cdr v)) - ) - ) - ) - ) - `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) - (while (not ,(car test)) - ,@cmds - ,@(_step vars) - ) - ,@(cdr test) - ) - ) - ) - -(do ((x 1 (+ x 1)) - (y 0) - ) - ((= x 10) y) - (set! y (+ y x)) - ) diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c deleted file mode 100644 index 2a568ed9..00000000 --- a/src/scheme/ao_scheme_atom.c +++ /dev/null @@ -1,298 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_scheme.h" - -static int name_size(char *name) -{ - return sizeof(struct ao_scheme_atom) + strlen(name) + 1; -} - -static int atom_size(void *addr) -{ - struct ao_scheme_atom *atom = addr; - if (!atom) - return 0; - return name_size(atom->name); -} - -static void atom_mark(void *addr) -{ - MDBG_MOVE("mark atom %s\n", ((struct ao_scheme_atom *) addr)->name); - (void) addr; -} - -static void atom_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_atom_type = { - .mark = atom_mark, - .size = atom_size, - .move = atom_move, - .name = "atom" -}; - -struct ao_scheme_atom *ao_scheme_atoms; - -static struct ao_scheme_atom * -ao_scheme_atom_find(const char *name) -{ - struct ao_scheme_atom *atom; - -#ifdef ao_builtin_atoms - if (!ao_scheme_atoms) - ao_scheme_atoms = ao_scheme_poly_atom(ao_builtin_atoms); -#endif - for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } - return NULL; -} - -#ifdef AO_SCHEME_MAKE_CONST - -#define AO_SCHEME_BUILTIN_SYNTAX_ATOMS -#include "ao_scheme_builtin.h" -#undef AO_SCHEME_BUILTIN_SYNTAX_ATOMS - -static void -ao_scheme_atom_mark_syntax(void) -{ - unsigned a; - for (a = 0; a < sizeof(syntax_atoms)/sizeof(syntax_atoms[0]); a++) { - struct ao_scheme_atom *atom = ao_scheme_atom_find(syntax_atoms[a]); - if (atom) - ao_scheme_mark_memory(&ao_scheme_atom_type, atom); - } -} - -#else -#define ao_scheme_atom_mark_syntax() -#endif - -void -ao_scheme_atom_move(void) -{ - struct ao_scheme_atom *atom; - ao_scheme_move_memory(&ao_scheme_atom_type, (void **) (void *) &ao_scheme_atoms); - for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { - if (!ao_scheme_is_pool_addr(atom)) { - MDBG_DO(printf("atom out of pool %s\n", atom->name)); - break; - } - MDBG_DO(printf("move atom %s\n", atom->name)); - ao_scheme_poly_move(&atom->next, 0); - } -} - -void -ao_scheme_atom_check_references(void) -{ - struct ao_scheme_atom *atom; - ao_poly *prev = NULL; - - ao_scheme_atom_mark_syntax(); - for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { - if (!ao_scheme_marked(atom)) { - MDBG_DO(printf("unreferenced atom %s\n", atom->name)); - if (prev) - *prev = atom->next; - else - ao_scheme_atoms = ao_scheme_poly_atom(atom->next); - } else - prev = &atom->next; - } -} - -static void -ao_scheme_atom_init(struct ao_scheme_atom *atom, char *name) -{ - if (atom) { - atom->type = AO_SCHEME_ATOM; - strcpy(atom->name, name); - atom->next = ao_scheme_atom_poly(ao_scheme_atoms); - ao_scheme_atoms = atom; - } -} - -struct ao_scheme_atom * -ao_scheme_string_to_atom(struct ao_scheme_string *string) -{ - struct ao_scheme_atom *atom = ao_scheme_atom_find(string->val); - - if (atom) - return atom; - ao_scheme_string_stash(string); - atom = ao_scheme_alloc(name_size(string->val)); - string = ao_scheme_string_fetch(); - ao_scheme_atom_init(atom, string->val); - return atom; -} - -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name) -{ - struct ao_scheme_atom *atom = ao_scheme_atom_find(name); - if (atom) - return atom; - - atom = ao_scheme_alloc(name_size(name)); - ao_scheme_atom_init(atom, name); - return atom; -} - -ao_poly * -ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref) -{ - ao_poly *ref; - struct ao_scheme_frame *frame; - - for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) { - ref = ao_scheme_frame_ref(frame, atom); - if (ref) { - if (frame_ref) - *frame_ref = frame; - return ref; - } - } - ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom); - if (ref) - if (frame_ref) - *frame_ref = ao_scheme_frame_global; - return ref; -} - -ao_poly -ao_scheme_atom_get(ao_poly atom) -{ - ao_poly *ref = ao_scheme_atom_ref(atom, NULL); - -#ifdef ao_builtin_frame - if (!ref) - ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom); -#endif - if (ref) - return *ref; - return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); -} - -ao_poly -ao_scheme_atom_def(ao_poly atom, ao_poly val) -{ - struct ao_scheme_frame *frame; - ao_poly *ref = ao_scheme_atom_ref(atom, &frame); - - if (ref) { - if (frame == ao_scheme_frame_current) - return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name); - *ref = val; - return val; - } - return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val); -} - -void -ao_scheme_atom_write(FILE *out, ao_poly a, bool write) -{ - struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); - (void) write; - fprintf(out, "%s", atom->name); -} - -ao_poly -ao_scheme_do_symbolp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_symbol3f, AO_SCHEME_ATOM, cons); -} - -ao_poly -ao_scheme_do_set(struct ao_scheme_cons *cons) -{ - ao_poly atom; - ao_poly val; - ao_poly *ref; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, - AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - ref = ao_scheme_atom_ref(atom, NULL); - - if (!ref) - return ao_scheme_error(AO_SCHEME_UNDEFINED, "%v: undefined atom %v", - _ao_scheme_atom_set, atom); - *ref = val; - return val; -} - -ao_poly -ao_scheme_do_def(struct ao_scheme_cons *cons) -{ - ao_poly atom; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, - AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_atom_def(atom, val); -} - -ao_poly -ao_scheme_do_setq(struct ao_scheme_cons *cons) -{ - ao_poly atom; - ao_poly val; - ao_poly p; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set21, cons, - AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_atom_ref(atom, NULL)) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: symbol %v not defined", - _ao_scheme_atom_set21, atom); - /* - * Build the macro return -- `(set (quote ,atom) ,val) - */ - ao_scheme_poly_stash(cons->cdr); - p = ao_scheme_cons(atom, AO_SCHEME_NIL); - p = ao_scheme_cons(_ao_scheme_atom_quote, p); - p = ao_scheme_cons(p, ao_scheme_poly_fetch()); - return ao_scheme_cons(_ao_scheme_atom_set, p); -} - -#ifdef AO_SCHEME_FEATURE_UNDEF -ao_poly -ao_scheme_do_undef(struct ao_scheme_cons *cons) -{ - ao_poly atom; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, - AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_frame_del(ao_scheme_frame_global, atom); -} -#endif diff --git a/src/scheme/ao_scheme_basic_syntax.scheme b/src/scheme/ao_scheme_basic_syntax.scheme deleted file mode 100644 index 4cd3e167..00000000 --- a/src/scheme/ao_scheme_basic_syntax.scheme +++ /dev/null @@ -1,414 +0,0 @@ -; -; Copyright © 2018 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Basic syntax placed in ROM - -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (a b) - (list - def - (list quote a) - b) - ) - ) - -(begin - (def! append - (lambda a - (def! _a - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (_a (cdr a) b))) - ) - ) - ) - - (def! _b - (lambda (l) - (cond ((null? l) l) - ((null? (cdr l)) (car l)) - (else (_a (car l) (_b (cdr l)))) - ) - ) - ) - (_b a) - ) - ) - 'append) - -(append '(a) '(b)) - - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name x y z) sexprs ...) - ; - -(begin - (def! define - (macro (a . b) - ; check for alternate lambda definition form - - (cond ((pair? a) - (set! b - (cons - lambda - (cons (cdr a) b))) - (set! a (car a)) - ) - (else - (set! b (car b)) - ) - ) - (cons begin - (cons - (cons def - (cons (cons quote (cons a '())) - (cons b '()) - ) - ) - (cons - (cons quote (cons a '())) - '()) - ) - ) - ) - ) - 'define - ) - ; boolean operators - -(define or - (macro a - (def! b - (lambda (a) - (cond ((null? a) #f) - ((null? (cdr a)) - (car a)) - (else - (list - cond - (list - (car a)) - (list - 'else - (b (cdr a)) - ) - ) - ) - ) - ) - ) - (b a))) - - ; execute to resolve macros - -(or #f #t) - -(define and - (macro a - (def! b - (lambda (a) - (cond ((null? a) #t) - ((null? (cdr a)) - (car a)) - (else - (list - cond - (list - (car a) - (b (cdr a)) - ) - ) - ) - ) - ) - ) - (b a) - ) - ) - - ; execute to resolve macros - -(and #t #f) - - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - -(define letrec - (macro (a . b) - - ; - ; make the list of names in the let - ; - - (define (_a a) - (cond ((not (null? a)) - (cons (car (car a)) - (_a (cdr a)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (_b a b) - (cond ((null? a) b) - (else - (cons - (list set - (list quote - (car (car a)) - ) - (cond ((null? (cdr (car a))) - () - ) - (else - (car (cdr (car a))) - ) - ) - ) - (_b (cdr a) b) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (_c a) - (cond ((null? a) ()) - (else (cons () (_c (cdr a)))) - ) - ) - ; build the lambda. - - (cons (cons lambda (cons (_a a) (_b a b))) (_c a)) - ) - ) - -(letrec ((a 1) (b a)) (+ a b)) - - ; letrec is sufficient for let* - -(define let* letrec) - - ; use letrec for let in basic - ; syntax - -(define let letrec) - - ; Basic recursive - ; equality. Replaced with - ; vector-capable version in - ; advanced syntax - -(define (equal? a b) - (cond ((eq? a b) #t) - ((pair? a) - (cond ((pair? b) - (cond ((equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - ) - ) - ) - ) - ) - -(equal? '(a b c) '(a b c)) - - ; basic list accessors - -(define (caar a) (car (car a))) - -(define (cadr a) (car (cdr a))) - -(define (list-ref a b) - (car (list-tail a b)) - ) - -(list-ref '(1 2 3) 2) - -(define (member a b . t?) - (cond ((null? b) - #f - ) - (else - (if (null? t?) (set! t? equal?) (set! t? (car t?))) - (if (t? a (car b)) - b - (member a (cdr b) t?)) - ) - ) - ) - -(member '(2) '((1) (2) (3))) -(member '(4) '((1) (2) (3))) - -(define (memq a b) (member a b eq?)) - -(memq 2 '(1 2 3)) -(memq 4 '(1 2 3)) -(memq '(2) '((1) (2) (3))) - -(define (assoc a b . t?) - (if (null? t?) - (set! t? equal?) - (set! t? (car t?)) - ) - (if (null? b) - #f - (if (t? a (caar b)) - (car b) - (assoc a (cdr b) t?) - ) - ) - ) - -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define (assq a b) (assoc a b eq?)) - -(assq 'a '((a 1) (b 2) (c 3))) - -(define map - (lambda (proc . lists) - (define (_a lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (_a (cdr lists))) - ) - ) - ) - (define (_n lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (_n (cdr lists))) - ) - ) - ) - (define (_m lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (_a lists)) (_m (_n lists))) - ) - ) - ) - (_m lists) - ) - ) - -(map cadr '((a b) (d e) (g h))) - - ; use map as for-each in basic - ; mode - -(define for-each map) - ; simple math operators - -(define zero? (macro (value) (list eq? value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) (list > value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) (list < value 0))) - -(negative? 12) -(negative? -12) - -(define (abs a) (if (>= a 0) a (- a))) - -(abs 12) -(abs -12) - -(define max (lambda (a . b) - (while (not (null? b)) - (cond ((< a (car b)) - (set! a (car b))) - ) - (set! b (cdr b)) - ) - a) - ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (a . b) - (while (not (null? b)) - (cond ((> a (car b)) - (set! a (car b))) - ) - (set! b (cdr b)) - ) - a) - ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? a) (zero? (% a 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? a) (not (even? a))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - -(define (newline) (write-char #\newline)) - -(newline) diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c deleted file mode 100644 index 05109fb9..00000000 --- a/src/scheme/ao_scheme_bool.c +++ /dev/null @@ -1,80 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -static void bool_mark(void *addr) -{ - (void) addr; -} - -static int bool_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_bool); -} - -static void bool_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_bool_type = { - .mark = bool_mark, - .size = bool_size, - .move = bool_move, - .name = "bool" -}; - -void -ao_scheme_bool_write(FILE *out, ao_poly v, bool write) -{ - struct ao_scheme_bool *b = ao_scheme_poly_bool(v); - - (void) write; - if (b->value) - fprintf(out, "#t"); - else - fprintf(out, "#f"); -} - -ao_poly -ao_scheme_do_booleanp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_boolean3f, AO_SCHEME_BOOL, cons); -} - -#ifdef AO_SCHEME_MAKE_CONST - -struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; - -struct ao_scheme_bool * -ao_scheme_bool_get(uint8_t value) -{ - struct ao_scheme_bool **b; - - if (value) - b = &ao_scheme_true; - else - b = &ao_scheme_false; - - if (!*b) { - *b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); - (*b)->type = AO_SCHEME_BOOL; - (*b)->value = value; - } - return *b; -} - -#endif diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c deleted file mode 100644 index 2b0c394b..00000000 --- a/src/scheme/ao_scheme_builtin.c +++ /dev/null @@ -1,1008 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#define _GNU_SOURCE -#include "ao_scheme.h" -#include -#include -#include - -static int -builtin_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_builtin); -} - -static void -builtin_mark(void *addr) -{ - (void) addr; -} - -static void -builtin_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_builtin_type = { - .size = builtin_size, - .mark = builtin_mark, - .move = builtin_move -}; - -#ifdef AO_SCHEME_MAKE_CONST - -#define AO_SCHEME_BUILTIN_CASENAME -#include "ao_scheme_builtin.h" - -char *ao_scheme_args_name(uint8_t args) { - args &= AO_SCHEME_FUNC_MASK; - switch (args) { - case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; - case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; - case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; - default: return (char *) "???"; - } -} -#else - -#define AO_SCHEME_BUILTIN_ARRAYNAME -#include "ao_scheme_builtin.h" - -static char * -ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { - if (b < _builtin_last) - return ao_scheme_poly_atom(builtin_names[b])->name; - return (char *) "???"; -} - -static const ao_poly ao_scheme_args_atoms[] = { - [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, - [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, - [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, -}; - -char * -ao_scheme_args_name(uint8_t args) -{ - args &= AO_SCHEME_FUNC_MASK; - if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) - return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; - return (char *) "(unknown)"; -} -#endif - -void -ao_scheme_builtin_write(FILE *out, ao_poly b, bool write) -{ - struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); - (void) write; - fputs(ao_scheme_builtin_name(builtin->func), out); -} - -static bool -ao_scheme_typecheck(ao_poly actual, int formal_type) { - int actual_type; - - if ((formal_type & AO_SCHEME_ARG_MASK) == AO_SCHEME_POLY) - return true; - - /* allow nil? */ - if (actual == AO_SCHEME_NIL) - return (formal_type & AO_SCHEME_ARG_NIL_OK) != 0; - - actual_type = ao_scheme_poly_type(actual); - formal_type &= AO_SCHEME_ARG_MASK; - - if (actual_type == formal_type) - return true; - if (actual_type == AO_SCHEME_BUILTIN && formal_type == AO_SCHEME_LAMBDA) - return true; - -#ifdef AO_SCHEME_FEATURE_BIGINT - if (ao_scheme_integer_typep(actual_type) && formal_type == AO_SCHEME_INT) - return true; -#endif -#ifdef AO_SCHEME_FEATURE_FLOAT - if (ao_scheme_number_typep(actual_type) && formal_type == AO_SCHEME_FLOAT) - return true; -#endif - return false; -} - -int -ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...) -{ - va_list ap; - int formal; - int argc = 0; - ao_poly car; - - va_start(ap, cons); - while ((formal = va_arg(ap, int)) != AO_SCHEME_ARG_END) { - if (formal & AO_SCHEME_ARG_OPTIONAL) - car = (ao_poly) va_arg(ap, int); - if (cons) { - car = cons->car; - cons = ao_scheme_cons_cdr(cons); - if (!ao_scheme_typecheck(car, formal)) { - ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); - return 0; - } - } else if (!(formal & AO_SCHEME_ARG_OPTIONAL)) { - goto bad_args; - } - if (formal & AO_SCHEME_ARG_RET_POLY) - formal = AO_SCHEME_POLY; - - switch (formal & AO_SCHEME_ARG_MASK) { - case AO_SCHEME_INT: -#ifdef AO_SCHEME_FEATURE_BIGINT - case AO_SCHEME_BIGINT: -#endif - *(va_arg(ap, int32_t *)) = ao_scheme_poly_integer(car); - break; -#ifdef AO_SCHEME_FEATURE_FLOAT - case AO_SCHEME_FLOAT: - *(va_arg(ap, float *)) = ao_scheme_poly_number(car); - break; -#endif - case AO_SCHEME_POLY: - *(va_arg(ap, ao_poly *)) = car; - break; - default: - *(va_arg(ap, void **)) = ao_scheme_ref(car); - break; - } - argc++; - } - if (cons) { - bad_args: - ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid arg count", name); - return 0; - } - return 1; -} - -ao_poly -ao_scheme_arg(struct ao_scheme_cons *cons, int argc) -{ - for (;;) { - if (!cons) - return AO_SCHEME_NIL; - if (argc == 0) - return cons->car; - cons = ao_scheme_cons_cdr(cons); - argc--; - } -} - -ao_poly -ao_scheme_do_quote(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_quote, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return val; -} - -ao_poly -ao_scheme_do_cond(struct ao_scheme_cons *cons) -{ - ao_scheme_set_cond(cons); - return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_begin(struct ao_scheme_cons *cons) -{ - ao_scheme_stack->state = eval_begin; - ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); - return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_while(struct ao_scheme_cons *cons) -{ - ao_scheme_stack->state = eval_while; - ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); - return AO_SCHEME_NIL; -} - -static ao_poly -ao_scheme_do_display_or_write(ao_poly proc, struct ao_scheme_cons *cons, bool write) -{ -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly val; - ao_poly port; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_POLY | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_poly_write(stdout, val, write); -#else - ao_poly val; - struct ao_scheme_port *port; - FILE *file = stdout; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_PORT | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) { - file = port->file; - if (!file) - return _ao_scheme_bool_true; - } - ao_scheme_poly_write(file, val, write); -#endif - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_write(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_display_or_write(_ao_scheme_atom_write, cons, true); -} - -ao_poly -ao_scheme_do_display(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_display_or_write(_ao_scheme_atom_display, cons, false); -} - -static ao_poly -ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) -{ - struct ao_scheme_cons *cons; - ao_poly ret = AO_SCHEME_NIL; - - for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { - ao_poly car = cons->car; - uint8_t rt = ao_scheme_poly_type(ret); - uint8_t ct = ao_scheme_poly_type(car); - - if (cons == orig_cons) { - ret = car; - ao_scheme_cons_stash(cons); - if (cons->cdr == AO_SCHEME_NIL) { - switch (op) { - case builtin_minus: - if (ao_scheme_integer_typep(ct)) - ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); -#ifdef AO_SCHEME_FEATURE_FLOAT - else if (ct == AO_SCHEME_FLOAT) - ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); -#endif - break; - case builtin_divide: - if (ao_scheme_poly_integer(ret) == 1) { - } else { -#ifdef AO_SCHEME_FEATURE_FLOAT - if (ao_scheme_number_typep(ct)) { - float v = ao_scheme_poly_number(ret); - ret = ao_scheme_float_get(1/v); - } -#else - ret = ao_scheme_integer_poly(0); -#endif - } - break; - default: - break; - } - } - cons = ao_scheme_cons_fetch(); - } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { - int32_t r = ao_scheme_poly_integer(ret); - int32_t c = ao_scheme_poly_integer(car); -#ifdef AO_SCHEME_FEATURE_FLOAT - int64_t t; -#endif - - switch(op) { - case builtin_plus: - r += c; - check_overflow: -#ifdef AO_SCHEME_FEATURE_FLOAT - if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) - goto inexact; -#endif - break; - case builtin_minus: - r -= c; - goto check_overflow; - break; - case builtin_times: -#ifdef AO_SCHEME_FEATURE_FLOAT - t = (int64_t) r * (int64_t) c; - if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) - goto inexact; - r = (int32_t) t; -#else - r = r * c; -#endif - break; - case builtin_divide: -#ifdef AO_SCHEME_FEATURE_FLOAT - if (c != 0 && (r % c) == 0) - r /= c; - else - goto inexact; -#else - r /= c; -#endif - break; - case builtin_quotient: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); - r = r / c; - break; - case builtin_floor_quotient: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "floor-quotient by zero"); - if (r % c != 0 && (c < 0) != (r < 0)) - r = r / c - 1; - else - r = r / c; - break; - case builtin_remainder: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); - r %= c; - break; - case builtin_modulo: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); - r %= c; - if ((r < 0) != (c < 0)) - r += c; - break; - default: - break; - } - ao_scheme_cons_stash(cons); - ret = ao_scheme_integer_poly(r); - cons = ao_scheme_cons_fetch(); -#ifdef AO_SCHEME_FEATURE_FLOAT - } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { - float r, c; - inexact: - r = ao_scheme_poly_number(ret); - c = ao_scheme_poly_number(car); - switch(op) { - case builtin_plus: - r += c; - break; - case builtin_minus: - r -= c; - break; - case builtin_times: - r *= c; - break; - case builtin_divide: - r /= c; - break; - case builtin_quotient: - case builtin_floor_quotient: - case builtin_remainder: - case builtin_modulo: - return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); - default: - break; - } - ao_scheme_cons_stash(cons); - ret = ao_scheme_float_get(r); - cons = ao_scheme_cons_fetch(); -#endif - } - else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { - ao_scheme_cons_stash(cons); - ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), - ao_scheme_poly_string(car))); - cons = ao_scheme_cons_fetch(); - if (!ret) - return ret; - } - else - return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); - } - return ret; -} - -ao_poly -ao_scheme_do_plus(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_plus); -} - -ao_poly -ao_scheme_do_minus(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_minus); -} - -ao_poly -ao_scheme_do_times(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_times); -} - -ao_poly -ao_scheme_do_divide(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_divide); -} - -ao_poly -ao_scheme_do_quotient(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_quotient); -} - -ao_poly -ao_scheme_do_floor_quotient(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_floor_quotient); -} - -ao_poly -ao_scheme_do_modulo(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_modulo); -} - -ao_poly -ao_scheme_do_remainder(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_remainder); -} - -static ao_poly -ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) -{ - ao_poly left; - - if (!cons) - return _ao_scheme_bool_true; - - left = cons->car; - for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { - ao_poly right = cons->car; - - if (op == builtin_equal && left == right) { - ; - } else { - uint8_t lt = ao_scheme_poly_type(left); - uint8_t rt = ao_scheme_poly_type(right); - if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { - int32_t l = ao_scheme_poly_integer(left); - int32_t r = ao_scheme_poly_integer(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_scheme_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_scheme_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_scheme_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_scheme_bool_false; - break; - case builtin_equal: - if (!(l == r)) - return _ao_scheme_bool_false; - default: - break; - } -#ifdef AO_SCHEME_FEATURE_FLOAT - } else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) { - float l, r; - - l = ao_scheme_poly_number(left); - r = ao_scheme_poly_number(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_scheme_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_scheme_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_scheme_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_scheme_bool_false; - break; - case builtin_equal: - if (!(l == r)) - return _ao_scheme_bool_false; - default: - break; - } -#endif /* AO_SCHEME_FEATURE_FLOAT */ - } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { - int c = strcmp(ao_scheme_poly_string(left)->val, - ao_scheme_poly_string(right)->val); - switch (op) { - case builtin_less: - if (!(c < 0)) - return _ao_scheme_bool_false; - break; - case builtin_greater: - if (!(c > 0)) - return _ao_scheme_bool_false; - break; - case builtin_less_equal: - if (!(c <= 0)) - return _ao_scheme_bool_false; - break; - case builtin_greater_equal: - if (!(c >= 0)) - return _ao_scheme_bool_false; - break; - case builtin_equal: - if (!(c == 0)) - return _ao_scheme_bool_false; - break; - default: - break; - } - } else - return _ao_scheme_bool_false; - } - left = right; - } - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_equal(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_equal); -} - -ao_poly -ao_scheme_do_less(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_less); -} - -ao_poly -ao_scheme_do_greater(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_greater); -} - -ao_poly -ao_scheme_do_less_equal(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_less_equal); -} - -ao_poly -ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_scheme_do_flush_output(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - fflush(stdout); -#else - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - fflush(stdout); - if (port) { - if (port->file) - fflush(port->file); - } else - fflush(stdout); -#endif - return _ao_scheme_bool_true; -} - -#ifdef AO_SCHEME_FEATURE_GPIO - -ao_poly -ao_scheme_do_led(struct ao_scheme_cons *cons) -{ - int32_t led; - if (!ao_scheme_parse_args(_ao_scheme_atom_led, cons, - AO_SCHEME_INT, &led, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_os_led(led); - return _ao_scheme_bool_true; -} - -#endif - -ao_poly -ao_scheme_do_eval(struct ao_scheme_cons *cons) -{ - ao_poly expr; - ao_poly env; - - if (!ao_scheme_parse_args(_ao_scheme_atom_eval, cons, - AO_SCHEME_POLY, &expr, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &env, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_stack->state = eval_sexpr; - ao_scheme_stack->frame = AO_SCHEME_NIL; - ao_scheme_frame_current = NULL; - return expr; -} - -ao_poly -ao_scheme_do_apply(struct ao_scheme_cons *cons) -{ - ao_scheme_stack->state = eval_apply; - return ao_scheme_cons_poly(cons); -} - -ao_poly -ao_scheme_do_read(struct ao_scheme_cons *cons) -{ - FILE *file = stdin; -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; -#else - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) { - file = port->file; - if (!file) - return _ao_scheme_atom_eof; - } -#endif - return ao_scheme_read(file); -} - -ao_poly -ao_scheme_do_collect(struct ao_scheme_cons *cons) -{ - int free; - (void) cons; - free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - return ao_scheme_integer_poly(free); -} - -ao_poly -ao_scheme_do_nullp(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (val == AO_SCHEME_NIL) - return _ao_scheme_bool_true; - else - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_not(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (val == _ao_scheme_bool_false) - return _ao_scheme_bool_true; - else - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (ao_scheme_poly_type(val) == type) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_procedurep(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_BUILTIN: - case AO_SCHEME_LAMBDA: - return _ao_scheme_bool_true; - default: - return _ao_scheme_bool_false; - } -} - -ao_poly -ao_scheme_do_read_char(struct ao_scheme_cons *cons) -{ - int c; -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - c = getchar(); -#else - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) - c = ao_scheme_port_getc(port); - else - c = getchar(); -#endif - if (c == EOF) - return _ao_scheme_atom_eof; - return ao_scheme_integer_poly(c); -} - -ao_poly -ao_scheme_do_write_char(struct ao_scheme_cons *cons) -{ - int32_t c; -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, - AO_SCHEME_INT, &c, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - putchar(c); -#else - struct ao_scheme_port *port; - if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, - AO_SCHEME_INT, &c, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) - ao_scheme_port_putc(port, c); - else - putchar(c); -#endif - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_exit(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_exit, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_true, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_exception |= AO_SCHEME_EXIT; - return val; -} - -#ifdef AO_SCHEME_FEATURE_TIME - -ao_poly -ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_current2djiffy, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(ao_scheme_os_jiffy()); -} - -ao_poly -ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_jiffies2dper2dsecond, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(AO_SCHEME_JIFFIES_PER_SECOND); -} - -ao_poly -ao_scheme_do_delay(struct ao_scheme_cons *cons) -{ - int32_t delay; - - if (!ao_scheme_parse_args(_ao_scheme_atom_delay, cons, - AO_SCHEME_INT, &delay, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_os_delay(delay); - return cons->car; -} -#endif - -#ifdef AO_SCHEME_FEATURE_POSIX - -#include - -static char **ao_scheme_argv; - -void -ao_scheme_set_argv(char **argv) -{ - ao_scheme_argv = argv; -} - -ao_poly -ao_scheme_do_command_line(struct ao_scheme_cons *cons) -{ - ao_poly args = AO_SCHEME_NIL; - ao_poly arg; - int i; - - if (!ao_scheme_parse_args(_ao_scheme_atom_command2dline, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - for (i = 0; ao_scheme_argv[i]; i++); - - while (--i >= 0) { - ao_scheme_poly_stash(args); - arg = ao_scheme_string_poly(ao_scheme_string_new(ao_scheme_argv[i])); - args = ao_scheme_poly_fetch(); - if (!arg) - return AO_SCHEME_NIL; - args = ao_scheme_cons(arg, args); - if (!args) - return AO_SCHEME_NIL; - } - return args; -} - -ao_poly -ao_scheme_do_get_environment_variables(struct ao_scheme_cons *cons) -{ - ao_poly envs = AO_SCHEME_NIL; - ao_poly env; - int i; - - if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariables, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - for (i = 0; environ[i]; i++); - - while (--i >= 0) { - ao_scheme_poly_stash(envs); - env = ao_scheme_string_poly(ao_scheme_string_new(environ[i])); - envs = ao_scheme_poly_fetch(); - if (!env) - return AO_SCHEME_NIL; - envs = ao_scheme_cons(env, envs); - if (!envs) - return AO_SCHEME_NIL; - } - return envs; -} - -ao_poly -ao_scheme_do_get_environment_variable(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *name; - char *val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariable, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - val = secure_getenv(name->val); - if (!val) - return _ao_scheme_bool_false; - return ao_scheme_string_poly(ao_scheme_string_new(val)); -} - -ao_poly -ao_scheme_do_file_existsp(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *name; - - if (!ao_scheme_parse_args(_ao_scheme_atom_file2dexists3f, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (access(name->val, F_OK) == 0) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_delete_file(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *name; - - if (!ao_scheme_parse_args(_ao_scheme_atom_delete2dfile, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (unlink(name->val) == 0) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_current_second(struct ao_scheme_cons *cons) -{ - int32_t second; - - if (!ao_scheme_parse_args(_ao_scheme_atom_current2dsecond, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - second = (int32_t) time(NULL); - return ao_scheme_integer_poly(second); -} - -#endif /* AO_SCHEME_FEATURE_POSIX */ - -#define AO_SCHEME_BUILTIN_FUNCS -#include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt deleted file mode 100644 index fd29d607..00000000 --- a/src/scheme/ao_scheme_builtin.txt +++ /dev/null @@ -1,100 +0,0 @@ -BIGINT feature bigint -all atom eof -all atom else -all f_lambda eval -all f_lambda read -all nlambda lambda -all nlambda nlambda -all nlambda macro -all f_lambda car -all f_lambda cdr -all f_lambda cons -all f_lambda last -all f_lambda length -all f_lambda list_copy list-copy -all f_lambda list_tail list-tail -all nlambda quote -QUASI atom quasiquote -QUASI atom unquote -QUASI atom unquote_splicing unquote-splicing -all f_lambda set -all macro setq set! -all f_lambda def -all nlambda cond -all nlambda begin -all nlambda while -all f_lambda write -all f_lambda display -all f_lambda plus + string-append -all f_lambda minus - -all f_lambda times * -all f_lambda divide / -all f_lambda modulo modulo % -all f_lambda remainder -all f_lambda quotient -all f_lambda floor_quotient floor-quotient -all f_lambda equal = eq? eqv? -all f_lambda less < string string>? -all f_lambda less_equal <= string<=? -all f_lambda greater_equal >= string>=? -all f_lambda flush_output flush-output -TIME f_lambda delay -GPIO f_lambda led -SAVE f_lambda save -SAVE f_lambda restore -all f_lambda call_cc call-with-current-continuation call/cc -all f_lambda collect -all f_lambda nullp null? -all f_lambda not -all f_lambda listp list? -all f_lambda pairp pair? -all f_lambda integerp integer? exact?@BIGINT exact-integer?@BIGINT -all f_lambda numberp number? real?@FLOAT -all f_lambda booleanp boolean? -all f_lambda set_car set-car! -all f_lambda set_cdr set-cdr! -all f_lambda symbolp symbol? -all f_lambda list_to_string list->string -all f_lambda string_to_list string->list -all f_lambda symbol_to_string symbol->string -all f_lambda string_to_symbol string->symbol -all f_lambda stringp string? -all f_lambda string_ref string-ref -all f_lambda string_set string-set! -all f_lambda string_length string-length -all f_lambda make_string make-string -all f_lambda procedurep procedure? -all lambda apply -all f_lambda read_char read-char -all f_lambda write_char write-char -all f_lambda exit -TIME f_lambda current_jiffy current-jiffy -TIME f_lambda jiffies_per_second jiffies-per-second -FLOAT f_lambda finitep finite? -FLOAT f_lambda infinitep infinite? -FLOAT f_lambda inexactp inexact? -FLOAT f_lambda sqrt -VECTOR f_lambda vector_ref vector-ref -VECTOR f_lambda vector_set vector-set! -VECTOR f_lambda vector -VECTOR f_lambda make_vector make-vector -VECTOR f_lambda list_to_vector list->vector -VECTOR f_lambda vector_to_list vector->list -VECTOR f_lambda vector_length vector-length -VECTOR f_lambda vectorp vector? -PORT f_lambda portp port? -PORT f_lambda port_openp port-open? -PORT f_lambda open_input_file open-input-file -PORT f_lambda open_output_file open-output-file -PORT f_lambda close_port close-port -PORT f_lambda current_input_port current-input-port -PORT f_lambda current_output_port current-output-port -PORT f_lambda current_error_port current-error-port -POSIX f_lambda command_line command-line -POSIX f_lambda get_environment_variables get-environment-variables -POSIX f_lambda get_environment_variable get-environment-variable -POSIX f_lambda file_existsp file-exists? -POSIX f_lambda delete_file delete-file -POSIX f_lambda current_second current-second -UNDEF f_lambda undef diff --git a/src/scheme/ao_scheme_char.scheme b/src/scheme/ao_scheme_char.scheme deleted file mode 100644 index fdb7fa64..00000000 --- a/src/scheme/ao_scheme_char.scheme +++ /dev/null @@ -1,80 +0,0 @@ -; -; Copyright © 2018 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Char primitives placed in ROM - -(define char? integer?) - -(char? #\q) -(char? "h") - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(char-lower-case? #\a) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(char-alphabetic? #\a) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(char-numeric? #\a) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(char-whitespace? #\a) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) - -(define char->integer (macro (v) v)) -(define integer->char char->integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(char-upcase #\a) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(char-downcase #\a) -(char-downcase #\B) -(char-downcase #\0) -(char-downcase #\space) - -(define (digit-value c) - (if (char-numeric? c) - (- c #\0) - #f) - ) - -(digit-value #\1) -(digit-value #\a) diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c deleted file mode 100644 index a6e697b2..00000000 --- a/src/scheme/ao_scheme_cons.c +++ /dev/null @@ -1,402 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -static void cons_mark(void *addr) -{ - struct ao_scheme_cons *cons = addr; - - for (;;) { - ao_poly cdr = cons->cdr; - - ao_scheme_poly_mark(cons->car, 1); - if (!cdr) - break; - if (!ao_scheme_is_cons(cdr)) { - ao_scheme_poly_mark(cdr, 0); - break; - } - cons = ao_scheme_poly_cons(cdr); - if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) - break; - } -} - -static int cons_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_cons); -} - -static void cons_move(void *addr) -{ - struct ao_scheme_cons *cons = addr; - - if (!cons) - return; - - for (;;) { - ao_poly cdr; - struct ao_scheme_cons *c; - int ret; - - MDBG_MOVE("cons_move start %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); - (void) ao_scheme_poly_move(&cons->car, 1); - cdr = cons->cdr; - if (!cdr) - break; - if (!ao_scheme_is_cons(cdr)) { - (void) ao_scheme_poly_move(&cons->cdr, 0); - break; - } - c = ao_scheme_poly_cons(cdr); - ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); - if (c != ao_scheme_poly_cons(cons->cdr)) - cons->cdr = ao_scheme_cons_poly(c); - MDBG_MOVE("cons_move end %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); - if (ret) - break; - cons = c; - } -} - -const struct ao_scheme_type ao_scheme_cons_type = { - .mark = cons_mark, - .size = cons_size, - .move = cons_move, - .name = "cons", -}; - -struct ao_scheme_cons *ao_scheme_cons_free_list; - -struct ao_scheme_cons * -ao_scheme_cons_cons(ao_poly car, ao_poly cdr) -{ - struct ao_scheme_cons *cons; - - if (ao_scheme_cons_free_list) { - cons = ao_scheme_cons_free_list; - ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); - } else { - ao_scheme_poly_stash(car); - ao_scheme_poly_stash(cdr); - cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - cdr = ao_scheme_poly_fetch(); - car = ao_scheme_poly_fetch(); - if (!cons) - return NULL; - } - cons->car = car; - cons->cdr = cdr; - return cons; -} - -struct ao_scheme_cons * -ao_scheme_cons_cdr(struct ao_scheme_cons *cons) -{ - ao_poly cdr = cons->cdr; - if (cdr == AO_SCHEME_NIL) - return NULL; - if (!ao_scheme_is_cons(cdr)) { - (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); - return NULL; - } - return ao_scheme_poly_cons(cdr); -} - -ao_poly -ao_scheme_cons(ao_poly car, ao_poly cdr) -{ - return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); -} - -static struct ao_scheme_cons * -ao_scheme_cons_copy(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *head = NULL; - struct ao_scheme_cons *tail = NULL; - - while (cons) { - struct ao_scheme_cons *new; - ao_poly cdr; - - ao_scheme_cons_stash(cons); - ao_scheme_cons_stash(head); - ao_scheme_cons_stash(tail); - new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - tail = ao_scheme_cons_fetch(); - head = ao_scheme_cons_fetch(); - cons = ao_scheme_cons_fetch(); - if (!new) - return AO_SCHEME_NIL; - new->car = cons->car; - new->cdr = AO_SCHEME_NIL; - if (!head) - head = new; - else - tail->cdr = ao_scheme_cons_poly(new); - tail = new; - cdr = cons->cdr; - if (!ao_scheme_is_cons(cdr)) { - tail->cdr = cdr; - break; - } - cons = ao_scheme_poly_cons(cdr); - } - return head; -} - -void -ao_scheme_cons_free(struct ao_scheme_cons *cons) -{ -#if DBG_FREE_CONS - ao_scheme_cons_check(cons); -#endif - while (cons) { - ao_poly cdr = cons->cdr; - cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); - ao_scheme_cons_free_list = cons; - cons = ao_scheme_poly_cons(cdr); - } -} - -void -ao_scheme_cons_write(FILE *out, ao_poly c, bool write) -{ - struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); - struct ao_scheme_cons *clear = cons; - ao_poly cdr; - int written = 0; - - ao_scheme_print_start(); - fprintf(out, "("); - while (cons) { - if (written != 0) - fprintf(out, " "); - - /* Note if there's recursion in printing. Not - * as good as actual references, but at least - * we don't infinite loop... - */ - if (ao_scheme_print_mark_addr(cons)) { - fprintf(out, "..."); - break; - } - - ao_scheme_poly_write(out, cons->car, write); - - /* keep track of how many pairs have been printed */ - written++; - - cdr = cons->cdr; - if (!ao_scheme_is_cons(cdr)) { - fprintf(out, " . "); - ao_scheme_poly_write(out, cdr, write); - break; - } - cons = ao_scheme_poly_cons(cdr); - } - fprintf(out, ")"); - - if (ao_scheme_print_stop()) { - - /* If we're still printing, clear the print marks on - * all printed pairs - */ - while (written--) { - ao_scheme_print_clear_addr(clear); - clear = ao_scheme_poly_cons(clear->cdr); - } - } -} - -int -ao_scheme_cons_length(struct ao_scheme_cons *cons) -{ - int len = 0; - while (cons) { - len++; - cons = ao_scheme_cons_cdr(cons); - } - return len; -} - -ao_poly -ao_scheme_do_car(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_car, cons, - AO_SCHEME_CONS, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return pair->car; -} - -ao_poly -ao_scheme_do_cdr(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_cdr, cons, - AO_SCHEME_CONS, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return pair->cdr; -} - -ao_poly -ao_scheme_do_cons(struct ao_scheme_cons *cons) -{ - ao_poly car, cdr; - - if (!ao_scheme_parse_args(_ao_scheme_atom_cons, cons, - AO_SCHEME_POLY, &car, - AO_SCHEME_POLY, &cdr, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_cons(car, cdr); -} - -ao_poly -ao_scheme_do_last(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_last, cons, - AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - while (pair) { - if (!pair->cdr) - return pair->car; - pair = ao_scheme_cons_cdr(pair); - } - return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_length(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - if (!ao_scheme_parse_args(_ao_scheme_atom_length, cons, - AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(ao_scheme_cons_length(pair)); -} - -ao_poly -ao_scheme_do_list_copy(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_list2dcopy, cons, - AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_cons_poly(ao_scheme_cons_copy(pair)); -} - -ao_poly -ao_scheme_do_list_tail(struct ao_scheme_cons *cons) -{ - ao_poly list; - int32_t v; - - if (!ao_scheme_parse_args(_ao_scheme_atom_list2dtail, cons, - AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK | AO_SCHEME_ARG_RET_POLY, &list, - AO_SCHEME_INT, &v, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - while (v > 0) { - if (!list) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: ran off end", _ao_scheme_atom_list2dtail); - if (!ao_scheme_is_cons(list)) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid list", _ao_scheme_atom_list2dtail); - list = ao_scheme_poly_cons(list)->cdr; - v--; - } - return list; -} - -ao_poly -ao_scheme_do_pairp(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (ao_scheme_is_pair(val)) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -/* This one is special -- a list is either nil or - * a 'proper' list with only cons cells - */ -ao_poly -ao_scheme_do_listp(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - for (;;) { - if (val == AO_SCHEME_NIL) - return _ao_scheme_bool_true; - if (!ao_scheme_is_cons(val)) - return _ao_scheme_bool_false; - val = ao_scheme_poly_cons(val)->cdr; - } -} - -ao_poly -ao_scheme_do_set_car(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons, - AO_SCHEME_CONS, &pair, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - pair->car = val; - return val; -} - -ao_poly -ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons, - AO_SCHEME_CONS, &pair, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - pair->cdr = val; - return val; -} - diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme deleted file mode 100644 index 17dc51a9..00000000 --- a/src/scheme/ao_scheme_const.scheme +++ /dev/null @@ -1,916 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - -(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1))))) - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (name value) - (list - def - (list quote name) - value) - ) - ) - -(begin - (def! append - (lambda args - (def! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - - (def! append-lists - (lambda (lists) - (cond ((null? lists) lists) - ((null? (cdr lists)) (car lists)) - (else (append-list (car lists) (append-lists (cdr lists)))) - ) - ) - ) - (append-lists args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; boolean operators - -(begin - (def! or - (macro l - (def! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) - ) - ) - (_or l))) - 'or) - - ; execute to resolve macros - -(_?_ (or #f #t) #t) - -(begin - (def! and - (macro l - (def! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) - ) - ) - (_and l) - ) - ) - 'and) - - ; execute to resolve macros - -(_?_ (and #t #f) #f) - - ; recursive equality - -(begin - (def! equal? - (lambda (a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b))) - ((lambda (i l) - (while (and (< i l) - (equal? (vector-ref a i) - (vector-ref b i))) - (set! i (+ i 1))) - (eq? i l) - ) - 0 - (vector-length a) - ) - ) - (else #f) - ) - ) - ) - 'equal? - ) - -(_?_ (equal? '(a b c) '(a b c)) #t) -(_?_ (equal? '(a b c) '(a b b)) #f) -(_?_ (equal? #(1 2 3) #(1 2 3)) #t) -(_?_ (equal? #(1 2 3) #(4 5 6)) #f) - -(def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit))))) - -(begin - (def! quasiquote - (macro (x) - (def! constant? - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (lambda (exp) - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - ) - (def! combine-skeletons - (lambda (left right exp) - (cond - ((and (constant? left) (constant? right)) - (cond ((and (eqv? (eval left) (car exp)) - (eqv? (eval right) (cdr exp))) - (list 'quote exp) - ) - (else - (list 'quote (cons (eval left) (eval right))) - ) - ) - ) - ((null? right) - (list 'list left) - ) - ((and (pair? right) (eq? (car right) 'list)) - (cons 'list (cons left (cdr right))) - ) - (else - (list 'cons left right) - ) - ) - ) - ) - - (def! expand-quasiquote - (lambda (exp nesting) - (cond - - ; non cons -- constants - ; themselves, others are - ; quoted - - ((not (pair? exp)) - (cond ((constant? exp) - exp - ) - (else - (list 'quote exp) - ) - ) - ) - - ; check for an unquote exp and - ; add the param unquoted - - ((and (eq? (car exp) 'unquote) (= (length exp) 2)) - (cond ((= nesting 0) - (car (cdr exp)) - ) - (else - (combine-skeletons ''unquote - (expand-quasiquote (cdr exp) (- nesting 1)) - exp)) - ) - ) - - ; nested quasi-quote -- - ; construct the right - ; expression - - ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) - (combine-skeletons ''quasiquote - (expand-quasiquote (cdr exp) (+ nesting 1)) - exp)) - - ; check for an - ; unquote-splicing member, - ; compute the expansion of the - ; value and append the rest of - ; the quasiquote result to it - - ((and (pair? (car exp)) - (eq? (car (car exp)) 'unquote-splicing) - (= (length (car exp)) 2)) - (cond ((= nesting 0) - (list 'append (car (cdr (car exp))) - (expand-quasiquote (cdr exp) nesting)) - ) - (else - (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) - (expand-quasiquote (cdr exp) nesting) - exp)) - ) - ) - - ; for other lists, just glue - ; the expansion of the first - ; element to the expansion of - ; the rest of the list - - (else (combine-skeletons (expand-quasiquote (car exp) nesting) - (expand-quasiquote (cdr exp) nesting) - exp) - ) - ) - ) - ) - (def! result (expand-quasiquote x 0)) - result - ) - ) - 'quasiquote) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name x y z) sexprs ...) - ; - -(begin - (def! define - (macro (first . rest) - ; check for alternate lambda definition form - - (cond ((pair? first) - (set! rest - (append - (list - 'lambda - (cdr first)) - rest)) - (set! first (car first)) - ) - (else - (set! rest (car rest)) - ) - ) - (def! result `(,begin - (,def (,quote ,first) ,rest) - (,quote ,first)) - ) - result - ) - ) - 'define - ) - - ; basic list accessors - -(define (caar l) (car (car l))) - -(_??_ (caar '((1 2 3) (4 5 6))) 1) - -(define (cadr l) (car (cdr l))) - -(_??_ (cadr '(1 2 3 4 5 6)) 2) - -(define (cdar l) (cdr (car l))) - -(_??_ (cdar '((1 2) (3 4))) '(2)) - -(define (cddr l) (cdr (cdr l))) - -(_??_ (cddr '(1 2 3)) '(3)) - -(define (caddr l) (car (cdr (cdr l)))) - -(_??_ (caddr '(1 2 3 4)) 3) - - ; (if ) - ; (if 3 2) 'yes) 'yes) -(_??_ (if (> 3 2) 'yes 'no) 'yes) -(_??_ (if (> 2 3) 'no 'yes) 'yes) -(_??_ (if (> 2 3) 'no) #f) - - ; simple math operators - -(define zero? (macro (value) `(eq? ,value 0))) - -(_??_ (zero? 1) #f) -(_??_ (zero? 0) #t) -(_??_ (zero? "hello") #f) - -(define positive? (macro (value) `(> ,value 0))) - -(_??_ (positive? 12) #t) -(_??_ (positive? -12) #f) - -(define negative? (macro (value) `(< ,value 0))) - -(_??_ (negative? 12) #f) -(_??_ (negative? -12) #t) - -(define (abs x) (if (>= x 0) x (- x))) - -(_??_ (abs 12) 12) -(_??_ (abs -12) 12) - -(define max (lambda (first . rest) - (while (not (null? rest)) - (cond ((< first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(_??_ (max 1 2 3) 3) -(_??_ (max 3 2 1) 3) - -(define min (lambda (first . rest) - (while (not (null? rest)) - (cond ((> first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(_??_ (min 1 2 3) 1) -(_??_ (min 3 2 1) 1) - -(define (even? x) (zero? (% x 2))) - -(_??_ (even? 2) #t) -(_??_ (even? -2) #t) -(_??_ (even? 3) #f) -(_??_ (even? -1) #f) - -(define (odd? x) (not (even? x))) - -(_??_ (odd? 2) #f) -(_??_ (odd? -2) #f) -(_??_ (odd? 3) #t) -(_??_ (odd? -1) #t) - -(_??_ (list-tail '(1 2 3 . 4) 3) 4) - -(define (list-ref x k) - (car (list-tail x k)) - ) - -(_??_ (list-ref '(1 2 3 4) 3) 4) - -(define (list-set! x k v) - (set-car! (list-tail x k) v) - x) - -(list-set! (list 1 2 3) 1 4) - - ; define a set of local - ; variables all at once and - ; then evaluate a list of - ; sexprs - ; - ; (let (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let ((x 1) (y)) (set! y (+ x 1)) y) - -(define let - (macro (vars . exprs) - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-vals vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ; prepend the set operations - ; to the expressions - - ; build the lambda. - - `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) - ) - ) - - -(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) - - ; define a set of local - ; variables one at a time and - ; then evaluate a list of - ; sexprs - ; - ; (let* (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let* ((x 1) (y)) (set! y (+ x 1)) y) - -(define letrec - (macro (vars . exprs) - - ; - ; make the list of names in the let - ; - - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (make-exprs vars exprs) - (cond ((null? vars) exprs) - (else - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-nils vars) - (cond ((null? vars) ()) - (else (cons () (make-nils (cdr vars)))) - ) - ) - ; build the lambda. - - `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) - ) - ) - -(_??_ (letrec ((x 1) (y x)) (+ x y)) 2) - - ; letrec is sufficient for let* - -(define let* letrec) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(_??_ (when #t (+ 1 2)) 3) -(_??_ (when #f (+ 1 2)) #f) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(_??_ (unless #f (+ 2 3)) 5) -(_??_ (unless #t (+ 2 3)) #f) - -(define (reverse list) - (define (_r old new) - (if (null? old) - new - (_r (cdr old) (cons (car old) new)) - ) - ) - (_r list ()) - ) - -(_??_ (reverse '(1 2 3)) '(3 2 1)) - -(define make-list - (lambda (a . b) - (define (_m a x) - (if (zero? a) - x - (_m (- a 1) (cons b x)) - ) - ) - (if (null? b) - (set! b #f) - (set! b (car b)) - ) - (_m a '()) - ) - ) - -(_??_ (make-list 10 'a) '(a a a a a a a a a a)) - -(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) - -(define member (lambda (obj list . test?) - (cond ((null? list) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car list)) - list - (member obj (cdr list) test?)) - ) - ) - ) - ) - -(_??_ (member '(2) '((1) (2) (3))) '((2) (3))) - -(_??_ (member '(4) '((1) (2) (3))) #f) - -(define (memq obj list) (member obj list eq?)) - -(_??_ (memq 2 '(1 2 3)) '(2 3)) - -(_??_ (memq 4 '(1 2 3)) #f) - -(_??_ (memq '(2) '((1) (2) (3))) #f) - -(define (memv obj list) (member obj list eqv?)) - -(_??_ (memv 2 '(1 2 3)) '(2 3)) - -(_??_ (memv 4 '(1 2 3)) #f) - -(_??_ (memv '(2) '((1) (2) (3))) #f) - -(define (assoc obj list . compare) - (if (null? compare) - (set! compare equal?) - (set! compare (car compare)) - ) - (if (null? list) - #f - (if (compare obj (caar list)) - (car list) - (assoc obj (cdr list) compare) - ) - ) - ) - -(define (assq obj list) (assoc obj list eq?)) -(define (assv obj list) (assoc obj list eqv?)) - -(_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2)) -(_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(define char? integer?) - -(_??_ (char? #\q) #t) -(_??_ (char? "h") #f) - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(_??_ (char-upper-case? #\a) #f) -(_??_ (char-upper-case? #\B) #t) -(_??_ (char-upper-case? #\0) #f) -(_??_ (char-upper-case? #\space) #f) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(_??_ (char-lower-case? #\a) #t) -(_??_ (char-lower-case? #\B) #f) -(_??_ (char-lower-case? #\0) #f) -(_??_ (char-lower-case? #\space) #f) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(_??_ (char-alphabetic? #\a) #t) -(_??_ (char-alphabetic? #\B) #t) -(_??_ (char-alphabetic? #\0) #f) -(_??_ (char-alphabetic? #\space) #f) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(_??_ (char-numeric? #\a) #f) -(_??_ (char-numeric? #\B) #f) -(_??_ (char-numeric? #\0) #t) -(_??_ (char-numeric? #\space) #f) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(_??_ (char-whitespace? #\a) #f) -(_??_ (char-whitespace? #\B) #f) -(_??_ (char-whitespace? #\0) #f) -(_??_ (char-whitespace? #\space) #t) - -(define char->integer (macro (v) v)) -(define integer->char char->integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(_??_ (char-upcase #\a) #\A) -(_??_ (char-upcase #\B) #\B) -(_??_ (char-upcase #\0) #\0) -(_??_ (char-upcase #\space) #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(_??_ (char-downcase #\a) #\a) -(_??_ (char-downcase #\B) #\b) -(_??_ (char-downcase #\0) #\0) -(_??_ (char-downcase #\space) #\space) - -(define (digit-value c) - (if (char-numeric? c) - (- c #\0) - #f) - ) - -(_??_ (digit-value #\1) 1) -(_??_ (digit-value #\a) #f) - -(define string (lambda chars (list->string chars))) - -(_??_ (string #\a #\b #\c) "abc") - -(_??_ (apply cons '(a b)) '(a . b)) - -(define map - (lambda (proc . lists) - (define (_a lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (_a (cdr lists))) - ) - ) - ) - (define (_n lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (_n (cdr lists))) - ) - ) - ) - (define (_m lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (_a lists)) (_m (_n lists))) - ) - ) - ) - (_m lists) - ) - ) - -(_??_ (map cadr '((a b) (d e) (g h))) '(b e h)) - -(define for-each - (lambda (proc . lists) - (define (_f lists) - (cond ((null? (car lists)) #t) - (else - (apply proc (map car lists)) - (_f (map cdr lists)) - ) - ) - ) - (_f lists) - ) - ) - -(_??_ (let ((a 0)) - (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) - a - ) - 6) - - -(define (newline) (write-char #\newline)) - -(newline) - -(_??_ (call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - -3) - - - ; `q -> (quote q) - ; `(q) -> (append (quote (q))) - ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) - ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - - -(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) - - -(define repeat - (macro (count . rest) - (define counter '__count__) - (cond ((pair? count) - (set! counter (car count)) - (set! count (cadr count)) - ) - ) - `(let ((,counter 0) - (__max__ ,count) - ) - (while (< ,counter __max__) - ,@rest - (set! ,counter (+ ,counter 1)) - ) - ) - ) - ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write (list 'goodbye x))) - -(define case - (macro (test . l) - ; construct the body of the - ; case, dealing with the - ; lambda version ( => lambda) - - (define (_unarrow l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)) - ) - - ; Build the case elements, which is - ; simply a list of cond clauses - - (define (_case l) - - (cond ((null? l) ()) - - ; else case - - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) - - ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - ) - ) - - ; now construct the overall - ; expression, using a lambda - ; to hold the computed value - ; of the test expression - - `((lambda (__key__) - (cond ,@(_case l))) ,test) - ) - ) - -(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "one") -(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "two") -(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) "three") -(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "else") -(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "twelve") - -(define do - (macro (vars test . cmds) - (define (_step v) - (if (null? v) - '() - (if (null? (cddr (car v))) - (_step (cdr v)) - (cons `(set! ,(caar v) ,(caddr (car v))) - (_step (cdr v)) - ) - ) - ) - ) - `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) - (while (not ,(car test)) - ,@cmds - ,@(_step vars) - ) - ,@(cdr test) - ) - ) - ) - -(define (eof-object? a) - (equal? a 'eof) - ) - -(_??_ (do ((x 1 (+ x 1)) - (y 0) - ) - ((= x 10) y) - (set! y (+ y x)) - ) - 45) - -(_??_ (do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i)) #(0 1 2 3 4)) diff --git a/src/scheme/ao_scheme_do.scheme b/src/scheme/ao_scheme_do.scheme deleted file mode 100644 index 063e4a38..00000000 --- a/src/scheme/ao_scheme_do.scheme +++ /dev/null @@ -1,34 +0,0 @@ -(define do - (macro (vars test . cmds) - (define (_step v) - (if (null? v) - '() - (if (null? (cddr (car v))) - (_step (cdr v)) - (cons `(set! ,(caar v) ,(caddr (car v))) - (_step (cdr v)) - ) - ) - ) - ) - `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) - (while (not ,(car test)) - ,@cmds - ,@(_step vars) - ) - ,@(cdr test) - ) - ) - ) - -(do ((x 1 (+ x 1))) - ((= x 10) "done") - (display "x: ") - (write x) - (newline) - ) - -(do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i)) diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c deleted file mode 100644 index f97eb003..00000000 --- a/src/scheme/ao_scheme_error.c +++ /dev/null @@ -1,78 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" -#include - -void -ao_scheme_vfprintf(FILE *out, const char *format, va_list args) -{ - char c; - - while ((c = *format++) != '\0') { - if (c == '%') { - switch (c = *format++) { - case 'v': - ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), true); - break; - case 'V': - ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), false); - break; - case 'p': - fprintf(out, "%p", va_arg(args, void *)); - break; - case 'd': - fprintf(out, "%d", va_arg(args, int)); - break; - case 'x': - fprintf(out, "%x", va_arg(args, int)); - break; - case 's': - fprintf(out, "%s", va_arg(args, char *)); - break; - default: - putc(c, out); - break; - } - } else - putc(c, out); - } -} - -void -ao_scheme_fprintf(FILE *out, const char *format, ...) -{ - va_list args; - va_start(args, format); - ao_scheme_vfprintf(out, format, args); - va_end(args); -} - -ao_poly -ao_scheme_error(int error, const char *format, ...) -{ - va_list args; - - ao_scheme_exception |= error; - va_start(args, format); - ao_scheme_vfprintf(stdout, format, args); - putchar('\n'); - va_end(args); - ao_scheme_fprintf(stdout, "Value: %v\n", ao_scheme_v); - ao_scheme_fprintf(stdout, "Frame: %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); - printf("Stack:\n"); - ao_scheme_stack_write(stdout, ao_scheme_stack_poly(ao_scheme_stack), true); - ao_scheme_fprintf(stdout, "Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); - return AO_SCHEME_NIL; -} diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c deleted file mode 100644 index 9536cb91..00000000 --- a/src/scheme/ao_scheme_eval.c +++ /dev/null @@ -1,573 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" -#include - -struct ao_scheme_stack *ao_scheme_stack; -ao_poly ao_scheme_v; - -ao_poly -ao_scheme_set_cond(struct ao_scheme_cons *c) -{ - ao_scheme_stack->state = eval_cond; - ao_scheme_stack->sexprs = ao_scheme_cons_poly(c); - return AO_SCHEME_NIL; -} - -static int -func_type(ao_poly func) -{ - if (func == AO_SCHEME_NIL) - return ao_scheme_error(AO_SCHEME_INVALID, "func is nil"); - switch (ao_scheme_poly_type(func)) { - case AO_SCHEME_BUILTIN: - return ao_scheme_poly_builtin(func)->args & AO_SCHEME_FUNC_MASK; - case AO_SCHEME_LAMBDA: - return ao_scheme_poly_lambda(func)->args; - case AO_SCHEME_STACK: - return AO_SCHEME_FUNC_LAMBDA; - default: - ao_scheme_error(AO_SCHEME_INVALID, "not a func"); - return -1; - } -} - -/* - * Flattened eval to avoid stack issues - */ - -/* - * Evaluate an s-expression - * - * For a list, evaluate all of the elements and - * then execute the resulting function call. - * - * Each element of the list is evaluated in - * a clean stack context. - * - * The current stack state is set to 'formal' so that - * when the evaluation is complete, the value - * will get appended to the values list. - * - * For other types, compute the value directly. - */ - -static int -ao_scheme_eval_sexpr(void) -{ - DBGI("sexpr: %v\n", ao_scheme_v); - switch (ao_scheme_poly_type(ao_scheme_v)) { - case AO_SCHEME_CONS: - if (ao_scheme_v == AO_SCHEME_NIL) { - if (!ao_scheme_stack->values) { - /* - * empty list evaluates to empty list - */ - ao_scheme_v = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_val; - } else { - /* - * done with arguments, go execute it - */ - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; - ao_scheme_stack->state = eval_exec; - } - } else { - if (!ao_scheme_stack->values) - ao_scheme_stack->list = ao_scheme_v; - /* - * Evaluate another argument and then switch - * to 'formal' to add the value to the values - * list - */ - ao_scheme_stack->sexprs = ao_scheme_v; - ao_scheme_stack->state = eval_formal; - if (!ao_scheme_stack_push()) - return 0; - /* - * push will reset the state to 'sexpr', which - * will evaluate the expression - */ - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; - } - break; - case AO_SCHEME_ATOM: - DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); - /* fall through */ - default: - ao_scheme_stack->state = eval_val; - break; - } - DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG("\n"); - return 1; -} - -/* - * A value has been computed. - * - * If the value was computed from a macro, - * then we want to reset the current context - * to evaluate the macro result again. - * - * If not a macro, then pop the stack. - * If the stack is empty, we're done. - * Otherwise, the stack will contain - * the next state. - */ - -static int -ao_scheme_eval_val(void) -{ - DBGI("val: "); DBG_POLY(ao_scheme_v); DBG("\n"); - /* - * Value computed, pop the stack - * to figure out what to do with the value - */ - ao_scheme_stack_pop(); - DBGI("..state %d\n", ao_scheme_stack ? ao_scheme_stack->state : -1); - return 1; -} - -/* - * A formal has been computed. - * - * If this is the first formal, then check to see if we've got a - * lamda, macro or nlambda. - * - * For lambda, go compute another formal. This will terminate - * when the sexpr state sees nil. - * - * For macro/nlambda, we're done, so move the sexprs into the values - * and go execute it. - * - * Macros have an additional step of saving a stack frame holding the - * macro value execution context, which then gets the result of the - * macro to run - */ - -static int -ao_scheme_eval_formal(void) -{ - ao_poly formal; - struct ao_scheme_stack *prev; - - DBGI("formal: "); DBG_POLY(ao_scheme_v); DBG("\n"); - - /* Check what kind of function we've got */ - if (!ao_scheme_stack->values) { - switch (func_type(ao_scheme_v)) { - case AO_SCHEME_FUNC_LAMBDA: - DBGI(".. lambda\n"); - break; - case AO_SCHEME_FUNC_MACRO: - /* Evaluate the result once more */ - ao_scheme_stack->state = eval_macro; - if (!ao_scheme_stack_push()) - return 0; - - /* After the function returns, take that - * value and re-evaluate it - */ - prev = ao_scheme_poly_stack(ao_scheme_stack->prev); - ao_scheme_stack->sexprs = prev->sexprs; - - DBGI(".. start macro\n"); - DBGI("\t.. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI("\t.. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); - DBG_FRAMES(); - - /* fall through ... */ - case AO_SCHEME_FUNC_NLAMBDA: - DBGI(".. nlambda or macro\n"); - - /* use the raw sexprs as values */ - ao_scheme_stack->values = ao_scheme_stack->sexprs; - ao_scheme_stack->values_tail = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_exec; - - /* ready to execute now */ - return 1; - case -1: - return 0; - } - } - - /* Append formal to list of values */ - formal = ao_scheme_cons(ao_scheme_v, AO_SCHEME_NIL); - if (!formal) - return 0; - - if (ao_scheme_stack->values_tail) - ao_scheme_poly_cons(ao_scheme_stack->values_tail)->cdr = formal; - else - ao_scheme_stack->values = formal; - ao_scheme_stack->values_tail = formal; - - DBGI(".. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); - - /* - * Step to the next argument, if this is last, then - * 'sexpr' will end up switching to 'exec' - */ - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; - - ao_scheme_stack->state = eval_sexpr; - - DBGI(".. "); DBG_POLY(ao_scheme_v); DBG("\n"); - return 1; -} - -/* - * Start executing a function call - * - * Most builtins are easy, just call the function. - * 'cond' is magic; it sticks the list of clauses - * in 'sexprs' and switches to 'cond' state. That - * bit of magic is done in ao_scheme_set_cond. - * - * Lambdas build a new frame to hold the locals and - * then re-use the current stack context to evaluate - * the s-expression from the lambda. - */ - -static int -ao_scheme_eval_exec(void) -{ - ao_poly v; - struct ao_scheme_builtin *builtin; - - DBGI("exec: "); DBG_POLY(ao_scheme_v); DBG(" values "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); - ao_scheme_stack->sexprs = AO_SCHEME_NIL; - switch (ao_scheme_poly_type(ao_scheme_v)) { - case AO_SCHEME_BUILTIN: - ao_scheme_stack->state = eval_val; - builtin = ao_scheme_poly_builtin(ao_scheme_v); - v = ao_scheme_func(builtin) ( - ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr)); - DBG_DO(if (!ao_scheme_exception && ao_scheme_poly_builtin(ao_scheme_v)->func == builtin_set) { - struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); - ao_poly atom = ao_scheme_arg(cons, 1); - ao_poly val = ao_scheme_arg(cons, 2); - DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); - }); - builtin = ao_scheme_poly_builtin(ao_scheme_v); - if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack)) { - struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); - ao_scheme_stack->values = AO_SCHEME_NIL; - ao_scheme_cons_free(cons); - } - - ao_scheme_v = v; - if (ao_scheme_stack->state != eval_exec) { - ao_scheme_stack->values = AO_SCHEME_NIL; - ao_scheme_stack->values_tail = AO_SCHEME_NIL; - } - DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - break; - case AO_SCHEME_LAMBDA: - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - ao_scheme_stack->state = eval_begin; - v = ao_scheme_lambda_eval(); - ao_scheme_stack->sexprs = v; - ao_scheme_stack->values = AO_SCHEME_NIL; - ao_scheme_stack->values_tail = AO_SCHEME_NIL; - DBGI(".. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - break; - case AO_SCHEME_STACK: - DBGI(".. stack "); DBG_POLY(ao_scheme_v); DBG("\n"); - ao_scheme_v = ao_scheme_stack_eval(); - DBGI(".. value "); DBG_POLY(ao_scheme_v); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - break; - } - return 1; -} - -/* - * Finish setting up the apply evaluation - * - * The value is the list to execute - */ -static int -ao_scheme_eval_apply(void) -{ - struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_v); - struct ao_scheme_cons *cdr, *prev; - - /* Glue the arguments into the right shape. That's all but the last - * concatenated onto the last - */ - cdr = cons; - for (;;) { - prev = cdr; - cdr = ao_scheme_poly_cons(prev->cdr); - if (cdr->cdr == AO_SCHEME_NIL) - break; - } - DBGI("before mangling: "); DBG_POLY(ao_scheme_v); DBG("\n"); - prev->cdr = cdr->car; - ao_scheme_stack->values = ao_scheme_v; - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; - DBGI("apply: "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); - ao_scheme_stack->state = eval_exec; - ao_scheme_stack_mark(ao_scheme_stack); - return 1; -} - -/* - * Start evaluating the next cond clause - * - * If the list of clauses is empty, then - * the result of the cond is nil. - * - * Otherwise, set the current stack state to 'cond_test' and create a - * new stack context to evaluate the test s-expression. Once that's - * complete, we'll land in 'cond_test' to finish the clause. - */ -static int -ao_scheme_eval_cond(void) -{ - DBGI("cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - if (!ao_scheme_stack->sexprs) { - ao_scheme_v = _ao_scheme_bool_false; - ao_scheme_stack->state = eval_val; - } else { - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; - if (!ao_scheme_is_pair(ao_scheme_v)) { - ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); - return 0; - } - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; - if (ao_scheme_v == _ao_scheme_atom_else) - ao_scheme_v = _ao_scheme_bool_true; - ao_scheme_stack->state = eval_cond_test; - if (!ao_scheme_stack_push()) - return 0; - } - return 1; -} - -/* - * Finish a cond clause. - * - * Check the value from the test expression, if - * non-nil, then set up to evaluate the value expression. - * - * Otherwise, step to the next clause and go back to the 'cond' - * state - */ -static int -ao_scheme_eval_cond_test(void) -{ - DBGI("cond_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - if (ao_scheme_v != _ao_scheme_bool_false) { - struct ao_scheme_cons *car = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car); - ao_poly c = car->cdr; - - if (c) { - ao_scheme_stack->state = eval_begin; - ao_scheme_stack->sexprs = c; - } else - ao_scheme_stack->state = eval_val; - } else { - ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; - DBGI("next cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - ao_scheme_stack->state = eval_cond; - } - return 1; -} - -/* - * Evaluate a list of sexprs, returning the value from the last one. - * - * ao_scheme_begin records the list in stack->sexprs, so we just need to - * walk that list. Set ao_scheme_v to the car of the list and jump to - * eval_sexpr. When that's done, it will land in eval_val. For all but - * the last, leave a stack frame with eval_begin set so that we come - * back here. For the last, don't add a stack frame so that we can - * just continue on. - */ -static int -ao_scheme_eval_begin(void) -{ - DBGI("begin: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - - if (!ao_scheme_stack->sexprs) { - ao_scheme_v = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_val; - } else { - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; - ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; - - /* If there are more sexprs to do, then come back here, otherwise - * return the value of the last one by just landing in eval_sexpr - */ - if (ao_scheme_stack->sexprs) { - ao_scheme_stack->state = eval_begin; - if (!ao_scheme_stack_push()) - return 0; - } - ao_scheme_stack->state = eval_sexpr; - } - return 1; -} - -/* - * Conditionally execute a list of sexprs while the first is true - */ -static int -ao_scheme_eval_while(void) -{ - DBGI("while: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - - ao_scheme_stack->values = ao_scheme_v; - if (!ao_scheme_stack->sexprs) { - ao_scheme_v = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_val; - } else { - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; - ao_scheme_stack->state = eval_while_test; - if (!ao_scheme_stack_push()) - return 0; - } - return 1; -} - -/* - * Check the while condition, terminate the loop if nil. Otherwise keep going - */ -static int -ao_scheme_eval_while_test(void) -{ - DBGI("while_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - - if (ao_scheme_v != _ao_scheme_bool_false) { - ao_scheme_stack->values = ao_scheme_v; - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; - ao_scheme_stack->state = eval_while; - if (!ao_scheme_stack_push()) - return 0; - ao_scheme_stack->state = eval_begin; - ao_scheme_stack->sexprs = ao_scheme_v; - } - else - { - ao_scheme_stack->state = eval_val; - ao_scheme_v = ao_scheme_stack->values; - } - return 1; -} - -/* - * Replace the original sexpr with the macro expansion, then - * execute that - */ -static int -ao_scheme_eval_macro(void) -{ - DBGI("macro: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - - if (ao_scheme_v == AO_SCHEME_NIL) - ao_scheme_abort(); - if (ao_scheme_is_cons(ao_scheme_v)) { - *ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); - ao_scheme_v = ao_scheme_stack->sexprs; - DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); - } - ao_scheme_stack->sexprs = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_sexpr; - return 1; -} - -static int (*const evals[])(void) = { - [eval_sexpr] = ao_scheme_eval_sexpr, - [eval_val] = ao_scheme_eval_val, - [eval_formal] = ao_scheme_eval_formal, - [eval_exec] = ao_scheme_eval_exec, - [eval_apply] = ao_scheme_eval_apply, - [eval_cond] = ao_scheme_eval_cond, - [eval_cond_test] = ao_scheme_eval_cond_test, - [eval_begin] = ao_scheme_eval_begin, - [eval_while] = ao_scheme_eval_while, - [eval_while_test] = ao_scheme_eval_while_test, - [eval_macro] = ao_scheme_eval_macro, -}; - -const char * const ao_scheme_state_names[] = { - [eval_sexpr] = "sexpr", - [eval_val] = "val", - [eval_formal] = "formal", - [eval_exec] = "exec", - [eval_apply] = "apply", - [eval_cond] = "cond", - [eval_cond_test] = "cond_test", - [eval_begin] = "begin", - [eval_while] = "while", - [eval_while_test] = "while_test", - [eval_macro] = "macro", -}; - -#ifdef AO_SCHEME_FEATURE_SAVE -/* - * Called at restore time to reset all execution state - */ - -void -ao_scheme_eval_clear_globals(void) -{ - ao_scheme_stack = NULL; - ao_scheme_frame_current = NULL; - ao_scheme_v = AO_SCHEME_NIL; -} - -int -ao_scheme_eval_restart(void) -{ - return ao_scheme_stack_push(); -} -#endif /* AO_SCHEME_FEATURE_SAVE */ - -ao_poly -ao_scheme_eval(ao_poly _v) -{ - ao_scheme_v = _v; - - ao_scheme_frame_init(); - - if (!ao_scheme_stack_push()) - return AO_SCHEME_NIL; - - while (ao_scheme_stack) { - if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) - break; - } - DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); - ao_scheme_stack = NULL; - ao_scheme_frame_current = NULL; - return ao_scheme_v; -} diff --git a/src/scheme/ao_scheme_finish.scheme b/src/scheme/ao_scheme_finish.scheme deleted file mode 100644 index fde04fb3..00000000 --- a/src/scheme/ao_scheme_finish.scheme +++ /dev/null @@ -1,17 +0,0 @@ -; -; Copyright © 2018 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Finish setting up ROM lisp code - -(undef '_?_) -(undef '_??_) diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c deleted file mode 100644 index 483035f9..00000000 --- a/src/scheme/ao_scheme_float.c +++ /dev/null @@ -1,161 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" -#include - -#ifdef AO_SCHEME_FEATURE_FLOAT - -static void float_mark(void *addr) -{ - (void) addr; -} - -static int float_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_scheme_float); -} - -static void float_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_float_type = { - .mark = float_mark, - .size = float_size, - .move = float_move, - .name = "float", -}; - -#ifndef FLOAT_FORMAT -#define FLOAT_FORMAT "%g" -#endif - -void -ao_scheme_float_write(FILE *out, ao_poly p, bool write) -{ - struct ao_scheme_float *f = ao_scheme_poly_float(p); - float v = f->value; - - (void) write; - if (isnanf(v)) - fputs("+nan.0", out); - else if (isinff(v)) { - if (v < 0) - putc('-', out); - else - putc('+', out); - fputs("inf.0", out); - } else - fprintf(out, FLOAT_FORMAT, v); -} - -float -ao_scheme_poly_number(ao_poly p) -{ - switch (ao_scheme_poly_base_type(p)) { - case AO_SCHEME_INT: - return ao_scheme_poly_int(p); - case AO_SCHEME_BIGINT: - return ao_scheme_poly_bigint(p)->value; - case AO_SCHEME_OTHER: - switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { - case AO_SCHEME_FLOAT: - return ao_scheme_poly_float(p)->value; - } - } - return NAN; -} - -ao_poly -ao_scheme_float_get(float value) -{ - struct ao_scheme_float *f; - - f = ao_scheme_alloc(sizeof (struct ao_scheme_float)); - f->type = AO_SCHEME_FLOAT; - f->value = value; - return ao_scheme_float_poly(f); -} - -ao_poly -ao_scheme_do_inexactp(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (ao_scheme_poly_type(val) == AO_SCHEME_FLOAT) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_finitep(struct ao_scheme_cons *cons) -{ - ao_poly val; - float f; - - if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - return _ao_scheme_bool_true; - case AO_SCHEME_FLOAT: - f = ao_scheme_poly_float(val)->value; - if (!isnan(f) && !isinf(f)) - return _ao_scheme_bool_true; - } - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_infinitep(struct ao_scheme_cons *cons) -{ - ao_poly val; - float f; - - if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_FLOAT: - f = ao_scheme_poly_float(val)->value; - if (isinf(f)) - return _ao_scheme_bool_true; - } - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_sqrt(struct ao_scheme_cons *cons) -{ - float f; - - if (!ao_scheme_parse_args(_ao_scheme_atom_sqrt, cons, - AO_SCHEME_FLOAT, &f, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_float_get(sqrtf(f)); -} -#endif diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c deleted file mode 100644 index e4da279b..00000000 --- a/src/scheme/ao_scheme_frame.c +++ /dev/null @@ -1,391 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -static inline int -frame_vals_num_size(int num) -{ - return sizeof (struct ao_scheme_frame_vals) + num * sizeof (struct ao_scheme_val); -} - -static int -frame_vals_size(void *addr) -{ - struct ao_scheme_frame_vals *vals = addr; - return frame_vals_num_size(vals->size); -} - -static void -frame_vals_mark(void *addr) -{ - struct ao_scheme_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_scheme_val *v = &vals->vals[f]; - - ao_scheme_poly_mark(v->atom, 0); - ao_scheme_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d\n", - ao_scheme_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_scheme_ref(v->atom)), - MDBG_OFFSET(ao_scheme_ref(v->val)), f); - } -} - -static void -frame_vals_move(void *addr) -{ - struct ao_scheme_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_scheme_val *v = &vals->vals[f]; - - ao_scheme_poly_move(&v->atom, 0); - ao_scheme_poly_move(&v->val, 0); - MDBG_MOVE("frame move atom %s %d val %d at %d\n", - ao_scheme_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_scheme_ref(v->atom)), - MDBG_OFFSET(ao_scheme_ref(v->val)), f); - } -} - -const struct ao_scheme_type ao_scheme_frame_vals_type = { - .mark = frame_vals_mark, - .size = frame_vals_size, - .move = frame_vals_move, - .name = "frame_vals" -}; - -static int -frame_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_frame); -} - -static void -frame_mark(void *addr) -{ - struct ao_scheme_frame *frame = addr; - - for (;;) { - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - - MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); - if (!ao_scheme_mark_memory(&ao_scheme_frame_vals_type, vals)) - frame_vals_mark(vals); - frame = ao_scheme_poly_frame(frame->prev); - MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); - if (!frame) - break; - if (ao_scheme_mark_memory(&ao_scheme_frame_type, frame)) - break; - } -} - -static void -frame_move(void *addr) -{ - struct ao_scheme_frame *frame = addr; - - for (;;) { - struct ao_scheme_frame *prev; - struct ao_scheme_frame_vals *vals; - int ret; - - MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - vals = ao_scheme_poly_frame_vals(frame->vals); - if (!ao_scheme_move_memory(&ao_scheme_frame_vals_type, (void **) &vals)) - frame_vals_move(vals); - if (vals != ao_scheme_poly_frame_vals(frame->vals)) - frame->vals = ao_scheme_frame_vals_poly(vals); - - prev = ao_scheme_poly_frame(frame->prev); - if (!prev) - break; - ret = ao_scheme_move_memory(&ao_scheme_frame_type, (void **) &prev); - if (prev != ao_scheme_poly_frame(frame->prev)) { - MDBG_MOVE("frame prev moved from %d to %d\n", - MDBG_OFFSET(ao_scheme_poly_frame(frame->prev)), - MDBG_OFFSET(prev)); - frame->prev = ao_scheme_frame_poly(prev); - } - if (ret) - break; - frame = prev; - } -} - -const struct ao_scheme_type ao_scheme_frame_type = { - .mark = frame_mark, - .size = frame_size, - .move = frame_move, - .name = "frame", -}; - -int ao_scheme_frame_print_indent; - -static void -ao_scheme_frame_indent(FILE *out, int extra) -{ - int i; - putc('\n', out); - for (i = 0; i < ao_scheme_frame_print_indent+extra; i++) - putc('\t', out); -} - -void -ao_scheme_frame_write(FILE *out, ao_poly p, bool write) -{ - struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); - struct ao_scheme_frame *clear = frame; - int f; - int written = 0; - - ao_scheme_print_start(); - while (frame) { - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - - if (written != 0) - fputs(", ", out); - if (ao_scheme_print_mark_addr(frame)) { - fputs("recurse...", out); - break; - } - - putc('{', out); - written++; - for (f = 0; f < frame->num; f++) { - ao_scheme_frame_indent(out, 1); - ao_scheme_poly_write(out, vals->vals[f].atom, write); - fputs(" = ", out); - ao_scheme_poly_write(out, vals->vals[f].val, write); - } - frame = ao_scheme_poly_frame(frame->prev); - ao_scheme_frame_indent(out, 0); - putc('}', out); - } - if (ao_scheme_print_stop()) { - while (written--) { - ao_scheme_print_clear_addr(clear); - clear = ao_scheme_poly_frame(clear->prev); - } - } -} - -static int -ao_scheme_frame_find(struct ao_scheme_frame *frame, int top, ao_poly atom) -{ - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - int l = 0; - int r = top - 1; - - while (l <= r) { - int m = (l + r) >> 1; - if (vals->vals[m].atom < atom) - l = m + 1; - else - r = m - 1; - } - return l; -} - -ao_poly * -ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom) -{ - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - int l = ao_scheme_frame_find(frame, frame->num, atom); - - if (l >= frame->num) - return NULL; - - if (vals->vals[l].atom != atom) - return NULL; - return &vals->vals[l].val; -} - -struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; - -static struct ao_scheme_frame_vals * -ao_scheme_frame_vals_new(int num) -{ - struct ao_scheme_frame_vals *vals; - - vals = ao_scheme_alloc(frame_vals_num_size(num)); - if (!vals) - return NULL; - vals->type = AO_SCHEME_FRAME_VALS; - vals->size = num; - memset(vals->vals, '\0', num * sizeof (struct ao_scheme_val)); - return vals; -} - -struct ao_scheme_frame * -ao_scheme_frame_new(int num) -{ - struct ao_scheme_frame *frame; - struct ao_scheme_frame_vals *vals; - - if (num < AO_SCHEME_FRAME_FREE && (frame = ao_scheme_frame_free_list[num])) { - ao_scheme_frame_free_list[num] = ao_scheme_poly_frame(frame->prev); - vals = ao_scheme_poly_frame_vals(frame->vals); - } else { - frame = ao_scheme_alloc(sizeof (struct ao_scheme_frame)); - if (!frame) - return NULL; - frame->type = AO_SCHEME_FRAME; - frame->num = 0; - frame->prev = AO_SCHEME_NIL; - frame->vals = AO_SCHEME_NIL; - ao_scheme_frame_stash(frame); - vals = ao_scheme_frame_vals_new(num); - frame = ao_scheme_frame_fetch(); - if (!vals) - return NULL; - frame->vals = ao_scheme_frame_vals_poly(vals); - frame->num = num; - } - frame->prev = AO_SCHEME_NIL; - return frame; -} - -ao_poly -ao_scheme_frame_mark(struct ao_scheme_frame *frame) -{ - if (!frame) - return AO_SCHEME_NIL; - frame->type |= AO_SCHEME_FRAME_MARK; - return ao_scheme_frame_poly(frame); -} - -void -ao_scheme_frame_free(struct ao_scheme_frame *frame) -{ - if (frame && !ao_scheme_frame_marked(frame)) { - int num = frame->num; - if (num < AO_SCHEME_FRAME_FREE) { - struct ao_scheme_frame_vals *vals; - - vals = ao_scheme_poly_frame_vals(frame->vals); - memset(vals->vals, '\0', vals->size * sizeof (struct ao_scheme_val)); - frame->prev = ao_scheme_frame_poly(ao_scheme_frame_free_list[num]); - ao_scheme_frame_free_list[num] = frame; - } - } -} - -static struct ao_scheme_frame * -ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) -{ - struct ao_scheme_frame_vals *vals; - struct ao_scheme_frame_vals *new_vals; - int copy; - - if (new_num == frame->num) - return frame; - ao_scheme_frame_stash(frame); - new_vals = ao_scheme_frame_vals_new(new_num); - frame = ao_scheme_frame_fetch(); - if (!new_vals) - return NULL; - vals = ao_scheme_poly_frame_vals(frame->vals); - copy = new_num; - if (copy > frame->num) - copy = frame->num; - memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_scheme_val)); - frame->vals = ao_scheme_frame_vals_poly(new_vals); - frame->num = new_num; - return frame; -} - -void -ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val) -{ - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - int l = ao_scheme_frame_find(frame, num, atom); - - memmove(&vals->vals[l+1], - &vals->vals[l], - (num - l) * sizeof (struct ao_scheme_val)); - vals->vals[l].atom = atom; - vals->vals[l].val = val; -} - -ao_poly -ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) -{ - ao_poly *ref = frame ? ao_scheme_frame_ref(frame, atom) : NULL; - - if (!ref) { - int f = frame->num; - ao_scheme_poly_stash(atom); - ao_scheme_poly_stash(val); - frame = ao_scheme_frame_realloc(frame, f + 1); - val = ao_scheme_poly_fetch(); - atom = ao_scheme_poly_fetch(); - if (!frame) - return AO_SCHEME_NIL; - ao_scheme_frame_bind(frame, frame->num - 1, atom, val); - } else - *ref = val; - return val; -} - -#ifdef AO_SCHEME_FEATURE_UNDEF -ao_poly -ao_scheme_frame_del(struct ao_scheme_frame *frame, ao_poly atom) -{ - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - int l = ao_scheme_frame_find(frame, frame->num, atom); - int f = frame->num; - struct ao_scheme_frame *moved_frame; - - if (l >= frame->num) - return _ao_scheme_bool_false; - - if (vals->vals[l].atom != atom) - return _ao_scheme_bool_false; - - /* squash the deleted entry */ - memmove(&vals->vals[l], - &vals->vals[l+1], - (f - l) * sizeof (struct ao_scheme_val)); - - /* allocate a smaller vals array */ - ao_scheme_frame_stash(frame); - moved_frame = ao_scheme_frame_realloc(frame, f - 1); - frame = ao_scheme_frame_fetch(); - - /* - * We couldn't allocate a smaller frame, so just - * ignore the last value in the array - */ - if (!moved_frame) - frame->num = f - 1; - return _ao_scheme_bool_true; -} -#endif - -struct ao_scheme_frame *ao_scheme_frame_global; -struct ao_scheme_frame *ao_scheme_frame_current; - -void -ao_scheme_frame_init(void) -{ - if (!ao_scheme_frame_global) - ao_scheme_frame_global = ao_scheme_frame_new(0); -} diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c deleted file mode 100644 index 2c9e45a0..00000000 --- a/src/scheme/ao_scheme_int.c +++ /dev/null @@ -1,132 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -void -ao_scheme_int_write(FILE *out, ao_poly p, bool write) -{ - int i = ao_scheme_poly_int(p); - (void) write; - fprintf(out, "%d", i); -} - -ao_poly -ao_scheme_do_integerp(struct ao_scheme_cons *cons) -{ -#ifdef AO_SCHEME_FEATURE_BIGINT - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - return _ao_scheme_bool_true; - default: - return _ao_scheme_bool_false; - } -#else - return ao_scheme_do_typep(_ao_scheme_atom_integer3f, AO_SCHEME_INT, cons); -#endif -} - -ao_poly -ao_scheme_do_numberp(struct ao_scheme_cons *cons) -{ -#if defined(AO_SCHEME_FEATURE_BIGINT) || defined(AO_SCHEME_FEATURE_FLOAT) - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_INT: -#ifdef AO_SCHEME_FEATURE_BIGINT - case AO_SCHEME_BIGINT: -#endif -#ifdef AO_SCHEME_FEATURE_FLOAT - case AO_SCHEME_FLOAT: -#endif - return _ao_scheme_bool_true; - default: - return _ao_scheme_bool_false; - } -#else - return ao_scheme_do_integerp(cons); -#endif -} - -#ifdef AO_SCHEME_FEATURE_BIGINT - -int32_t -ao_scheme_poly_integer(ao_poly p) -{ - switch (ao_scheme_poly_base_type(p)) { - case AO_SCHEME_INT: - return ao_scheme_poly_int(p); - case AO_SCHEME_BIGINT: - return ao_scheme_poly_bigint(p)->value; - } - return 0; -} - -ao_poly -ao_scheme_integer_poly(int32_t p) -{ - struct ao_scheme_bigint *bi; - - if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) - return ao_scheme_int_poly(p); - bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); - bi->value = p; - return ao_scheme_bigint_poly(bi); -} - -static void bigint_mark(void *addr) -{ - (void) addr; -} - -static int bigint_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_scheme_bigint); -} - -static void bigint_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_bigint_type = { - .mark = bigint_mark, - .size = bigint_size, - .move = bigint_move, - .name = "bigint", -}; - -void -ao_scheme_bigint_write(FILE *out, ao_poly p, bool write) -{ - struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); - - (void) write; - fprintf(out, "%d", bi->value); -} -#endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c deleted file mode 100644 index 18470efe..00000000 --- a/src/scheme/ao_scheme_lambda.c +++ /dev/null @@ -1,208 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_scheme.h" - -static int -lambda_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_lambda); -} - -static void -lambda_mark(void *addr) -{ - struct ao_scheme_lambda *lambda = addr; - - ao_scheme_poly_mark(lambda->code, 0); - ao_scheme_poly_mark(lambda->frame, 0); -} - -static void -lambda_move(void *addr) -{ - struct ao_scheme_lambda *lambda = addr; - - ao_scheme_poly_move(&lambda->code, 0); - ao_scheme_poly_move(&lambda->frame, 0); -} - -const struct ao_scheme_type ao_scheme_lambda_type = { - .size = lambda_size, - .mark = lambda_mark, - .move = lambda_move, - .name = "lambda", -}; - -void -ao_scheme_lambda_write(FILE *out, ao_poly poly, bool write) -{ - struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly); - struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code); - - putc('(', out); - fputs(ao_scheme_args_name(lambda->args), out); - while (cons) { - putc(' ', out); - ao_scheme_poly_write(out, cons->car, write); - cons = ao_scheme_poly_cons(cons->cdr); - } - putc(')', out); -} - -static ao_poly -ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) -{ - struct ao_scheme_lambda *lambda; - ao_poly formal; - struct ao_scheme_cons *cons; - - formal = ao_scheme_arg(code, 0); - while (formal != AO_SCHEME_NIL) { - switch (ao_scheme_poly_type(formal)) { - case AO_SCHEME_CONS: - cons = ao_scheme_poly_cons(formal); - if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM) - return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car); - formal = cons->cdr; - break; - case AO_SCHEME_ATOM: - formal = AO_SCHEME_NIL; - break; - default: - return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal); - } - } - - ao_scheme_cons_stash(code); - lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); - code = ao_scheme_cons_fetch(); - if (!lambda) - return AO_SCHEME_NIL; - - lambda->type = AO_SCHEME_LAMBDA; - lambda->args = args; - lambda->code = ao_scheme_cons_poly(code); - lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current); - DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); - DBG_STACK(); - return ao_scheme_lambda_poly(lambda); -} - -ao_poly -ao_scheme_do_lambda(struct ao_scheme_cons *cons) -{ - return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA); -} - -ao_poly -ao_scheme_do_nlambda(struct ao_scheme_cons *cons) -{ - return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA); -} - -ao_poly -ao_scheme_do_macro(struct ao_scheme_cons *cons) -{ - return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO); -} - -ao_poly -ao_scheme_lambda_eval(void) -{ - struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(ao_scheme_v); - struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); - struct ao_scheme_cons *code = ao_scheme_poly_cons(lambda->code); - ao_poly formals; - struct ao_scheme_frame *next_frame; - int args_wanted; - ao_poly varargs = AO_SCHEME_NIL; - int args_provided; - int f; - struct ao_scheme_cons *vals; - - DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n"); - - args_wanted = 0; - for (formals = ao_scheme_arg(code, 0); - ao_scheme_is_pair(formals); - formals = ao_scheme_poly_cons(formals)->cdr) - ++args_wanted; - if (formals != AO_SCHEME_NIL) { - if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM) - return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form"); - varargs = formals; - } - - /* Create a frame to hold the variables - */ - args_provided = ao_scheme_cons_length(cons) - 1; - if (varargs == AO_SCHEME_NIL) { - if (args_wanted != args_provided) - return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided); - } else { - if (args_provided < args_wanted) - return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); - } - - ao_scheme_poly_stash(varargs); - next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); - varargs = ao_scheme_poly_fetch(); - if (!next_frame) - return AO_SCHEME_NIL; - - /* Re-fetch all of the values in case something moved */ - lambda = ao_scheme_poly_lambda(ao_scheme_v); - cons = ao_scheme_poly_cons(ao_scheme_stack->values); - code = ao_scheme_poly_cons(lambda->code); - formals = ao_scheme_arg(code, 0); - vals = ao_scheme_poly_cons(cons->cdr); - - next_frame->prev = lambda->frame; - ao_scheme_frame_current = next_frame; - ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); - - for (f = 0; f < args_wanted; f++) { - struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); - DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); - formals = arg->cdr; - vals = ao_scheme_poly_cons(vals->cdr); - } - if (varargs) { - DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); - /* - * Bind the rest of the arguments to the final parameter - */ - ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals)); - } else { - /* - * Mark the cons cells from the actuals as freed for immediate re-use, unless - * the actuals point into the source function (nlambdas and macros), or if the - * stack containing them was copied as a part of a continuation - */ - if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { - ao_scheme_stack->values = AO_SCHEME_NIL; - ao_scheme_cons_free(cons); - } - } - DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n"); - DBG_STACK(); - DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); - return code->cdr; -} diff --git a/src/scheme/ao_scheme_lex.c b/src/scheme/ao_scheme_lex.c deleted file mode 100644 index 266b1fc0..00000000 --- a/src/scheme/ao_scheme_lex.c +++ /dev/null @@ -1,16 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin deleted file mode 100644 index a34affce..00000000 --- a/src/scheme/ao_scheme_make_builtin +++ /dev/null @@ -1,318 +0,0 @@ -#!/usr/bin/nickle - -typedef struct { - string name; - string feature; -} lisp_name_t; - -typedef struct { - string feature; - string type; - string c_name; - lisp_name_t[*] lisp_names; -} builtin_t; - -string[string] type_map = { - "lambda" => "LAMBDA", - "nlambda" => "NLAMBDA", - "macro" => "MACRO", - "f_lambda" => "F_LAMBDA", - "atom" => "atom", - "feature" => "feature", -}; - -lisp_name_t -make_one_lisp(string token) -{ - string[*] bits = String::split(token, "@"); - string name = bits[0]; - string feature = "all"; - - if (dim(bits) > 1) - feature = bits[1]; - return (lisp_name_t) {.name = name, .feature = feature }; -} - -lisp_name_t[*] -make_lisp(string[*] tokens) -{ - lisp_name_t[...] lisp = {}; - - if (dim(tokens) < 4) - return (lisp_name_t[1]) { make_one_lisp(tokens[dim(tokens) - 1]) }; - return (lisp_name_t[dim(tokens)-3]) { [i] = make_one_lisp(tokens[i+3]) }; -} - -builtin_t -read_builtin(file f) { - string line = File::fgets(f); - string[*] tokens = String::wordsplit(line, " \t"); - - return (builtin_t) { - .feature = dim(tokens) > 0 ? tokens[0] : "#", - .type = dim(tokens) > 1 ? type_map[tokens[1]] : "#", - .c_name = dim(tokens) > 2 ? tokens[2] : "#", - .lisp_names = make_lisp(tokens), - }; -} - -builtin_t[*] -read_builtins(file f) { - builtin_t[...] builtins = {}; - - while (!File::end(f)) { - builtin_t b = read_builtin(f); - - if (b.type[0] != '#') - builtins[dim(builtins)] = b; - } - return builtins; -} - -void -dump_ifdef(builtin_t builtin) -{ - if (builtin.feature != "all") - printf("#ifdef AO_SCHEME_FEATURE_%s\n", builtin.feature); -} - -void -dump_endif(builtin_t builtin) -{ - if (builtin.feature != "all") - printf("#endif /* AO_SCHEME_FEATURE_%s */\n", builtin.feature); -} - -bool is_atom(builtin_t b) = b.type == "atom"; - -bool is_func(builtin_t b) = b.type != "atom" && b.type != "feature"; - -bool is_feature(builtin_t b) = b.type == "feature"; - -void -dump_ids(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); - printf("#undef AO_SCHEME_BUILTIN_ID\n"); - printf("enum ao_scheme_builtin_id {\n"); - for (int i = 0; i < dim(builtins); i++) - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("\tbuiltin_%s,\n", builtins[i].c_name); - dump_endif(builtins[i]); - } - printf("\t_builtin_last\n"); - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_ID */\n"); -} - -void -dump_casename(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_CASENAME\n"); - printf("#undef AO_SCHEME_BUILTIN_CASENAME\n"); - printf("static char *ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {\n"); - printf("\tswitch(b) {\n"); - for (int i = 0; i < dim(builtins); i++) - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", - builtins[i].c_name, builtins[i].lisp_names[0].name); - dump_endif(builtins[i]); - } - printf("\tdefault: return (char *) \"???\";\n"); - printf("\t}\n"); - printf("}\n"); - printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); -} - -void -cify_lisp(string l) { - for (int j = 0; j < String::length(l); j++) { - int c= l[j]; - if (Ctype::isalnum(c) || c == '_') - printf("%c", c); - else - printf("%02x", c); - } -} - -void -dump_arrayname(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_ARRAYNAME\n"); - printf("#undef AO_SCHEME_BUILTIN_ARRAYNAME\n"); - printf("static const ao_poly builtin_names[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("\t[builtin_%s] = _ao_scheme_atom_", - builtins[i].c_name); - cify_lisp(builtins[i].lisp_names[0].name); - printf(",\n"); - dump_endif(builtins[i]); - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_ARRAYNAME */\n"); -} - -void -dump_funcs(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_FUNCS\n"); - printf("#undef AO_SCHEME_BUILTIN_FUNCS\n"); - printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("\t[builtin_%s] = ao_scheme_do_%s,\n", - builtins[i].c_name, - builtins[i].c_name); - dump_endif(builtins[i]); - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n"); -} - -void -dump_decls(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); - printf("#undef AO_SCHEME_BUILTIN_DECLS\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("ao_poly\n"); - printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", - builtins[i].c_name); - dump_endif(builtins[i]); - } - } - printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n"); -} - -void -dump_consts(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_CONSTS\n"); - printf("#undef AO_SCHEME_BUILTIN_CONSTS\n"); - printf("struct builtin_func funcs[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - string feature = builtins[i].feature; - if (builtins[i].lisp_names[j].feature != "all") - feature = builtins[i].lisp_names[j].feature; - printf ("\t{ .feature = \"%s\", .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", - feature, - builtins[i].lisp_names[j].name, - builtins[i].type, - builtins[i].c_name); - } - dump_endif(builtins[i]); - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n"); -} - -void -dump_atoms(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); - printf("#undef AO_SCHEME_BUILTIN_ATOMS\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_feature(builtins[i])) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf("#define _ao_scheme_atom_"); - cify_lisp(builtins[i].lisp_names[j].name); - printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j].name); - } - } - } - printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); -} - -void -dump_atom_names(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_ATOM_NAMES\n"); - printf("#undef AO_SCHEME_BUILTIN_ATOM_NAMES\n"); - printf("static struct builtin_atom atoms[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_atom(builtins[i])) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - string feature = builtins[i].feature; - if (builtins[i].lisp_names[j].feature != "all") - feature = builtins[i].lisp_names[j].feature; - printf("\t{ .feature = \"%s\", .name = \"%s\" },\n", - feature, - builtins[i].lisp_names[j].name); - } - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_ATOM_NAMES */\n"); -} - -void -dump_syntax_atoms(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_SYNTAX_ATOMS\n"); - printf("#undef AO_SCHEME_BUILTIN_SYNTAX_ATOMS\n"); - printf("static const char *syntax_atoms[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_atom(builtins[i])) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf("\t\"%s\",\n", builtins[i].lisp_names[j].name); - } - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_SYNTAX_ATOMS */\n"); -} - -bool -has_feature(string[*] features, string feature) -{ - for (int i = 0; i < dim(features); i++) - if (features[i] == feature) - return true; - return false; -} - -void -dump_features(builtin_t[*] builtins) { - string[...] features = {}; - printf("#ifdef AO_SCHEME_BUILTIN_FEATURES\n"); - for (int i = 0; i < dim(builtins); i++) { - if (builtins[i].feature != "all") { - string feature = builtins[i].feature; - if (!has_feature(features, feature)) { - features[dim(features)] = feature; - printf("#ifndef AO_SCHEME_NO_FEATURE_%s\n", feature); - printf("#define AO_SCHEME_FEATURE_%s\n", feature); - printf("#endif /* AO_SCHEME_NO_FEATURE_%s */\n", feature); - } - } - } - printf("#endif /* AO_SCHEME_BUILTIN_FEATURES */\n"); -} - -void main() { - if (dim(argv) < 2) { - File::fprintf(stderr, "usage: %s \n", argv[0]); - exit(1); - } - twixt(file f = File::open(argv[1], "r"); File::close(f)) { - builtin_t[*] builtins = read_builtins(f); - - printf("/* %d builtins */\n", dim(builtins)); - dump_ids(builtins); - dump_casename(builtins); - dump_arrayname(builtins); - dump_funcs(builtins); - dump_decls(builtins); - dump_consts(builtins); - dump_atoms(builtins); - dump_atom_names(builtins); - dump_syntax_atoms(builtins); - dump_features(builtins); - } -} - -main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c deleted file mode 100644 index 8561bf0b..00000000 --- a/src/scheme/ao_scheme_make_const.c +++ /dev/null @@ -1,543 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" -#include -#include -#include -#include -#include - -static struct ao_scheme_builtin * -ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { - struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin)); - - b->type = AO_SCHEME_BUILTIN; - b->func = func; - b->args = args; - return b; -} - -struct builtin_func { - const char *feature; - const char *name; - int args; - enum ao_scheme_builtin_id func; -}; - -struct builtin_atom { - const char *feature; - const char *name; -}; - -#define AO_SCHEME_BUILTIN_CONSTS -#define AO_SCHEME_BUILTIN_ATOM_NAMES - -#include "ao_scheme_builtin.h" - -#define N_FUNC (sizeof funcs / sizeof funcs[0]) - -#define N_ATOM (sizeof atoms / sizeof atoms[0]) - -struct ao_scheme_frame *globals; - -static int -is_atom(int offset) -{ - struct ao_scheme_atom *a; - - for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) - if (((uint8_t *) a->name - ao_scheme_const) == offset) - return strlen(a->name); - return 0; -} - -#define AO_FEC_CRC_INIT 0xffff - -static inline uint16_t -ao_fec_crc_byte(uint8_t byte, uint16_t crc) -{ - uint8_t bit; - - for (bit = 0; bit < 8; bit++) { - if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) - crc = (crc << 1) ^ 0x8005; - else - crc = (crc << 1); - byte <<= 1; - } - return crc; -} - -static uint16_t -ao_fec_crc(const uint8_t *bytes, uint8_t len) -{ - uint16_t crc = AO_FEC_CRC_INIT; - - while (len--) - crc = ao_fec_crc_byte(*bytes++, crc); - return crc; -} - -struct ao_scheme_macro_stack { - struct ao_scheme_macro_stack *next; - ao_poly p; -}; - -struct ao_scheme_macro_stack *macro_stack; - -static int -ao_scheme_macro_push(ao_poly p) -{ - struct ao_scheme_macro_stack *m = macro_stack; - - while (m) { - if (m->p == p) - return 1; - m = m->next; - } - m = malloc (sizeof (struct ao_scheme_macro_stack)); - m->p = p; - m->next = macro_stack; - macro_stack = m; - return 0; -} - -static void -ao_scheme_macro_pop(void) -{ - struct ao_scheme_macro_stack *m = macro_stack; - - macro_stack = m->next; - free(m); -} - -#define DBG_MACRO 0 -#if DBG_MACRO -static int macro_scan_depth; - -static void indent(void) -{ - int i; - for (i = 0; i < macro_scan_depth; i++) - printf(" "); -} -#define MACRO_DEBUG(a) a -#else -#define MACRO_DEBUG(a) -#endif - -ao_poly -ao_has_macro(ao_poly p); - -static ao_poly -ao_macro_test_get(ao_poly atom) -{ - ao_poly *ref = ao_scheme_atom_ref(atom, NULL); - if (ref) - return *ref; - return AO_SCHEME_NIL; -} - -static ao_poly -ao_is_macro(ao_poly p) -{ - struct ao_scheme_builtin *builtin; - struct ao_scheme_lambda *lambda; - ao_poly ret; - - MACRO_DEBUG(indent(); ao_scheme_printf ("is macro %v\n", p); ++macro_scan_depth); - switch (ao_scheme_poly_type(p)) { - case AO_SCHEME_ATOM: - if (ao_scheme_macro_push(p)) - ret = AO_SCHEME_NIL; - else { - if (ao_is_macro(ao_macro_test_get(p))) - ret = p; - else - ret = AO_SCHEME_NIL; - ao_scheme_macro_pop(); - } - break; - case AO_SCHEME_CONS: - ret = ao_has_macro(p); - break; - case AO_SCHEME_BUILTIN: - builtin = ao_scheme_poly_builtin(p); - if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO) - ret = p; - else - ret = 0; - break; - - case AO_SCHEME_LAMBDA: - lambda = ao_scheme_poly_lambda(p); - if (lambda->args == AO_SCHEME_FUNC_MACRO) - ret = p; - else - ret = ao_has_macro(lambda->code); - break; - default: - ret = AO_SCHEME_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); ao_scheme_printf ("... %v\n", ret);); - return ret; -} - -ao_poly -ao_has_macro(ao_poly p) -{ - struct ao_scheme_cons *cons; - struct ao_scheme_lambda *lambda; - ao_poly m; - ao_poly list; - - if (p == AO_SCHEME_NIL) - return AO_SCHEME_NIL; - - MACRO_DEBUG(indent(); ao_scheme_printf("has macro %v\n", p); ++macro_scan_depth); - switch (ao_scheme_poly_type(p)) { - case AO_SCHEME_LAMBDA: - lambda = ao_scheme_poly_lambda(p); - p = ao_has_macro(ao_scheme_poly_cons(lambda->code)->cdr); - break; - case AO_SCHEME_CONS: - cons = ao_scheme_poly_cons(p); - if ((p = ao_is_macro(cons->car))) - break; - - list = cons->cdr; - p = AO_SCHEME_NIL; - while (ao_scheme_is_pair(list)) { - cons = ao_scheme_poly_cons(list); - m = ao_has_macro(cons->car); - if (m) { - p = m; - break; - } - list = cons->cdr; - } - break; - - default: - p = AO_SCHEME_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); ao_scheme_printf("... %v\n", p)); - return p; -} - -static struct ao_scheme_builtin * -ao_scheme_get_builtin(ao_poly p) -{ - if (ao_scheme_poly_type(p) == AO_SCHEME_BUILTIN) - return ao_scheme_poly_builtin(p); - return NULL; -} - -struct seen_builtin { - struct seen_builtin *next; - struct ao_scheme_builtin *builtin; -}; - -static struct seen_builtin *seen_builtins; - -static int -ao_scheme_seen_builtin(struct ao_scheme_builtin *b) -{ - struct seen_builtin *s; - - for (s = seen_builtins; s; s = s->next) - if (s->builtin == b) - return 1; - s = malloc (sizeof (struct seen_builtin)); - s->builtin = b; - s->next = seen_builtins; - seen_builtins = s; - return 0; -} - -static int -ao_scheme_read_eval_abort(FILE *read_file) -{ - ao_poly in; - - for(;;) { - in = ao_scheme_read(read_file); - if (in == _ao_scheme_atom_eof) - break; - (void) ao_scheme_eval(in); - if (ao_scheme_exception) { - ao_scheme_fprintf(stderr, "make_const failed on %v\n", in); - return 0; - } - } - return 1; -} - -static FILE *in; -static FILE *out; - -struct feature { - struct feature *next; - char name[]; -}; - -static struct feature *enable; -static struct feature *disable; - -static void -ao_scheme_add_feature(struct feature **list, char *name) -{ - struct feature *feature = malloc (sizeof (struct feature) + strlen(name) + 1); - strcpy(feature->name, name); - feature->next = *list; - *list = feature; -} - -static bool -_ao_scheme_has_feature(struct feature *list, const char *name, bool skip_undef) -{ - if (skip_undef && !strcmp(name, "UNDEF")) - return false; - - while (list) { - if (!strcmp(list->name, name)) - return true; - list = list->next; - } - return false; -} - -static bool -ao_scheme_has_undef(struct feature *list) -{ - return _ao_scheme_has_feature(list, "UNDEF", false); -} - -static bool -ao_scheme_has_feature(struct feature *list, const char *name) -{ - return _ao_scheme_has_feature(list, name, true); -} - -static void -ao_scheme_add_features(struct feature **list, const char *names) -{ - char *saveptr = NULL; - char *name; - char *copy = strdup(names); - char *save = copy; - - while ((name = strtok_r(copy, ",", &saveptr)) != NULL) { - copy = NULL; - if (!ao_scheme_has_feature(*list, name)) - ao_scheme_add_feature(list, name); - } - free(save); -} - -int -ao_scheme_getc(void) -{ - return getc(in); -} - -static const struct option options[] = { - { .name = "out", .has_arg = 1, .val = 'o' }, - { .name = "disable", .has_arg = 1, .val = 'd' }, - { .name = "enable", .has_arg = 1, .val = 'e' }, - { 0, 0, 0, 0 } -}; - -static void usage(char *program) -{ - fprintf(stderr, "usage: %s [--out=] [--disable={feature,...}] [--enable={feature,...} [input]\n", program); - exit(1); -} - -int -main(int argc, char **argv) -{ - int f, o, an; - ao_poly val; - struct ao_scheme_atom *a; - struct ao_scheme_builtin *b; - struct feature *d; - int in_atom = 0; - char *out_name = NULL; - int c; - enum ao_scheme_builtin_id prev_func; - enum ao_scheme_builtin_id target_func; - enum ao_scheme_builtin_id func_map[_builtin_last]; - - in = stdin; - out = stdout; - - while ((c = getopt_long(argc, argv, "o:d:e:", options, NULL)) != -1) { - switch (c) { - case 'o': - out_name = optarg; - break; - case 'd': - ao_scheme_add_features(&disable, optarg); - break; - case 'e': - ao_scheme_add_features(&enable, optarg); - break; - default: - usage(argv[0]); - break; - } - } - - ao_scheme_frame_init(); - - /* Boolean values #f and #t */ - ao_scheme_bool_get(0); - ao_scheme_bool_get(1); - - prev_func = _builtin_last; - target_func = 0; - b = NULL; - for (f = 0; f < (int) N_FUNC; f++) { - if (ao_scheme_has_feature(enable, funcs[f].feature) || !ao_scheme_has_feature(disable, funcs[f].feature)) { - if (funcs[f].func != prev_func) { - prev_func = funcs[f].func; - b = ao_scheme_make_builtin(prev_func, funcs[f].args); - - /* Target may have only a subset of - * the enum values; record what those - * values will be here. This obviously - * depends on the functions in the - * array being in the same order as - * the enumeration; which - * ao_scheme_make_builtin ensures. - */ - func_map[prev_func] = target_func++; - } - a = ao_scheme_atom_intern((char *) funcs[f].name); - ao_scheme_atom_def(ao_scheme_atom_poly(a), - ao_scheme_builtin_poly(b)); - } - } - - /* atoms */ - for (an = 0; an < (int) N_ATOM; an++) { - if (ao_scheme_has_feature(enable, atoms[an].feature) || !ao_scheme_has_feature(disable, atoms[an].feature)) - a = ao_scheme_atom_intern((char *) atoms[an].name); - } - - while (argv[optind]) { - in = fopen(argv[optind], "r"); - if (!in) { - perror(argv[optind]); - exit(1); - } - if (!ao_scheme_read_eval_abort(in)) { - fprintf(stderr, "eval failed\n"); - exit(1); - } - fclose(in); - optind++; - } - - if (!ao_scheme_has_undef(enable) && ao_scheme_has_undef(disable)) { - struct ao_scheme_cons cons; - - cons.car = _ao_scheme_atom_undef; - cons.cdr = AO_SCHEME_NIL; - ao_scheme_do_undef(&cons); - } - - /* Reduce to referenced values */ - ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - - for (f = 0; f < ao_scheme_frame_global->num; f++) { - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); - - val = ao_has_macro(vals->vals[f].val); - if (val != AO_SCHEME_NIL) { - fprintf(stderr, "error: function %s contains unresolved macro: ", - ao_scheme_poly_atom(vals->vals[f].atom)->name); - ao_scheme_poly_write(stderr, val, true); - fprintf(stderr, "\n"); - exit(1); - } - - /* Remap builtin enum values to match target set */ - b = ao_scheme_get_builtin(vals->vals[f].val); - if (b != NULL) { - if (!ao_scheme_seen_builtin(b)) - b->func = func_map[b->func]; - } - } - - if (out_name) { - out = fopen(out_name, "w"); - if (!out) { - perror(out_name); - exit(1); - } - } - - fprintf(out, "/* Generated file, do not edit */\n\n"); - - for (d = disable; d; d = d->next) - fprintf(out, "#undef AO_SCHEME_FEATURE_%s\n", d->name); - - fprintf(out, "#define AO_SCHEME_POOL_CONST %d\n", ao_scheme_top); - fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n"); - fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms)); - fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global)); - fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top)); - - fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false)); - fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true)); - - for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) { - const char *n = a->name; - char ch; - fprintf(out, "#define _ao_scheme_atom_"); - while ((ch = *n++)) { - if (isalnum(ch)) - fprintf(out, "%c", ch); - else - fprintf(out, "%02x", ch); - } - fprintf(out, " 0x%04x\n", ao_scheme_atom_poly(a)); - } - fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); - fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); - for (o = 0; o < ao_scheme_top; o++) { - uint8_t ch; - if ((o & 0xf) == 0) - fprintf(out, "\n\t"); - else - fprintf(out, " "); - ch = ao_scheme_const[o]; - if (!in_atom) - in_atom = is_atom(o); - if (in_atom) { - fprintf(out, " '%c',", ch); - in_atom--; - } else { - fprintf(out, "0x%02x,", ch); - } - } - fprintf(out, "\n};\n"); - fprintf(out, "#endif /* AO_SCHEME_CONST_BITS */\n"); - exit(0); -} diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c deleted file mode 100644 index 94cbdfc1..00000000 --- a/src/scheme/ao_scheme_mem.c +++ /dev/null @@ -1,1117 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#define AO_SCHEME_CONST_BITS - -#include "ao_scheme.h" -#include -#include - -#ifdef AO_SCHEME_MAKE_CONST - -/* - * When building the constant table, it is the - * pool for allocations. - */ - -#include -uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); -#define ao_scheme_pool ao_scheme_const -#undef AO_SCHEME_POOL -#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST - -#else - -uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); - -#endif - -#ifndef DBG_MEM_STATS -#define DBG_MEM_STATS DBG_MEM -#endif - -#define DBG_MEM_STACK 0 -#if DBG_MEM_STACK -char *mem_collect_stack; -int64_t mem_collect_max_depth; - -static void -ao_scheme_check_stack(void) -{ - char x; - int64_t depth; - - depth = mem_collect_stack - &x; - if (depth > mem_collect_max_depth) - mem_collect_max_depth = depth; -} - -static void -_ao_scheme_reset_stack(char *x) -{ - mem_collect_stack = x; -// mem_collect_max_depth = 0; -} -#define ao_scheme_declare_stack char x; -#define ao_scheme_reset_stack() _ao_scheme_reset_stack(&x) -#else -#define ao_scheme_check_stack() -#define ao_scheme_declare_stack -#define ao_scheme_reset_stack() -#endif - -#if DBG_MEM -#define DBG_MEM_RECORD 1 -#endif - -#if DBG_MEM -int dbg_move_depth; -int dbg_mem = DBG_MEM_START; -int dbg_validate = 0; -#endif - -#if DBG_MEM_RECORD -struct ao_scheme_record { - struct ao_scheme_record *next; - const struct ao_scheme_type *type; - void *addr; - int size; -}; - -static struct ao_scheme_record *record_head, **record_tail; - -static void -ao_scheme_record_free(struct ao_scheme_record *record) -{ - while (record) { - struct ao_scheme_record *next = record->next; - free(record); - record = next; - } -} - -static void -ao_scheme_record_reset(void) -{ - ao_scheme_record_free(record_head); - record_head = NULL; - record_tail = &record_head; -} - -static void -ao_scheme_record(const struct ao_scheme_type *type, - void *addr, - int size) -{ - struct ao_scheme_record *r = malloc(sizeof (struct ao_scheme_record)); - - r->next = NULL; - r->type = type; - r->addr = addr; - r->size = size; - *record_tail = r; - record_tail = &r->next; -} - -static struct ao_scheme_record * -ao_scheme_record_save(void) -{ - struct ao_scheme_record *r = record_head; - - record_head = NULL; - record_tail = &record_head; - return r; -} - -static void -ao_scheme_record_compare(const char *where, - struct ao_scheme_record *a, - struct ao_scheme_record *b) -{ - while (a && b) { - if (a->type != b->type || a->size != b->size) { - printf("%s record difers %d %s %d -> %d %s %d\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_scheme_abort(); - } - a = a->next; - b = b->next; - } - if (a) { - printf("%s record differs %d %s %d -> NULL\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size); - ao_scheme_abort(); - } - if (b) { - printf("%s record differs NULL -> %d %s %d\n", - where, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_scheme_abort(); - } -} - -#else -#define ao_scheme_record_reset() -#define ao_scheme_record(t,a,s) -#endif - -uint8_t ao_scheme_exception; - -struct ao_scheme_root { - const struct ao_scheme_type *type; - void **addr; -}; - -#define AO_SCHEME_NUM_STASH 6 -static ao_poly stash_poly[AO_SCHEME_NUM_STASH]; -static int stash_poly_ptr; - -static const struct ao_scheme_root ao_scheme_root[] = { - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[0] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[1] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[2] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[3] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[4] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[5] - }, - { - .type = &ao_scheme_frame_type, - .addr = (void **) &ao_scheme_frame_global, - }, - { - .type = &ao_scheme_frame_type, - .addr = (void **) &ao_scheme_frame_current, - }, - { - .type = &ao_scheme_stack_type, - .addr = (void **) &ao_scheme_stack, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_scheme_v, - }, - { - .type = &ao_scheme_cons_type, - .addr = (void **) &ao_scheme_read_cons, - }, - { - .type = &ao_scheme_cons_type, - .addr = (void **) &ao_scheme_read_cons_tail, - }, - { - .type = &ao_scheme_cons_type, - .addr = (void **) &ao_scheme_read_stack, - }, -#ifdef AO_SCHEME_FEATURE_PORT - { - .type = NULL, - .addr = (void **) (void *) &ao_scheme_stdin, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_scheme_stdout, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_scheme_stderr, - }, -#endif -#ifdef AO_SCHEME_MAKE_CONST - { - .type = &ao_scheme_bool_type, - .addr = (void **) &ao_scheme_false, - }, - { - .type = &ao_scheme_bool_type, - .addr = (void **) &ao_scheme_true, - }, -#endif -}; - -#define AO_SCHEME_ROOT (sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) - -static const void ** const ao_scheme_cache[] = { - (const void **) &ao_scheme_cons_free_list, - (const void **) &ao_scheme_stack_free_list, - (const void **) &ao_scheme_frame_free_list[0], - (const void **) &ao_scheme_frame_free_list[1], - (const void **) &ao_scheme_frame_free_list[2], - (const void **) &ao_scheme_frame_free_list[3], - (const void **) &ao_scheme_frame_free_list[4], - (const void **) &ao_scheme_frame_free_list[5], -}; - -#if AO_SCHEME_FRAME_FREE != 6 -#error Unexpected AO_SCHEME_FRAME_FREE value -#endif - -#define AO_SCHEME_CACHE (sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) - -#define AO_SCHEME_BUSY_SIZE ((AO_SCHEME_POOL + 31) / 32) - -static int ao_scheme_printing, ao_scheme_print_cleared; -#if DBG_MEM -static int ao_scheme_collecting; -#endif -static uint8_t ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; -static uint8_t ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; -static uint8_t ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; -static uint8_t ao_scheme_cons_noted; - -uint16_t ao_scheme_top; - -struct ao_scheme_chunk { - uint16_t old_offset; - union { - uint16_t size; - uint16_t new_offset; - }; -}; - -#define AO_SCHEME_NCHUNK (AO_SCHEME_POOL / 64) - -static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; - -/* Offset of an address within the pool. */ -static inline uint16_t pool_offset(void *addr) { -#if DBG_MEM - if (!ao_scheme_is_pool_addr(addr)) - ao_scheme_abort(); -#endif - return ((uint8_t *) addr) - ao_scheme_pool; -} - -static inline void mark(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - ao_scheme_check_stack(); - tag[byte] |= (1 << bit); -} - -static inline void clear(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - tag[byte] &= ~(1 << bit); -} - -static inline int busy(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - return (tag[byte] >> bit) & 1; -} - -static inline int min(int a, int b) { return a < b ? a : b; } -static inline int max(int a, int b) { return a > b ? a : b; } - -static inline int limit(int offset) { - return min(AO_SCHEME_POOL, max(offset, 0)); -} - -static inline void -note_cons(uint16_t offset) -{ - MDBG_MOVE("note cons %d\n", offset); - ao_scheme_cons_noted = 1; - mark(ao_scheme_cons_note, offset); -} - -static uint16_t chunk_low, chunk_high; -static uint16_t chunk_first, chunk_last; - -static int -find_chunk(uint16_t offset) -{ - int l, r; - /* Binary search for the location */ - l = chunk_first; - r = chunk_last - 1; - while (l <= r) { - int m = (l + r) >> 1; - if (ao_scheme_chunk[m].old_offset < offset) - l = m + 1; - else - r = m - 1; - } - return l; -} - -static void -note_chunk(uint16_t offset, uint16_t size) -{ - int l; - int end; - - if (offset < chunk_low || chunk_high <= offset) - return; - - l = find_chunk(offset); - - /* - * The correct location is always in 'l', with r = l-1 being - * the entry before the right one - */ - -#if DBG_MEM - /* Off the right side */ - if (l >= AO_SCHEME_NCHUNK) - ao_scheme_abort(); - - /* Off the left side */ - if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) - ao_scheme_abort(); - - if (l < chunk_last && ao_scheme_chunk[l].old_offset == offset) - ao_scheme_abort(); -#endif - - /* Shuffle existing entries right */ - end = min(AO_SCHEME_NCHUNK, chunk_last + 1); - - memmove(&ao_scheme_chunk[l+1], - &ao_scheme_chunk[l], - (end - (l+1)) * sizeof (struct ao_scheme_chunk)); - - /* Add new entry */ - ao_scheme_chunk[l].old_offset = offset; - ao_scheme_chunk[l].size = size; - - /* Increment the number of elements up to the size of the array */ - if (chunk_last < AO_SCHEME_NCHUNK) - chunk_last++; - - /* Set the top address if the array is full */ - if (chunk_last == AO_SCHEME_NCHUNK) - chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + - ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; -} - -static void -reset_chunks(void) -{ - chunk_high = ao_scheme_top; - chunk_last = 0; - chunk_first = 0; -} - -/* - * Walk all referenced objects calling functions on each one - */ - -static void -walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr), - int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) -{ - int i; - - ao_scheme_record_reset(); - memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); - memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); - ao_scheme_cons_noted = 0; - for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { - if (ao_scheme_root[i].type) { - void **a = ao_scheme_root[i].addr, *v; - if (a && (v = *a)) { - MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); - visit_addr(ao_scheme_root[i].type, a); - } - } else { - ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; - if (a && (p = *a)) { - MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); - visit_poly(a, 0); - } - } - } - while (ao_scheme_cons_noted) { - memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); - memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); - ao_scheme_cons_noted = 0; - for (i = 0; i < AO_SCHEME_POOL; i += 4) { - if (busy(ao_scheme_cons_last, i)) { - void *v = ao_scheme_pool + i; - MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); - visit_addr(&ao_scheme_cons_type, &v); - } - } - } -} - -#if MDBG_DUMP -static void -dump_busy(void) -{ - int i; - printf("busy:"); - for (i = 0; i < ao_scheme_top; i += 4) { - if ((i & 0xff) == 0) { - printf("\n\t"); - } - else if ((i & 0x1f) == 0) - printf(" "); - if (busy(ao_scheme_busy, i)) - printf("*"); - else - printf("-"); - } - printf ("\n"); -} -#define DUMP_BUSY() dump_busy() -#else -#define DUMP_BUSY() -#endif - -#if MDBG_DUMP -static void -dump_atoms(int show_marked) -{ - struct ao_scheme_atom *atom; - - printf("atoms {\n"); - for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { - printf("\t%d: %s", MDBG_OFFSET(atom), atom->name); - if (show_marked) - printf(" %s", ao_scheme_marked(atom) ? "referenced" : "unreferenced"); - printf("\n"); - } - printf("}\n"); - -} -#define DUMP_ATOMS(a) dump_atoms(a) -#else -#define DUMP_ATOMS(a) -#endif - -static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { - [AO_SCHEME_CONS] = &ao_scheme_cons_type, - [AO_SCHEME_INT] = NULL, -#ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, -#endif - [AO_SCHEME_OTHER] = (void *) 0x1, - [AO_SCHEME_ATOM] = &ao_scheme_atom_type, - [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, - [AO_SCHEME_FRAME] = &ao_scheme_frame_type, - [AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, - [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, - [AO_SCHEME_STACK] = &ao_scheme_stack_type, - [AO_SCHEME_BOOL] = &ao_scheme_bool_type, - [AO_SCHEME_STRING] = &ao_scheme_string_type, -#ifdef AO_SCHEME_FEATURE_FLOAT - [AO_SCHEME_FLOAT] = &ao_scheme_float_type, -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR - [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, -#endif -#ifdef AO_SCHEME_FEATURE_PORT - [AO_SCHEME_PORT] = &ao_scheme_port_type, -#endif -}; - -static int -ao_scheme_mark(const struct ao_scheme_type *type, void *addr); - -static int -ao_scheme_move(const struct ao_scheme_type *type, void **ref); - -static int -ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) -{ - return ao_scheme_mark(type, *ref); -} - -static int -ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) -{ - return ao_scheme_poly_mark(*p, do_note_cons); -} - -#if DBG_MEM_STATS -uint64_t ao_scheme_collects[2]; -uint64_t ao_scheme_freed[2]; -uint64_t ao_scheme_loops[2]; -#endif - -int ao_scheme_last_top; -int ao_scheme_collect_counts; - -int -ao_scheme_collect(uint8_t style) -{ - ao_scheme_declare_stack - int i; - int top; -#if DBG_MEM_STATS - int loops = 0; -#endif -#if DBG_MEM_RECORD - struct ao_scheme_record *mark_record = NULL, *move_record = NULL; -#endif - MDBG_MOVE("collect %lu\n", ao_scheme_collects[style]); - - MDBG_DO(ao_scheme_frame_write(stdout, ao_scheme_frame_poly(ao_scheme_frame_global), true)); - MDBG_DO(++ao_scheme_collecting); - - ao_scheme_reset_stack(); - - /* The first time through, we're doing a full collect */ - if (ao_scheme_last_top == 0) - style = AO_SCHEME_COLLECT_FULL; - - /* One in a while, just do a full collect */ - - if (ao_scheme_collect_counts >= 128) - style = AO_SCHEME_COLLECT_FULL; - - if (style == AO_SCHEME_COLLECT_FULL) - ao_scheme_collect_counts = 0; - - /* Clear references to all caches */ - for (i = 0; i < (int) AO_SCHEME_CACHE; i++) - *ao_scheme_cache[i] = NULL; - if (style == AO_SCHEME_COLLECT_FULL) { - chunk_low = top = 0; - } else { - chunk_low = top = ao_scheme_last_top; - } - for (;;) { - MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); - /* Find the sizes of the first chunk of objects to move */ - reset_chunks(); - walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); - -#ifdef AO_SCHEME_FEATURE_PORT - ao_scheme_port_check_references(); -#endif - ao_scheme_atom_check_references(); - -#if DBG_MEM_RECORD - ao_scheme_record_free(mark_record); - mark_record = ao_scheme_record_save(); - if (mark_record && move_record) - ao_scheme_record_compare("mark", move_record, mark_record); -#endif - - DUMP_ATOMS(1); - DUMP_BUSY(); - - /* Find the first moving object */ - for (i = 0; i < chunk_last; i++) { - uint16_t size = ao_scheme_chunk[i].size; -#if DBG_MEM - if (!size) - ao_scheme_abort(); -#endif - - if (ao_scheme_chunk[i].old_offset > top) - break; - - MDBG_MOVE("chunk %d %d not moving\n", - ao_scheme_chunk[i].old_offset, - ao_scheme_chunk[i].size); -#if DBG_MEM - if (ao_scheme_chunk[i].old_offset != top) - ao_scheme_abort(); -#endif - top += size; - } - - /* Short-circuit the rest of the loop when all of the - * found objects aren't moving. This isn't strictly - * necessary as the rest of the loop is structured to - * work in this case, but GCC 7.2.0 with optimization - * greater than 2 generates incorrect code for this... - */ - if (i == AO_SCHEME_NCHUNK) { - chunk_low = chunk_high; -#if DBG_MEM_STATS - loops++; -#endif - continue; - } - - /* - * Limit amount of chunk array used in mapping moves - * to the active region - */ - chunk_first = i; - chunk_low = ao_scheme_chunk[i].old_offset; - - /* Copy all of the objects */ - for (; i < chunk_last; i++) { - uint16_t size = ao_scheme_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_scheme_abort(); -#endif - - MDBG_MOVE("chunk %d %d -> %d\n", - ao_scheme_chunk[i].old_offset, - size, - top); - ao_scheme_chunk[i].new_offset = top; - - memmove(&ao_scheme_pool[top], - &ao_scheme_pool[ao_scheme_chunk[i].old_offset], - size); - - top += size; - } - - if (chunk_first < chunk_last) { - /* Relocate all references to the objects */ - walk(ao_scheme_move, ao_scheme_poly_move); - ao_scheme_atom_move(); -#ifdef AO_SCHEME_FEATURE_PORT - /* the set of open ports gets relocated but not marked, so - * just deal with it separately - */ - ao_scheme_poly_move(&ao_scheme_open_ports, 0); -#endif - -#if DBG_MEM_RECORD - ao_scheme_record_free(move_record); - move_record = ao_scheme_record_save(); - if (mark_record && move_record) - ao_scheme_record_compare("move", mark_record, move_record); -#endif - DUMP_ATOMS(0); - } - -#if DBG_MEM_STATS - loops++; -#endif - /* If we ran into the end of the heap, then - * there's no need to keep walking - */ - if (chunk_last != AO_SCHEME_NCHUNK) - break; - - /* Next loop starts right above this loop */ - chunk_low = chunk_high; - } - -#if DBG_MEM_STATS - /* Collect stats */ - ++ao_scheme_collects[style]; - ao_scheme_freed[style] += ao_scheme_top - top; - ao_scheme_loops[style] += loops; -#endif - - ao_scheme_top = top; - if (style == AO_SCHEME_COLLECT_FULL) - ao_scheme_last_top = top; - - MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); - walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); - -#if DBG_MEM_STACK - fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth); -#endif - MDBG_DO(--ao_scheme_collecting); - return AO_SCHEME_POOL - ao_scheme_top; -} - -#if DBG_FREE_CONS -void -ao_scheme_cons_check(struct ao_scheme_cons *cons) -{ - ao_poly cdr; - int offset; - - chunk_low = 0; - reset_chunks(); - walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); - while (cons) { - if (!ao_scheme_is_pool_addr(cons)) - break; - offset = pool_offset(cons); - if (busy(ao_scheme_busy, offset)) { - ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); - abort(); - } - cdr = cons->cdr; - if (!ao_scheme_is_pair(cdr)) - break; - cons = ao_scheme_poly_cons(cdr); - } -} -#endif - -/* - * Mark interfaces for objects - */ - - -/* - * Note a reference to memory and collect information about a few - * object sizes at a time - */ - -int -ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) -{ - int offset; - if (!ao_scheme_is_pool_addr(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_scheme_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_scheme_busy, offset); - note_chunk(offset, ao_scheme_size(type, addr)); - return 0; -} - -/* - * Mark an object and all that it refereces - */ -static int -ao_scheme_mark(const struct ao_scheme_type *type, void *addr) -{ - int ret; - MDBG_MOVE("mark offset %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_scheme_mark_memory(type, addr); - if (!ret) { - MDBG_MOVE("mark recurse\n"); - type->mark(addr); - } - MDBG_MOVE_OUT(); - return ret; -} - -/* - * Mark an object, unless it is a cons cell and - * do_note_cons is set. In that case, just - * set a bit in the cons note array; those - * will be marked in a separate pass to avoid - * deep recursion in the collector - */ -int -ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) -{ - uint8_t type; - void *addr; - int ret; - - type = ao_scheme_poly_base_type(p); - - if (type == AO_SCHEME_INT) - return 1; - - addr = ao_scheme_ref(p); - if (!ao_scheme_is_pool_addr(addr)) - return 1; - - if (type == AO_SCHEME_CONS && do_note_cons) { - note_cons(pool_offset(addr)); - return 1; - } else { - const struct ao_scheme_type *lisp_type; - - if (type == AO_SCHEME_OTHER) - type = ao_scheme_other_type(addr); - - lisp_type = ao_scheme_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_scheme_abort(); -#endif - - MDBG_MOVE("poly_mark offset %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_scheme_mark_memory(lisp_type, addr); - if (!ret) { - MDBG_MOVE("mark recurse\n"); - lisp_type->mark(addr); - } - MDBG_MOVE_OUT(); - return ret; - } -} - -/* - * Find the current location of an object - * based on the original location. For unmoved - * objects, this is simple. For moved objects, - * go search for it - */ - -static uint16_t -move_map(uint16_t offset) -{ - int l; - - if (offset < chunk_low || chunk_high <= offset) - return offset; - - l = find_chunk(offset); - -#if DBG_MEM - if (ao_scheme_chunk[l].old_offset != offset) - ao_scheme_abort(); -#endif - return ao_scheme_chunk[l].new_offset; -} - -int -ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) -{ - void *addr = *ref; - uint16_t offset, orig_offset; - - if (!ao_scheme_is_pool_addr(addr)) - return 1; - - (void) type; - - MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - if (offset != orig_offset) { - MDBG_MOVE("update ref %d %d -> %d\n", - ao_scheme_is_pool_addr(ref) ? MDBG_OFFSET(ref) : -1, - orig_offset, offset); - *ref = ao_scheme_pool + offset; - } - if (busy(ao_scheme_busy, offset)) { - MDBG_MOVE("already moved\n"); - return 1; - } - mark(ao_scheme_busy, offset); - ao_scheme_record(type, addr, ao_scheme_size(type, addr)); - return 0; -} - -static int -ao_scheme_move(const struct ao_scheme_type *type, void **ref) -{ - int ret; - MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); - MDBG_MOVE_IN(); - ret = ao_scheme_move_memory(type, ref); - if (!ret) { - MDBG_MOVE("move recurse\n"); - type->move(*ref); - } - MDBG_MOVE_OUT(); - return ret; -} - -int -ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) -{ - ao_poly p = *ref; - int ret; - void *addr; - uint16_t offset, orig_offset; - - if (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) - return 1; - - addr = ao_scheme_ref(p); - if (!ao_scheme_is_pool_addr(addr)) - return 1; - - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - - if (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS && do_note_cons) { - note_cons(orig_offset); - ret = 1; - } else { - uint8_t type = ao_scheme_poly_base_type(p); - const struct ao_scheme_type *lisp_type; - - if (type == AO_SCHEME_OTHER) - type = ao_scheme_other_type(ao_scheme_pool + offset); - - lisp_type = ao_scheme_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_scheme_abort(); -#endif - /* inline ao_scheme_move to save stack space */ - MDBG_MOVE("move object %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_scheme_move_memory(lisp_type, &addr); - if (!ret) { - MDBG_MOVE("move recurse\n"); - lisp_type->move(addr); - } - MDBG_MOVE_OUT(); - } - - /* Re-write the poly value */ - if (offset != orig_offset) { - ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p)); - MDBG_MOVE("poly %d moved %d -> %d\n", - ao_scheme_poly_type(np), orig_offset, offset); - *ref = np; - } - return ret; -} - -int -ao_scheme_marked(void *addr) -{ - if (!ao_scheme_is_pool_addr(addr)) - return 1; - return busy(ao_scheme_busy, pool_offset(addr)); -} - -#if DBG_MEM -static void -ao_scheme_validate(void) -{ - chunk_low = 0; - memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); - walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); -} - -int dbg_allocs; - -#endif - -void * -ao_scheme_alloc(int size) -{ - void *addr; - - MDBG_DO(++dbg_allocs); - MDBG_DO(if (dbg_validate) ao_scheme_validate()); - size = ao_scheme_size_round(size); - if (AO_SCHEME_POOL - ao_scheme_top < size && - ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && - ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) - { - ao_scheme_error(AO_SCHEME_OOM, "out of memory"); - return NULL; - } - addr = ao_scheme_pool + ao_scheme_top; - ao_scheme_top += size; - MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); - return addr; -} - -void -ao_scheme_poly_stash(ao_poly p) -{ - assert(stash_poly_ptr < AO_SCHEME_NUM_STASH); - stash_poly[stash_poly_ptr++] = p; -} - -ao_poly -ao_scheme_poly_fetch(void) -{ - ao_poly p; - - assert (stash_poly_ptr > 0); - p = stash_poly[--stash_poly_ptr]; - stash_poly[stash_poly_ptr] = AO_SCHEME_NIL; - return p; -} - -int -ao_scheme_print_mark_addr(void *addr) -{ - int offset; - -#if DBG_MEM - if (ao_scheme_collecting) - ao_scheme_abort(); -#endif - - if (!ao_scheme_is_pool_addr(addr)) - return 0; - - if (!ao_scheme_print_cleared) { - ao_scheme_print_cleared = 1; - memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); - } - offset = pool_offset(addr); - if (busy(ao_scheme_busy, offset)) - return 1; - mark(ao_scheme_busy, offset); - return 0; -} - -void -ao_scheme_print_clear_addr(void *addr) -{ - int offset; - -#if DBG_MEM - if (ao_scheme_collecting) - ao_scheme_abort(); -#endif - - if (!ao_scheme_is_pool_addr(addr)) - return; - - if (!ao_scheme_print_cleared) - return; - offset = pool_offset(addr); - clear(ao_scheme_busy, offset); -} - -/* Notes that printing has started */ -void -ao_scheme_print_start(void) -{ - ao_scheme_printing++; -} - -/* Notes that printing has ended. Returns 1 if printing is still going on */ -int -ao_scheme_print_stop(void) -{ - ao_scheme_printing--; - if (ao_scheme_printing != 0) - return 1; - ao_scheme_print_cleared = 0; - return 0; -} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c deleted file mode 100644 index 8a92c9f2..00000000 --- a/src/scheme/ao_scheme_poly.c +++ /dev/null @@ -1,74 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -static void ao_scheme_invalid_write(FILE *out, ao_poly p, bool write) { - fprintf(out, "??? type %d poly 0x%04x ???", ao_scheme_poly_type (p), p); - (void) write; - ao_scheme_abort(); -} - -static void (*const ao_scheme_write_funcs[AO_SCHEME_NUM_TYPE]) (FILE *out, ao_poly p, bool write) = { - [AO_SCHEME_CONS] = ao_scheme_cons_write, -#ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = ao_scheme_bigint_write, -#endif - [AO_SCHEME_INT] = ao_scheme_int_write, - [AO_SCHEME_ATOM] = ao_scheme_atom_write, - [AO_SCHEME_BUILTIN] = ao_scheme_builtin_write, - [AO_SCHEME_FRAME] = ao_scheme_frame_write, - [AO_SCHEME_FRAME_VALS] = ao_scheme_invalid_write, - [AO_SCHEME_LAMBDA] = ao_scheme_lambda_write, - [AO_SCHEME_STACK] = ao_scheme_stack_write, - [AO_SCHEME_BOOL] = ao_scheme_bool_write, - [AO_SCHEME_STRING] = ao_scheme_string_write, -#ifdef AO_SCHEME_FEATURE_FLOAT - [AO_SCHEME_FLOAT] = ao_scheme_float_write, -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR - [AO_SCHEME_VECTOR] = ao_scheme_vector_write, -#endif -#ifdef AO_SCHEME_FEATURE_PORT - [AO_SCHEME_PORT] = ao_scheme_port_write, -#endif -}; - -void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write) -{ - uint8_t type = ao_scheme_poly_type(p); - - if (type < AO_SCHEME_NUM_TYPE) - return ao_scheme_write_funcs[type]; - return ao_scheme_invalid_write; -} - -void * -ao_scheme_ref(ao_poly poly) { - if (poly == AO_SCHEME_NIL) - return NULL; - if (poly & AO_SCHEME_CONST) - return (void *) (ao_scheme_const + (poly & AO_SCHEME_REF_MASK) - 4); - return (void *) (ao_scheme_pool + (poly & AO_SCHEME_REF_MASK) - 4); -} - -ao_poly -ao_scheme_poly(const void *addr, ao_poly type) { - const uint8_t *a = addr; - if (a == NULL) - return AO_SCHEME_NIL; - if (ao_scheme_is_const_addr(a)) - return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; - return (a - ao_scheme_pool + 4) | type; -} diff --git a/src/scheme/ao_scheme_port.c b/src/scheme/ao_scheme_port.c deleted file mode 100644 index b5e5d8dc..00000000 --- a/src/scheme/ao_scheme_port.c +++ /dev/null @@ -1,193 +0,0 @@ -/* - * Copyright © 2018 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -#ifdef AO_SCHEME_FEATURE_PORT - -static void port_mark(void *addr) -{ - (void) addr; -} - -static int port_size(void *addr) -{ - (void) addr; - return sizeof(struct ao_scheme_port); -} - -static void port_move(void *addr) -{ - struct ao_scheme_port *port = addr; - - (void) ao_scheme_poly_move(&port->next, 0); -} - -const struct ao_scheme_type ao_scheme_port_type = { - .mark = port_mark, - .size = port_size, - .move = port_move, - .name = "port", -}; - -void -ao_scheme_port_write(FILE *out, ao_poly v, bool write) -{ - (void) write; - ao_scheme_fprintf(out, "#port<%d>", fileno(ao_scheme_poly_port(v)->file)); -} - -ao_poly ao_scheme_stdin, ao_scheme_stdout, ao_scheme_stderr; - -ao_poly ao_scheme_open_ports; - -void -ao_scheme_port_check_references(void) -{ - struct ao_scheme_port *p; - - for (p = ao_scheme_poly_port(ao_scheme_open_ports); p; p = ao_scheme_poly_port(p->next)) { - if (!ao_scheme_marked(p)) - ao_scheme_port_close(p); - } -} - -struct ao_scheme_port * -ao_scheme_port_alloc(FILE *file, bool stayopen) -{ - struct ao_scheme_port *p; - - p = ao_scheme_alloc(sizeof (struct ao_scheme_port)); - if (!p) - return NULL; - p->type = AO_SCHEME_PORT; - p->stayopen = stayopen; - p->file = file; - p->next = ao_scheme_open_ports; - ao_scheme_open_ports = ao_scheme_port_poly(p); - return p; -} - -void -ao_scheme_port_close(struct ao_scheme_port *port) -{ - ao_poly *prev; - struct ao_scheme_port *ref; - - if (port->file && !port->stayopen) { - fclose(port->file); - port->file = NULL; - for (prev = &ao_scheme_open_ports; (ref = ao_scheme_poly_port(*prev)); prev = &ref->next) - if (ref == port) { - *prev = port->next; - break; - } - } -} - -ao_poly -ao_scheme_do_portp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_port3f, AO_SCHEME_PORT, cons); -} - -ao_poly -ao_scheme_do_port_openp(struct ao_scheme_cons *cons) -{ - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons, - AO_SCHEME_PORT, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return port->file ? _ao_scheme_bool_true : _ao_scheme_bool_false; -} - -static ao_poly -ao_scheme_do_open_file(ao_poly proc, struct ao_scheme_cons *cons, const char *mode) -{ - FILE *file; - struct ao_scheme_string *name; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - file = fopen(name->val, mode); - if (!file) - return ao_scheme_error(AO_SCHEME_FILEERROR, - "%v: no such file \"%v\"", - proc, name); - return ao_scheme_port_poly(ao_scheme_port_alloc(file, false)); -} - -ao_poly -ao_scheme_do_open_input_file(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_open_file(_ao_scheme_atom_open2dinput2dfile, cons, "r"); -} - -ao_poly -ao_scheme_do_open_output_file(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_open_file(_ao_scheme_atom_open2doutput2dfile, cons, "w"); -} - -ao_poly -ao_scheme_do_close_port(struct ao_scheme_cons *cons) -{ - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons, - AO_SCHEME_PORT, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_port_close(port); - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_current_input_port(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_current2dinput2dport, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_stdin) - ao_scheme_stdin = ao_scheme_port_poly(ao_scheme_port_alloc(stdin, true)); - return ao_scheme_stdin; -} - -ao_poly -ao_scheme_do_current_output_port(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_current2doutput2dport, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_stdout) - ao_scheme_stdout = ao_scheme_port_poly(ao_scheme_port_alloc(stdout, true)); - return ao_scheme_stdout; -} - -ao_poly -ao_scheme_do_current_error_port(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_current2derror2dport, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_stderr) - ao_scheme_stderr = ao_scheme_port_poly(ao_scheme_port_alloc(stderr, true)); - return ao_scheme_stderr; -} - -#endif /* AO_SCHEME_FEATURE_PORT */ diff --git a/src/scheme/ao_scheme_port.scheme b/src/scheme/ao_scheme_port.scheme deleted file mode 100644 index 886aed25..00000000 --- a/src/scheme/ao_scheme_port.scheme +++ /dev/null @@ -1,43 +0,0 @@ -; -; Copyright © 2018 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; port functions placed in ROM - - -(define newline - (lambda args - (if (null? args) - (write-char #\newline) - (write-char #\newline (car args)) - ) - ) - ) - -(newline) -(newline (open-output-file "/dev/null")) - -(define (eof-object? a) - (equal? a 'eof) - ) - -(define (load name) - (let ((p (open-input-file name)) - (e)) - (while (not (eof-object? (set! e (read p)))) - (write (eval e)) (newline) - ) - (close-port p) - ) - ) - -(load "/dev/null") diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c deleted file mode 100644 index 3575ff3f..00000000 --- a/src/scheme/ao_scheme_read.c +++ /dev/null @@ -1,727 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" -#include "ao_scheme_read.h" -#include -#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, /* + */ - PRINTABLE|SPECIAL_QUASI, /* , */ - PRINTABLE|SIGN, /* - */ - PRINTABLE|SPECIAL|FLOATC, /* . */ - PRINTABLE, /* / */ - PRINTABLE|DIGIT, /* 0 */ - PRINTABLE|DIGIT, /* 1 */ - PRINTABLE|DIGIT, /* 2 */ - PRINTABLE|DIGIT, /* 3 */ - PRINTABLE|DIGIT, /* 4 */ - PRINTABLE|DIGIT, /* 5 */ - PRINTABLE|DIGIT, /* 6 */ - PRINTABLE|DIGIT, /* 7 */ - PRINTABLE|DIGIT, /* 8 */ - PRINTABLE|DIGIT, /* 9 */ - PRINTABLE, /* : */ - PRINTABLE|COMMENT, /* ; */ - PRINTABLE, /* < */ - PRINTABLE, /* = */ - PRINTABLE, /* > */ - PRINTABLE, /* ? */ - PRINTABLE, /* @ */ - PRINTABLE|ALPHA|HEX_LETTER, /* A */ - PRINTABLE|ALPHA|HEX_LETTER, /* B */ - PRINTABLE|ALPHA|HEX_LETTER, /* C */ - PRINTABLE|ALPHA|HEX_LETTER, /* D */ - PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/* E */ - PRINTABLE|ALPHA|HEX_LETTER, /* F */ - PRINTABLE|ALPHA, /* G */ - PRINTABLE|ALPHA, /* H */ - PRINTABLE|ALPHA, /* I */ - PRINTABLE|ALPHA, /* J */ - PRINTABLE|ALPHA, /* K */ - PRINTABLE|ALPHA, /* L */ - PRINTABLE|ALPHA, /* M */ - PRINTABLE|ALPHA, /* N */ - PRINTABLE|ALPHA, /* O */ - PRINTABLE|ALPHA, /* P */ - PRINTABLE|ALPHA, /* Q */ - PRINTABLE|ALPHA, /* R */ - PRINTABLE|ALPHA, /* S */ - PRINTABLE|ALPHA, /* T */ - PRINTABLE|ALPHA, /* U */ - PRINTABLE|ALPHA, /* V */ - PRINTABLE|ALPHA, /* W */ - PRINTABLE|ALPHA, /* X */ - PRINTABLE|ALPHA, /* Y */ - PRINTABLE|ALPHA, /* Z */ - PRINTABLE, /* [ */ - PRINTABLE, /* \ */ - PRINTABLE, /* ] */ - PRINTABLE, /* ^ */ - PRINTABLE, /* _ */ - PRINTABLE|SPECIAL_QUASI, /* ` */ - PRINTABLE|ALPHA|HEX_LETTER, /* a */ - PRINTABLE|ALPHA|HEX_LETTER, /* b */ - PRINTABLE|ALPHA|HEX_LETTER, /* c */ - PRINTABLE|ALPHA|HEX_LETTER, /* d */ - PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/* e */ - PRINTABLE|ALPHA|HEX_LETTER, /* f */ - PRINTABLE|ALPHA, /* g */ - PRINTABLE|ALPHA, /* h */ - PRINTABLE|ALPHA, /* i */ - PRINTABLE|ALPHA, /* j */ - PRINTABLE|ALPHA, /* k */ - PRINTABLE|ALPHA, /* l */ - PRINTABLE|ALPHA, /* m */ - PRINTABLE|ALPHA, /* n */ - PRINTABLE|ALPHA, /* o */ - PRINTABLE|ALPHA, /* p */ - PRINTABLE|ALPHA, /* q */ - PRINTABLE|ALPHA, /* r */ - PRINTABLE|ALPHA, /* s */ - PRINTABLE|ALPHA, /* t */ - PRINTABLE|ALPHA, /* u */ - PRINTABLE|ALPHA, /* v */ - PRINTABLE|ALPHA, /* w */ - PRINTABLE|ALPHA, /* x */ - PRINTABLE|ALPHA, /* y */ - PRINTABLE|ALPHA, /* z */ - PRINTABLE, /* { */ - PRINTABLE, /* | */ - PRINTABLE, /* } */ - PRINTABLE, /* ~ */ - IGNORE, /* ^? */ -}; - -static int lex_unget_c; - -#ifndef ao_scheme_getc -#define ao_scheme_getc(f) getc(f) -#endif - -static inline int -lex_get(FILE *in) -{ - int c; - if (lex_unget_c) { - c = lex_unget_c; - lex_unget_c = 0; - } else { - c = ao_scheme_getc(in); - } - return c; -} - -static inline void -lex_unget(int c) -{ - if (c != EOF) - lex_unget_c = c; -} - -static uint16_t lex_class; - -static int -lexc(FILE *in) -{ - int c; - do { - c = lex_get(in); - if (c == EOF) { - c = 0; - lex_class = ENDOFFILE; - } else { - lex_class = PRINTABLE; - if (c <= 0x7f) - lex_class = lex_classes[c]; - } - } while (lex_class & IGNORE); - return c; -} - -static int -lex_quoted(FILE *in) -{ - int c; - int v; - int count; - - c = lex_get(in); - if (c == EOF) { - eof: - lex_class = ENDOFFILE; - return 0; - } - lex_class = 0; - c &= 0x7f; - switch (c) { - case 'a': - return '\a'; - case 'b': - return '\b'; - case 't': - return '\t'; - case 'n': - return '\n'; - case 'r': - return '\r'; - case 'f': - return '\f'; - case 'v': - return '\v'; - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - v = c - '0'; - count = 1; - while (count <= 3) { - c = lex_get(in); - if (c == EOF) - goto eof; - c &= 0x7f; - if (c < '0' || '7' < c) { - lex_unget(c); - break; - } - v = (v << 3) + c - '0'; - ++count; - } - return v; - default: - return c; - } -} - -#ifndef AO_SCHEME_TOKEN_MAX -#define AO_SCHEME_TOKEN_MAX 128 -#endif - -static char token_string[AO_SCHEME_TOKEN_MAX]; -static int32_t token_int; -static int token_len; - -static void start_token(void) { - token_len = 0; -} - -static void add_token(int c) { - if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) - token_string[token_len++] = c; -} - -static void end_token(void) { - token_string[token_len] = '\0'; -} - -#ifdef AO_SCHEME_FEATURE_FLOAT -static float token_float; - -struct namedfloat { - const char *name; - float value; -}; - -static const struct namedfloat namedfloats[] = { - { .name = "+inf.0", .value = INFINITY }, - { .name = "-inf.0", .value = -INFINITY }, - { .name = "+nan.0", .value = NAN }, - { .name = "-nan.0", .value = NAN }, -}; - -#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) -#endif - -static int -parse_int(FILE *in, int base) -{ - int cval; - int c; - - token_int = 0; - for (;;) { - c = lexc(in); - if ((lex_class & HEX_DIGIT) == 0) { - lex_unget(c); - return NUM; - } - if ('0' <= c && c <= '9') - cval = c - '0'; - else - cval = (c | ('a' - 'A')) - 'a' + 10; - token_int = token_int * base + cval; - } - return NUM; -} - -static int -_lex(FILE *in) -{ - int c; - - start_token(); - for (;;) { - c = lexc(in); - if (lex_class & ENDOFFILE) - return END; - - if (lex_class & WHITE) - continue; - - if (lex_class & COMMENT) { - while ((c = lexc(in)) != '\n') { - if (lex_class & ENDOFFILE) - return END; - } - continue; - } - - if (lex_class & SPECIAL) { - switch (c) { - case '(': - case '[': - return OPEN; - case ')': - case ']': - return CLOSE; - case '\'': - return QUOTE; - case '.': - return DOT; -#ifdef AO_SCHEME_FEATURE_QUASI - case '`': - return QUASIQUOTE; - case ',': - c = lexc(in); - if (c == '@') { - return UNQUOTE_SPLICING; - } else { - lex_unget(c); - return UNQUOTE; - } -#endif - } - } - if (c == '#') { - c = lexc(in); - switch (c) { - case 't': - return TRUE_TOKEN; - case 'f': - return FALSE_TOKEN; -#ifdef AO_SCHEME_FEATURE_VECTOR - case '(': - return OPEN_VECTOR; -#endif - case '\\': - for (;;) { - c = lexc(in); - if (token_len == 0) { - add_token(c); - if (!(lex_class & ALPHA)) - break; - } else { - if (lex_class & ALPHA) - add_token(c); - else { - lex_unget(c); - break; - } - } - } - end_token(); - if (token_len == 1) - token_int = token_string[0]; - else if (!strcmp(token_string, "space")) - token_int = ' '; - else if (!strcmp(token_string, "newline")) - token_int = '\n'; - else if (!strcmp(token_string, "tab")) - token_int = '\t'; - else if (!strcmp(token_string, "return")) - token_int = '\r'; - else if (!strcmp(token_string, "formfeed")) - token_int = '\f'; - else { - ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string); - continue; - } - return NUM; - case 'x': - return parse_int(in, 16); - case 'o': - return parse_int(in, 8); - case 'b': - return parse_int(in, 2); - } - } - if (lex_class & STRINGC) { - for (;;) { - c = lexc(in); - if (c == '\\') - c = lex_quoted(in); - if (lex_class & (STRINGC|ENDOFFILE)) { - end_token(); - return STRING; - } - add_token(c); - } - } - if (lex_class & PRINTABLE) { -#ifdef AO_SCHEME_FEATURE_FLOAT - int isfloat = 1; - int epos = 0; -#endif - int hasdigit = 0; - int isneg = 0; - int isint = 1; - - token_int = 0; - for (;;) { - if (!(lex_class & NUMBER)) { - isint = 0; -#ifdef AO_SCHEME_FEATURE_FLOAT - isfloat = 0; -#endif - } else { -#ifdef AO_SCHEME_FEATURE_FLOAT - if (!(lex_class & INTEGER)) - isint = 0; - if (token_len != epos && - (lex_class & SIGN)) - { - isint = 0; - isfloat = 0; - } -#endif - if (c == '-') - isneg = 1; -#ifdef AO_SCHEME_FEATURE_FLOAT - if (c == '.' && epos != 0) - isfloat = 0; - if (c == 'e' || c == 'E') { - if (token_len == 0) - isfloat = 0; - else - epos = token_len + 1; - } -#endif - if (lex_class & DIGIT) { - hasdigit = 1; - if (isint) - token_int = token_int * 10 + c - '0'; - } - } - add_token (c); - c = lexc (in); - if ((lex_class & (NOTNAME)) -#ifdef AO_SCHEME_FEATURE_FLOAT - && (c != '.' || !isfloat) -#endif - ) { -#ifdef AO_SCHEME_FEATURE_FLOAT - unsigned int u; -#endif - lex_unget(c); - end_token (); - if (isint && hasdigit) { - if (isneg) - token_int = -token_int; - return NUM; - } -#ifdef AO_SCHEME_FEATURE_FLOAT - if (isfloat && hasdigit) { - token_float = strtof(token_string, NULL); - return FLOAT; - } - for (u = 0; u < NUM_NAMED_FLOATS; u++) - if (!strcmp(namedfloats[u].name, token_string)) { - token_float = namedfloats[u].value; - return FLOAT; - } -#endif - return NAME; - } - } - } - } -} - -static inline int lex(FILE *in) -{ - int parse_token = _lex(in); - RDBGI("token %d \"%s\"\n", parse_token, token_string); - return parse_token; -} - -static int parse_token; - -int ao_scheme_read_list; -struct ao_scheme_cons *ao_scheme_read_cons; -struct ao_scheme_cons *ao_scheme_read_cons_tail; -struct ao_scheme_cons *ao_scheme_read_stack; -static int ao_scheme_read_state; - -#define READ_IN_QUOTE 0x01 -#define READ_SAW_DOT 0x02 -#define READ_DONE_DOT 0x04 -#define READ_SAW_VECTOR 0x08 - -static int -push_read_stack(int read_state) -{ - RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); - RDBG_IN(); - if (ao_scheme_read_list) { - ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), - ao_scheme_cons(ao_scheme_int_poly(read_state), - ao_scheme_cons_poly(ao_scheme_read_stack))); - if (!ao_scheme_read_stack) - return 0; - } else - ao_scheme_read_state = read_state; - ao_scheme_read_cons = NULL; - ao_scheme_read_cons_tail = NULL; - return 1; -} - -static int -pop_read_stack(void) -{ - int read_state = 0; - if (ao_scheme_read_list) { - ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); - ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); - read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); - ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); - for (ao_scheme_read_cons_tail = ao_scheme_read_cons; - ao_scheme_read_cons_tail && ao_scheme_read_cons_tail->cdr; - ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr)) - ; - } else { - read_state = ao_scheme_read_state; - ao_scheme_read_cons = NULL; - ao_scheme_read_cons_tail = NULL; - ao_scheme_read_stack = NULL; - ao_scheme_read_state = 0; - } - RDBG_OUT(); - RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); - return read_state; -} - -#ifdef AO_SCHEME_FEATURE_VECTOR -#define is_open(t) ((t) == OPEN || (t) == OPEN_VECTOR) -#else -#define is_open(t) ((t) == OPEN) -#endif - -ao_poly -ao_scheme_read(FILE *in) -{ - struct ao_scheme_atom *atom; - struct ao_scheme_string *string; - int read_state; - ao_poly v = AO_SCHEME_NIL; - - ao_scheme_read_list = 0; - read_state = 0; - ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = NULL; - for (;;) { - parse_token = lex(in); - while (is_open(parse_token)) { -#ifdef AO_SCHEME_FEATURE_VECTOR - if (parse_token == OPEN_VECTOR) - read_state |= READ_SAW_VECTOR; -#endif - if (!push_read_stack(read_state)) - return AO_SCHEME_NIL; - ao_scheme_read_list++; - read_state = 0; - parse_token = lex(in); - } - - switch (parse_token) { - case END: - default: - if (ao_scheme_read_list) - ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); - return _ao_scheme_atom_eof; - break; - case NAME: - atom = ao_scheme_atom_intern(token_string); - if (atom) - v = ao_scheme_atom_poly(atom); - else - v = AO_SCHEME_NIL; - break; - case NUM: - v = ao_scheme_integer_poly(token_int); - break; -#ifdef AO_SCHEME_FEATURE_FLOAT - case FLOAT: - v = ao_scheme_float_get(token_float); - break; -#endif - case TRUE_TOKEN: - v = _ao_scheme_bool_true; - break; - case FALSE_TOKEN: - v = _ao_scheme_bool_false; - break; - case STRING: - string = ao_scheme_string_new(token_string); - if (string) - v = ao_scheme_string_poly(string); - else - v = AO_SCHEME_NIL; - break; - case QUOTE: -#ifdef AO_SCHEME_FEATURE_QUASI - case QUASIQUOTE: - case UNQUOTE: - case UNQUOTE_SPLICING: -#endif - if (!push_read_stack(read_state)) - return AO_SCHEME_NIL; - ao_scheme_read_list++; - read_state = READ_IN_QUOTE; - switch (parse_token) { - case QUOTE: - v = _ao_scheme_atom_quote; - break; -#ifdef AO_SCHEME_FEATURE_QUASI - case QUASIQUOTE: - v = _ao_scheme_atom_quasiquote; - break; - case UNQUOTE: - v = _ao_scheme_atom_unquote; - break; - case UNQUOTE_SPLICING: - v = _ao_scheme_atom_unquote2dsplicing; - break; -#endif - } - break; - case CLOSE: - if (!ao_scheme_read_list) { - v = AO_SCHEME_NIL; - break; - } - v = ao_scheme_cons_poly(ao_scheme_read_cons); - --ao_scheme_read_list; - read_state = pop_read_stack(); -#ifdef AO_SCHEME_FEATURE_VECTOR - if (read_state & READ_SAW_VECTOR) { - v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); - read_state &= ~READ_SAW_VECTOR; - } -#endif - break; - case DOT: - if (!ao_scheme_read_list) { - ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); - return AO_SCHEME_NIL; - } - if (!ao_scheme_read_cons) { - ao_scheme_error(AO_SCHEME_INVALID, ". first in cons"); - return AO_SCHEME_NIL; - } - read_state |= READ_SAW_DOT; - continue; - } - - /* loop over QUOTE ends */ - for (;;) { - if (!ao_scheme_read_list) - return v; - - if (read_state & READ_DONE_DOT) { - ao_scheme_error(AO_SCHEME_INVALID, ". not last in cons"); - return AO_SCHEME_NIL; - } - - if (read_state & READ_SAW_DOT) { - read_state |= READ_DONE_DOT; - ao_scheme_read_cons_tail->cdr = v; - } else { - struct ao_scheme_cons *read = ao_scheme_cons_cons(v, AO_SCHEME_NIL); - if (!read) - return AO_SCHEME_NIL; - - if (ao_scheme_read_cons_tail) - ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read); - else - ao_scheme_read_cons = read; - ao_scheme_read_cons_tail = read; - } - - if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr) - break; - - v = ao_scheme_cons_poly(ao_scheme_read_cons); - --ao_scheme_read_list; - read_state = pop_read_stack(); - } - } - return v; -} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h deleted file mode 100644 index 34739c9e..00000000 --- a/src/scheme/ao_scheme_read.h +++ /dev/null @@ -1,76 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_SCHEME_READ_H_ -#define _AO_SCHEME_READ_H_ - -/* - * token classes - */ - -# define END 0 -# define NAME 1 -# define OPEN 2 -# define CLOSE 3 -# define QUOTE 4 -#ifdef AO_SCHEME_FEATURE_QUASI -# define QUASIQUOTE 5 -# define UNQUOTE 6 -# define UNQUOTE_SPLICING 7 -#endif -# define STRING 8 -# define NUM 9 -#ifdef AO_SCHEME_FEATURE_FLOAT -# define FLOAT 10 -#endif -# define DOT 11 -# define TRUE_TOKEN 12 -# define FALSE_TOKEN 13 -#ifdef AO_SCHEME_FEATURE_VECTOR -# define OPEN_VECTOR 14 -#endif - -/* - * character classes - */ - -# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ -# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ -#ifdef AO_SCHEME_FEATURE_QUASI -# define SPECIAL_QUASI SPECIAL -#else -# define SPECIAL_QUASI 0 -#endif -# -# define ALPHA 0x0004 /* A-Z a-z */ -# define WHITE 0x0008 /* ' ' \t \n */ -# define DIGIT 0x0010 /* [0-9] */ -# define SIGN 0x0020 /* +- */ -#ifdef AO_SCHEME_FEATURE_FLOAT -# define FLOATC 0x0040 /* . e E */ -#else -# define FLOATC 0 -#endif -# define ENDOFFILE 0x0080 /* end of file */ -# define COMMENT 0x0100 /* ; */ -# define IGNORE 0x0200 /* \0 - ' ' */ -# define STRINGC 0x0400 /* " */ -# define HEX_LETTER 0x0800 /* a-f A-F */ - -# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define INTEGER (DIGIT|SIGN) -# define NUMBER (INTEGER|FLOATC) -# define HEX_DIGIT (DIGIT|HEX_LETTER) - -#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c deleted file mode 100644 index 49ab0559..00000000 --- a/src/scheme/ao_scheme_rep.c +++ /dev/null @@ -1,42 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -ao_poly -ao_scheme_read_eval_print(FILE *read_file, FILE *write_file, bool interactive) -{ - ao_poly in, out = AO_SCHEME_NIL; - - ao_scheme_exception = 0; - for(;;) { - if (interactive) - fputs("> ", write_file); - in = ao_scheme_read(read_file); - if (in == _ao_scheme_atom_eof) - break; - out = ao_scheme_eval(in); - if (ao_scheme_exception) { - if (ao_scheme_exception & AO_SCHEME_EXIT) - break; - ao_scheme_exception = 0; - } else { - if (write_file) { - ao_scheme_poly_write(write_file, out, true); - putc('\n', write_file); - } - } - } - return out; -} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c deleted file mode 100644 index 0ef547d8..00000000 --- a/src/scheme/ao_scheme_save.c +++ /dev/null @@ -1,89 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -#ifdef AO_SCHEME_FEATURE_SAVE -ao_poly -ao_scheme_do_save(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_MAKE_CONST - struct ao_scheme_os_save *os; - - if (!ao_scheme_parse_args(_ao_scheme_atom_save, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; - - ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - os->atoms = ao_scheme_atom_poly(ao_scheme_atoms); - os->globals = ao_scheme_frame_poly(ao_scheme_frame_global); - os->const_checksum = ao_scheme_const_checksum; - os->const_checksum_inv = (uint16_t) ~ao_scheme_const_checksum; - - if (ao_scheme_os_save()) - return _ao_scheme_bool_true; -#else - (void) cons; -#endif - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_restore(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_MAKE_CONST - struct ao_scheme_os_save save; - struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; - if (!ao_scheme_parse_args(_ao_scheme_atom_restore, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; - - if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) - return ao_scheme_error(AO_SCHEME_INVALID, "header restore failed"); - - if (save.const_checksum != ao_scheme_const_checksum || - save.const_checksum_inv != (uint16_t) ~ao_scheme_const_checksum) - { - return ao_scheme_error(AO_SCHEME_INVALID, "image is corrupted or stale"); - } - - if (ao_scheme_os_restore()) { - - ao_scheme_atoms = ao_scheme_poly_atom(os->atoms); - ao_scheme_frame_global = ao_scheme_poly_frame(os->globals); - - /* Clear the eval global variabls */ - ao_scheme_eval_clear_globals(); - - /* Reset the allocator */ - ao_scheme_top = AO_SCHEME_POOL; - ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - - /* Re-create the evaluator stack */ - if (!ao_scheme_eval_restart()) - return _ao_scheme_bool_false; - - return _ao_scheme_bool_true; - } -#else - (void) cons; -#endif - return _ao_scheme_bool_false; -} - -#endif /* AO_SCHEME_FEATURE_SAVE */ diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c deleted file mode 100644 index d3b5d4b7..00000000 --- a/src/scheme/ao_scheme_stack.c +++ /dev/null @@ -1,279 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -const struct ao_scheme_type ao_scheme_stack_type; - -static int -stack_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_stack); -} - -static void -stack_mark(void *addr) -{ - struct ao_scheme_stack *stack = addr; - for (;;) { - ao_scheme_poly_mark(stack->sexprs, 1); - ao_scheme_poly_mark(stack->values, 1); - /* no need to mark values_tail */ - ao_scheme_poly_mark(stack->frame, 0); - ao_scheme_poly_mark(stack->list, 1); - stack = ao_scheme_poly_stack(stack->prev); - if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_scheme_stack *stack = addr; - - while (stack) { - struct ao_scheme_stack *prev; - int ret; - (void) ao_scheme_poly_move(&stack->sexprs, 1); - (void) ao_scheme_poly_move(&stack->values, 1); - (void) ao_scheme_poly_move(&stack->values_tail, 0); - (void) ao_scheme_poly_move(&stack->frame, 0); - (void) ao_scheme_poly_move(&stack->list, 1); - prev = ao_scheme_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); - if (prev != ao_scheme_poly_stack(stack->prev)) - stack->prev = ao_scheme_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_scheme_type ao_scheme_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - -struct ao_scheme_stack *ao_scheme_stack_free_list; - -void -ao_scheme_stack_reset(struct ao_scheme_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_SCHEME_NIL; - stack->values = AO_SCHEME_NIL; - stack->values_tail = AO_SCHEME_NIL; -} - -static struct ao_scheme_stack * -ao_scheme_stack_new(void) -{ - struct ao_scheme_stack *stack; - - if (ao_scheme_stack_free_list) { - stack = ao_scheme_stack_free_list; - ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); - } else { - stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); - if (!stack) - return 0; - stack->type = AO_SCHEME_STACK; - } - ao_scheme_stack_reset(stack); - return stack; -} - -int -ao_scheme_stack_push(void) -{ - struct ao_scheme_stack *stack; - - stack = ao_scheme_stack_new(); - - if (!stack) - return 0; - - stack->prev = ao_scheme_stack_poly(ao_scheme_stack); - stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); - stack->list = AO_SCHEME_NIL; - - ao_scheme_stack = stack; - - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -void -ao_scheme_stack_pop(void) -{ - ao_poly prev; - struct ao_scheme_frame *prev_frame; - - if (!ao_scheme_stack) - return; - prev = ao_scheme_stack->prev; - if (!ao_scheme_stack_marked(ao_scheme_stack)) { - ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); - ao_scheme_stack_free_list = ao_scheme_stack; - } - - ao_scheme_stack = ao_scheme_poly_stack(prev); - prev_frame = ao_scheme_frame_current; - if (ao_scheme_stack) - ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); - else - ao_scheme_frame_current = NULL; - if (ao_scheme_frame_current != prev_frame) - ao_scheme_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -void -ao_scheme_stack_write(FILE *out, ao_poly poly, bool write) -{ - struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); - struct ao_scheme_stack *clear = s; - int written = 0; - - (void) write; - ao_scheme_print_start(); - ao_scheme_frame_print_indent += 2; - while (s) { - if (ao_scheme_print_mark_addr(s)) { - fputs("[recurse...]", out); - break; - } - written++; - fputs("\t[\n", out); - ao_scheme_fprintf(out, "\t\texpr: %v\n", s->list); - ao_scheme_fprintf(out, "\t\tvalues: %v\n", s->values); - ao_scheme_fprintf(out, "\t\tframe: %v\n", s->frame); - fputs("\t]\n", out); - s = ao_scheme_poly_stack(s->prev); - } - ao_scheme_frame_print_indent -= 2; - if (ao_scheme_print_stop()) { - while (written--) { - ao_scheme_print_clear_addr(clear); - clear = ao_scheme_poly_stack(clear->prev); - } - } -} - -/* - * Copy a stack, being careful to keep everybody referenced - */ -static struct ao_scheme_stack * -ao_scheme_stack_copy(struct ao_scheme_stack *old) -{ - struct ao_scheme_stack *new = NULL; - struct ao_scheme_stack *n, *prev = NULL; - - while (old) { - ao_scheme_stack_stash(old); - ao_scheme_stack_stash(new); - ao_scheme_stack_stash(prev); - n = ao_scheme_stack_new(); - prev = ao_scheme_stack_fetch(); - new = ao_scheme_stack_fetch(); - old = ao_scheme_stack_fetch(); - if (!n) - return NULL; - - ao_scheme_stack_mark(old); - ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); - *n = *old; - - if (prev) - prev->prev = ao_scheme_stack_poly(n); - else - new = n; - prev = n; - - old = ao_scheme_poly_stack(old->prev); - } - return new; -} - -/* - * Evaluate a continuation invocation - */ -ao_poly -ao_scheme_stack_eval(void) -{ - struct ao_scheme_cons *cons; - struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); - if (!new) - return AO_SCHEME_NIL; - - cons = ao_scheme_poly_cons(ao_scheme_stack->values); - - if (!cons || !cons->cdr) - return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); - - new->state = eval_val; - - ao_scheme_stack = new; - ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); - - return ao_scheme_poly_cons(cons->cdr)->car; -} - -/* - * Call with current continuation. This calls a lambda, passing - * it a single argument which is the current continuation - */ -ao_poly -ao_scheme_do_call_cc(struct ao_scheme_cons *cons) -{ - struct ao_scheme_stack *new; - ao_poly v; - - if (!ao_scheme_parse_args(_ao_scheme_atom_call2fcc, cons, - AO_SCHEME_LAMBDA|AO_SCHEME_ARG_RET_POLY, &v, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - ao_scheme_poly_stash(v); - /* Note that the whole call chain now has - * a reference to it which may escape - */ - new = ao_scheme_stack_copy(ao_scheme_stack); - if (!new) - return AO_SCHEME_NIL; - v = ao_scheme_poly_fetch(); - - /* re-fetch cons after the allocation */ - cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); - - /* Reset the arg list to the current stack, - * and call the lambda - */ - - cons->car = ao_scheme_stack_poly(new); - cons->cdr = AO_SCHEME_NIL; - - ao_scheme_stack->state = eval_exec; - return v; -} diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c deleted file mode 100644 index 2c6d0960..00000000 --- a/src/scheme/ao_scheme_string.c +++ /dev/null @@ -1,349 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_scheme.h" - -static void string_mark(void *addr) -{ - (void) addr; -} - -static int string_size(void *addr) -{ - struct ao_scheme_string *string = addr; - if (!addr) - return 0; - return strlen(string->val) + 2; -} - -static void string_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_string_type = { - .mark = string_mark, - .size = string_size, - .move = string_move, - .name = "string", -}; - -static struct ao_scheme_string * -ao_scheme_string_alloc(int len) -{ - struct ao_scheme_string *s; - - if (len < 0) - return NULL; - s = ao_scheme_alloc(len + 2); - if (!s) - return NULL; - s->type = AO_SCHEME_STRING; - s->val[len] = '\0'; - return s; -} - -struct ao_scheme_string * -ao_scheme_string_new(char *a) -{ - struct ao_scheme_string *r; - - r = ao_scheme_string_alloc(strlen(a)); - if (!r) - return NULL; - strcpy(r->val, a); - return r; -} - -struct ao_scheme_string * -ao_scheme_atom_to_string(struct ao_scheme_atom *a) -{ - int alen = strlen(a->name); - struct ao_scheme_string *r; - - ao_scheme_atom_stash(a); - r = ao_scheme_string_alloc(alen); - a = ao_scheme_atom_fetch(); - if (!r) - return NULL; - strcpy(r->val, a->name); - return r; -} - -struct ao_scheme_string * -ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) -{ - int alen = strlen(a->val); - int blen = strlen(b->val); - struct ao_scheme_string *r; - - ao_scheme_string_stash(a); - ao_scheme_string_stash(b); - r = ao_scheme_string_alloc(alen + blen); - b = ao_scheme_string_fetch(); - a = ao_scheme_string_fetch(); - if (!r) - return NULL; - strcpy(r->val, a->val); - strcpy(r->val+alen, b->val); - return r; -} - -static ao_poly -ao_scheme_string_pack(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - char *s; - int len; - - len = ao_scheme_cons_length(cons); - ao_scheme_cons_stash(cons); - string = ao_scheme_string_alloc(len); - cons = ao_scheme_cons_fetch(); - if (!string) - return AO_SCHEME_NIL; - s = string->val; - - while (cons) { - ao_poly car = cons->car; - int32_t c; - if (!ao_scheme_is_integer(car) || (c = ao_scheme_poly_integer(car)) == 0) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: Invalid %v", _ao_scheme_atom_list2d3estring, car); - *s++ = c; - cons = ao_scheme_cons_cdr(cons); - } - return ao_scheme_string_poly(string); -} - -static ao_poly -ao_scheme_string_unpack(struct ao_scheme_string *a) -{ - ao_poly cons = AO_SCHEME_NIL; - int i; - - for (i = strlen(a->val); --i >= 0;) { - ao_scheme_string_stash(a); - cons = ao_scheme_cons(ao_scheme_int_poly(a->val[i]), cons); - a = ao_scheme_string_fetch(); - if (!cons) - break; - } - return cons; -} - -void -ao_scheme_string_write(FILE *out, ao_poly p, bool write) -{ - struct ao_scheme_string *s = ao_scheme_poly_string(p); - char *sval = s->val; - char c; - - if (write) { - putc('"', out); - while ((c = *sval++)) { - switch (c) { - case '\a': - fputs("\\a", out); - break; - case '\b': - fputs("\\b", out); - break; - case '\t': - fputs("\\t", out); - break; - case '\n': - fputs("\\n", out); - break; - case '\r': - fputs("\\r", out); - break; - case '\f': - fputs("\\f", out); - break; - case '\v': - fputs("\\v", out); - break; - case '\"': - fputs("\\\"", out); - break; - case '\\': - fputs("\\\\", out); - break; - default: - if ((uint8_t) c < ' ') - fprintf(out, "\\%03o", (uint8_t) c); - else - putc(c, out); - break; - } - } - putc('"', out); - } else { - while ((c = *sval++)) - putc(c, out); - } -} - -ao_poly -ao_scheme_do_stringp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_string3f, AO_SCHEME_STRING, cons); -} - -ao_poly -ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *list; - - if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3estring, cons, - AO_SCHEME_CONS, &list, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_string_pack(list); -} - -ao_poly -ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3elist, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_string_unpack(string); -} - -static char * -ao_scheme_string_ref(struct ao_scheme_string *string, int32_t r) -{ - char *s = string->val; - while (*s && r) { - ++s; - --r; - } - return s; -} - -ao_poly -ao_scheme_do_string_ref(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - int32_t ref; - char *s; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2dref, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_INT, &ref, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - s = ao_scheme_string_ref(string, ref); - if (!*s) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", - _ao_scheme_atom_string2dref, - cons->car, - ao_scheme_arg(cons, 1)); - return ao_scheme_integer_poly(*s); -} - -ao_poly -ao_scheme_do_string_length(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2dlength, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(strlen(string->val)); -} - -ao_poly -ao_scheme_do_string_set(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - int32_t ref; - int32_t val; - char *s; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2dset21, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_INT, &ref, - AO_SCHEME_INT, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!val) - goto fail; - s = ao_scheme_string_ref(string, ref); - if (!*s) - goto fail; - *s = val; - return ao_scheme_integer_poly(val); -fail: - return ao_scheme_error(AO_SCHEME_INVALID, "%v: %v[%v] = %v invalid", - _ao_scheme_atom_string2dset21, - ao_scheme_arg(cons, 0), - ao_scheme_arg(cons, 1), - ao_scheme_arg(cons, 2)); -} - -ao_poly -ao_scheme_do_make_string(struct ao_scheme_cons *cons) -{ - int32_t len; - int32_t fill; - struct ao_scheme_string *string; - - if (!ao_scheme_parse_args(_ao_scheme_atom_make2dstring, cons, - AO_SCHEME_INT, &len, - AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(' '), &fill, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!fill) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: fill 0 invalid", - _ao_scheme_atom_make2dstring); - string = ao_scheme_string_alloc(len); - if (!string) - return AO_SCHEME_NIL; - memset(string->val, fill, len); - return ao_scheme_string_poly(string); -} - -ao_poly -ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) -{ - struct ao_scheme_atom *atom; - - if (!ao_scheme_parse_args(_ao_scheme_atom_symbol2d3estring, cons, - AO_SCHEME_ATOM, &atom, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_string_poly(ao_scheme_atom_to_string(atom)); -} - -ao_poly -ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3esymbol, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_atom_poly(ao_scheme_string_to_atom(string)); -} diff --git a/src/scheme/ao_scheme_string.scheme b/src/scheme/ao_scheme_string.scheme deleted file mode 100644 index 99f16fab..00000000 --- a/src/scheme/ao_scheme_string.scheme +++ /dev/null @@ -1,156 +0,0 @@ -; -; Copyright © 2018 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; string functions placed in ROM - -(define string (lambda chars (list->string chars))) - -(string #\a #\b #\c) - -(define string-map - (lambda (proc . strings) - ; result length is min of arg lengths - (let* ((l (apply min (map string-length strings))) - ; create the result - (s (make-string l))) - ; walk the strings, doing evaluation - (define (_m p) - (if (equal? p l) - s - (begin - (string-set! s p (apply proc (map (lambda (s) (string-ref s p)) strings))) - (_m (+ p 1)) - ) - ) - ) - (_m 0) - ) - ) - ) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-copy! - (lambda (t a f . args) - (let ((l 0) - (h (string-length f)) - (o a) - (d 1)) - ; handle optional start/end args - - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - (set! o (- a l)) - ) - ) - ; flip copy order if dst is - ; after src - (if (< l a) - (begin - (set! d h) - (set! h (- l 1)) - (set! l (- d 1)) - (set! d -1) - ) - ) - ; loop copying one at a time - (do ((p l (+ p d)) - ) - ((= p h) t) - (string-set! t (+ p o) (string-ref f p)) - ) - ) - ) - ) - -(string-copy! (make-string 10) 0 "hello" 0 5) -(string-copy! (make-string 10) 1 "hello" 0 5) -(string-copy! (make-string 10) 0 "hello" 0 5) - -(define (string-upcase s) (string-map char-upcase s)) -(define (string-downcase s) (string-map char-downcase s)) -(define string-foldcase string-downcase) - -(define string-copy - (lambda (s . args) - (let ((l 0) - (h (string-length s))) - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - (string-copy! (make-string (- h l)) 0 s l h) - ) - ) - ) - -(string-copy "hello" 0 1) -(string-copy "hello" 1) -(string-copy "hello") - -(define substring string-copy) - -(define string-fill! - (lambda (s a . args) - (let ((l 0) - (h (string-length s))) - (cond ((not (null? args)) - (set! l (car args)) - (cond ((not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - ) - (define (_f b) - (cond ((< b h) - (string-set! s b a) - (_f (+ b 1)) - ) - (else s) - ) - ) - (_f l) - ) - ) - ) - -(string-fill! (make-string 10) #\a) -(string-fill! (make-string 10) #\a 1 2) - -(define string-for-each - (lambda (proc . strings) - ; result length is min of arg lengths - (let* ((l (apply min (map string-length strings))) - ) - ; walk the strings, doing evaluation - (define (_m p) - (if (equal? p l) - #t - (begin - (apply proc (map (lambda (s) (string-ref s p)) strings)) - (_m (+ p 1)) - ) - ) - ) - (_m 0) - ) - ) - ) - -(string-for-each write-char "IBM\n") diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c deleted file mode 100644 index e7328e32..00000000 --- a/src/scheme/ao_scheme_vector.c +++ /dev/null @@ -1,284 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - -#ifdef AO_SCHEME_FEATURE_VECTOR - -static void vector_mark(void *addr) -{ - struct ao_scheme_vector *vector = addr; - unsigned int i; - - for (i = 0; i < vector->length; i++) { - ao_poly v = vector->vals[i]; - - ao_scheme_poly_mark(v, 1); - } -} - -static int vector_len_size(uint16_t length) -{ - return sizeof (struct ao_scheme_vector) + length * sizeof (ao_poly); -} - -static int vector_size(void *addr) -{ - struct ao_scheme_vector *vector = addr; - - return vector_len_size(vector->length); -} - -static void vector_move(void *addr) -{ - struct ao_scheme_vector *vector = addr; - unsigned int i; - - for (i = 0; i < vector->length; i++) - (void) ao_scheme_poly_move(&vector->vals[i], 1); -} - -const struct ao_scheme_type ao_scheme_vector_type = { - .mark = vector_mark, - .size = vector_size, - .move = vector_move, - .name = "vector", -}; - -struct ao_scheme_vector * -ao_scheme_vector_alloc(uint16_t length, ao_poly fill) -{ - struct ao_scheme_vector *vector; - unsigned int i; - - vector = ao_scheme_alloc(vector_len_size(length)); - if (!vector) - return NULL; - vector->type = AO_SCHEME_VECTOR; - vector->length = length; - for (i = 0; i < length; i++) - vector->vals[i] = fill; - return vector; -} - -struct vl { - struct ao_scheme_vector *vector; - struct vl *prev; -}; - -static struct vl *vl; -static unsigned int vd; - -void -ao_scheme_vector_write(FILE *out, ao_poly v, bool write) -{ - struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); - unsigned int i; - int was_marked = 0; - struct vl *ve; - - ++vd; - for (ve = vl; ve; ve = ve->prev) - if (ve->vector == vector) - abort(); - - ve = malloc(sizeof (struct vl)); - ve->prev = vl; - ve->vector = vector; - vl = ve; - - ao_scheme_print_start(); - was_marked = ao_scheme_print_mark_addr(vector); - if (was_marked) { - fputs("...", out); - } else { - fputs("#(", out); - for (i = 0; i < vector->length; i++) { - if (i != 0) - putc(' ', out); - ao_scheme_poly_write(out, vector->vals[i], write); - } - printf(")"); - } - if (ao_scheme_print_stop() && !was_marked) - ao_scheme_print_clear_addr(vector); - if (vl != ve) - abort(); - vl = ve->prev; - free(ve); - --vd; -} - -struct ao_scheme_vector * -ao_scheme_list_to_vector(struct ao_scheme_cons *cons) -{ - uint16_t length; - uint16_t i; - struct ao_scheme_vector *vector; - - length = (uint16_t) ao_scheme_cons_length (cons); - if (ao_scheme_exception) - return NULL; - - ao_scheme_cons_stash(cons); - vector = ao_scheme_vector_alloc(length, AO_SCHEME_NIL); - cons = ao_scheme_cons_fetch(); - if (!vector) - return NULL; - i = 0; - while (cons) { - vector->vals[i++] = cons->car; - cons = ao_scheme_cons_cdr(cons); - } - return vector; -} - -struct ao_scheme_cons * -ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end) -{ - int i; - uint16_t length = vector->length; - struct ao_scheme_cons *cons = NULL; - - if (end == -1) - end = length; - if (start < 0) - start = 0; - if (end > length) - end = length; - for (i = end; i-- > start;) { - ao_scheme_vector_stash(vector); - cons = ao_scheme_cons_cons(vector->vals[i], ao_scheme_cons_poly(cons)); - vector = ao_scheme_vector_fetch(); - if (!cons) - return NULL; - } - return cons; -} - -ao_poly -ao_scheme_do_vector(struct ao_scheme_cons *cons) -{ - return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); -} - -ao_poly -ao_scheme_do_make_vector(struct ao_scheme_cons *cons) -{ - int32_t len; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_make2dvector, cons, - AO_SCHEME_INT, &len, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_false, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_vector_poly(ao_scheme_vector_alloc(len, val)); -} - -static bool -ao_scheme_check_vector(ao_poly proc, struct ao_scheme_vector *vector, int32_t offset) -{ - if (offset < 0 || vector->length <= offset) { - (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: vector index %d out of range (max %d)", - proc, - offset, vector->length); - return false; - } - return true; -} - -ao_poly -ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) -{ - struct ao_scheme_vector *vector; - int32_t offset; - - if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dref, cons, - AO_SCHEME_VECTOR, &vector, - AO_SCHEME_INT, &offset, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dref, vector, offset)) - return AO_SCHEME_NIL; - return vector->vals[offset]; -} - -ao_poly -ao_scheme_do_vector_set(struct ao_scheme_cons *cons) -{ - struct ao_scheme_vector *vector; - int32_t offset; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dset21, cons, - AO_SCHEME_VECTOR, &vector, - AO_SCHEME_INT, &offset, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dset21, vector, offset)) - return AO_SCHEME_NIL; - vector->vals[offset] = val; - return val; -} - -ao_poly -ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3evector, cons, - AO_SCHEME_CONS|AO_SCHEME_ARG_NIL_OK, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_vector_poly(ao_scheme_list_to_vector(pair)); -} - -ao_poly -ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) -{ - struct ao_scheme_vector *vector; - int32_t start, end; - - if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons, - AO_SCHEME_VECTOR, &vector, - AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(0), &start, - AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(-1), &end, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (end == -1) - end = vector->length; - return ao_scheme_cons_poly(ao_scheme_vector_to_list(vector, start, end)); -} - -ao_poly -ao_scheme_do_vector_length(struct ao_scheme_cons *cons) -{ - struct ao_scheme_vector *vector; - - if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons, - AO_SCHEME_VECTOR, &vector, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(vector->length); -} - -ao_poly -ao_scheme_do_vectorp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_vector3f, AO_SCHEME_VECTOR, cons); -} - -#endif /* AO_SCHEME_FEATURE_VECTOR */ diff --git a/src/scheme/ao_scheme_vector.scheme b/src/scheme/ao_scheme_vector.scheme deleted file mode 100644 index 6c25aae5..00000000 --- a/src/scheme/ao_scheme_vector.scheme +++ /dev/null @@ -1,192 +0,0 @@ -; -; Copyright © 2018 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; vector functions placed in ROM - - -(define vector->string - (lambda (v . args) - (let ((l 0) - (h (vector-length v))) - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - (do ((s (make-string (- h l))) - (p l (+ p 1)) - ) - ((= p h) s) - (string-set! s (- p l) (vector-ref v p)) - ) - ) - ) - ) - -(vector->string #(#\a #\b #\c) 0 2) - -(define string->vector - (lambda (s . args) - (let ((l 0) - (h (string-length s))) - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - (do ((v (make-vector (- h l))) - (p l (+ p 1)) - ) - ((= p h) v) - (vector-set! v (- p l) (string-ref s p)) - ) - ) - ) - ) - -(string->vector "hello" 0 2) - -(define vector-copy! - (lambda (t a f . args) - (let ((l 0) - (h (vector-length f)) - (o a) - (d 1)) - ; handle optional start/end args - - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - (set! o (- a l)) - ) - ) - ; flip copy order if dst is - ; after src - (if (< l a) - (begin - (set! d h) - (set! h (- l 1)) - (set! l (- d 1)) - (set! d -1) - ) - ) - ; loop copying one at a time - (do ((p l (+ p d)) - ) - ((= p h) t) - (vector-set! t (+ p o) (vector-ref f p)) - ) - ) - ) - ) - - ; simple vector-copy test - -(vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) - -(let ((v (vector 1 2 3 4 5 6 7 8 9 0))) - (vector-copy! v 1 v 0 2) - (display "v ") (write v) (newline) - ) - -(define vector-copy - (lambda (v . args) - (let ((l 0) - (h (vector-length v))) - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - (vector-copy! (make-vector (- h l)) 0 v) - ) - ) - ) - -(vector-copy #(1 2 3) 0 3) - -(define vector-append - (lambda a - (define (_f v a p) - (if (null? a) - v - (begin - (vector-copy! v p (car a)) - (_f v (cdr a) (+ p (vector-length (car a)))) - ) - ) - ) - (_f (make-vector (apply + (map vector-length a))) a 0) - ) - ) - -(vector-append #(1 2 3) #(4 5 6) #(7 8 9)) - -(define vector-fill! - (lambda (v a . args) - (let ((l 0) - (h (vector-length v))) - (cond ((not (null? args)) - (set! l (car args)) - (cond ((not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - ) - (define (_f b) - (cond ((< b h) - (vector-set! v b a) - (_f (+ b 1)) - ) - (else v) - ) - ) - (_f l) - ) - ) - ) - -(vector-fill! (make-vector 3) #t 1 2) - - ; like 'map', but for vectors - -(define vector-map - (lambda (proc . vectors) - ; result length is min of arg lengths - (let* ((l (apply min (map vector-length vectors))) - ; create the result - (v (make-vector l))) - ; walk the vectors, doing evaluation - (define (_m p) - (if (equal? p l) - v - (begin - (vector-set! v p (apply proc (map (lambda (v) (vector-ref v p)) vectors))) - (_m (+ p 1)) - ) - ) - ) - (_m 0) - ) - ) - ) - -(vector-map + #(1 2 3) #(4 5 6)) diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore deleted file mode 100644 index bcd57242..00000000 --- a/src/scheme/make-const/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile deleted file mode 100644 index a8e3a7f5..00000000 --- a/src/scheme/make-const/Makefile +++ /dev/null @@ -1,26 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath %.h .. - -SRCS=$(SCHEME_SRCS) ao_scheme_make_const.c -HDRS=$(SCHEME_HDRS) ao_scheme_os.h - -OBJS=$(SRCS:.c=.o) - -CC=cc -CFLAGS=-DAO_SCHEME_MAKE_CONST -O0 -g -I. -Wall -Wextra -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -.c.o: - $(CC) -c $(CFLAGS) $< -o $@ - -all: ao_scheme_make_const - -ao_scheme_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $^ -lm - -clean: - rm -f $(OBJS) ao_scheme_make_const - -$(OBJS): $(SCHEME_HDRS) diff --git a/src/scheme/make-const/ao_scheme_os.h b/src/scheme/make-const/ao_scheme_os.h deleted file mode 100644 index f06bbbb1..00000000 --- a/src/scheme/make-const/ao_scheme_os.h +++ /dev/null @@ -1,63 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include -#include -#include - -extern int ao_scheme_getc(void); - -static inline void -ao_scheme_os_flush(void) { - fflush(stdout); -} - -static inline void -ao_scheme_abort(void) -{ - abort(); -} - -static inline void -ao_scheme_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND 100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_scheme_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} -#endif diff --git a/src/scheme/test/.gitignore b/src/scheme/test/.gitignore deleted file mode 100644 index 3622bc1d..00000000 --- a/src/scheme/test/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao-scheme diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile deleted file mode 100644 index a8129217..00000000 --- a/src/scheme/test/Makefile +++ /dev/null @@ -1,33 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath %.h .. -vpath %.scheme .. -vpath ao_scheme_make_const ../make-const - -SRCS=$(SCHEME_SRCS) ao_scheme_test.c -HDRS=$(SCHEME_HDRS) ao_scheme_const.h - -OBJS=$(SRCS:.c=.o) - -#PGFLAGS=-pg -no-pie -OFLAGS=-O3 -#DFLAGS=-O0 - -CFLAGS=$(DFLAGS) $(OFLAGS) $(PGFLAGS) -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -ao-scheme: $(OBJS) - cc $(CFLAGS) -o $@ $(OBJS) -lm - ./ao-scheme ao_scheme_test.scheme - -$(OBJS): $(HDRS) - -ao_scheme_const.h: ao_scheme_make_const $(SCHEME_SCHEME) - $^ -o $@ -d GPIO - -clean:: - rm -f $(OBJS) ao-scheme ao_scheme_const.h - -install: ao-scheme - install -t $$HOME/bin $^ diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h deleted file mode 100644 index 9836d534..00000000 --- a/src/scheme/test/ao_scheme_os.h +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include -#include -#include - -#define AO_SCHEME_POOL_TOTAL 32768 - -static inline void -ao_scheme_abort(void) -{ - abort(); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND 100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_scheme_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c deleted file mode 100644 index 195b8b46..00000000 --- a/src/scheme/test/ao_scheme_test.c +++ /dev/null @@ -1,188 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" -#include -#include -#include - -static char save_file[] = "scheme.image"; - -int -ao_scheme_os_save(void) -{ - FILE *save = fopen(save_file, "w"); - - if (!save) { - perror(save_file); - return 0; - } - fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); - fclose(save); - return 1; -} - -int -ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - fseek(restore, offset, SEEK_SET); - ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); - fclose(restore); - if (ret != 1) - return 0; - return 1; -} - -int -ao_scheme_os_restore(void) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); - fclose(restore); - if (ret != AO_SCHEME_POOL_TOTAL) - return 0; - return 1; -} - -static const struct option options[] = { - { .name = "load", .has_arg = 1, .val = 'l' }, - { 0, 0, 0, 0 }, -}; - -static void usage(char *program) -{ - fprintf(stderr, "usage: %s [--load= ...] \n", program); -} - -static void -check_exit(ao_poly v) -{ - if (ao_scheme_exception & AO_SCHEME_EXIT) { - int ret; - - if (v == _ao_scheme_bool_true) - ret = 0; - else { - ret = 1; - if (ao_scheme_is_integer(v)) - ret = ao_scheme_poly_integer(v); - } - exit(ret); - } -} - -static void -run_file(char *name) -{ - FILE *in; - int c; - ao_poly v; - - in = fopen(name, "r"); - if (!in) { - perror(name); - exit(1); - } - c = getc(in); - if (c == '#') { - do { - c = getc(in); - } while (c != EOF && c != '\n'); - } else { - ungetc(c, in); - } - v = ao_scheme_read_eval_print(in, NULL, false); - fclose(in); - check_exit(v); -} - -int -main (int argc, char **argv) -{ - int o; - - while ((o = getopt_long(argc, argv, "?l:", options, NULL)) != -1) { - switch (o) { - case '?': - usage(argv[0]); - exit(0); - case 'l': -#ifdef AO_SCHEME_FEATURE_POSIX - ao_scheme_set_argv(&argv[argc]); -#endif - run_file(optarg); - break; - default: - usage(argv[0]); - exit(1); - } - } -#ifdef AO_SCHEME_FEATURE_POSIX - ao_scheme_set_argv(argv + optind); -#endif - if (argv[optind]) { - run_file(argv[optind]); - } else { - ao_poly v; - v = ao_scheme_read_eval_print(stdin, stdout, true); - check_exit(v); - putchar('\n'); - } - -#ifdef DBG_MEM_STATS - printf ("collects: full: %lu incremental %lu\n", - ao_scheme_collects[AO_SCHEME_COLLECT_FULL], - ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf ("freed: full %lu incremental %lu\n", - ao_scheme_freed[AO_SCHEME_COLLECT_FULL], - ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("loops: full %lu incremental %lu\n", - ao_scheme_loops[AO_SCHEME_COLLECT_FULL], - ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("loops per collect: full %f incremental %f\n", - (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], - (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("freed per collect: full %f incremental %f\n", - (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], - (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("freed per loop: full %f incremental %f\n", - (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / - (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL], - (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / - (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); -#endif - return 0; -} diff --git a/src/scheme/test/ao_scheme_test.scheme b/src/scheme/test/ao_scheme_test.scheme deleted file mode 100644 index 41aaeda1..00000000 --- a/src/scheme/test/ao_scheme_test.scheme +++ /dev/null @@ -1,175 +0,0 @@ - ; Basic syntax tests - -(define _assert-eq_ - (macro (a b) - (list cond - (list (list eq? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(define _assert-equal_ - (macro (a b) - (list cond - (list (list equal? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(_assert-eq_ (or #f #t) #t) -(_assert-eq_ (and #t #f) #f) -(_assert-eq_ (if (> 3 2) 'yes) 'yes) -(_assert-eq_ (if (> 3 2) 'yes 'no) 'yes) -(_assert-eq_ (if (> 2 3) 'no 'yes) 'yes) -(_assert-eq_ (if (> 2 3) 'no) #f) - -(_assert-eq_ (letrec ((a 1) (b a)) (+ a b)) 2) - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) - -(_assert-equal_ (cdar '((1 2) (3 4))) '(2)) - -(_assert-equal_ (cddr '(1 2 3)) '(3)) - -(_assert-equal_ (caddr '(1 2 3 4)) 3) - -(_assert-equal_ (member '(2) '((1) (2) (3))) '((2) (3))) -(_assert-equal_ (member '(4) '((1) (2) (3))) #f) - -(_assert-equal_ (memq 2 '(1 2 3)) '(2 3)) -(_assert-equal_ (memq 4 '(1 2 3)) #f) -(_assert-equal_ (memq '(2) '((1) (2) (3))) #f) - -(_assert-equal_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_assert-equal_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2)) -(_assert-equal_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(_assert-equal_ (map cadr '((a b) (d e) (g h))) '(b e h)) - -(_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) - - ; Advanced syntax tests - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) -(_assert-eq_ (equal? #(1 2 3) #(1 2 3)) #t) -(_assert-eq_ (equal? #(1 2 3) #(4 5 6)) #f) -(_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) -(_assert-equal_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) -(_assert-equal_ (when #t (+ 1 2)) 3) -(_assert-equal_ (when #f (+ 1 2)) #f) -(_assert-equal_ (unless #f (+ 2 3)) 5) -(_assert-equal_ (unless #t (+ 2 3)) #f) -(_assert-equal_ (cdar '((1 2) (3 4))) '(2)) -(_assert-equal_ (cddr '(1 2 3)) '(3)) -(_assert-equal_ (caddr '(1 2 3 4)) 3) -(_assert-equal_ (reverse '(1 2 3)) '(3 2 1)) -(_assert-equal_ (make-list 10 'a) '(a a a a a a a a a a)) -(_assert-equal_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) -(_assert-equal_ (let ((a 0)) - (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) - a - ) - 6) -(_assert-equal_ (call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - ) - ) - -3) -(_assert-equal_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "one") -(_assert-equal_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "two") -(_assert-equal_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "three") -(_assert-equal_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "else") -(_assert-equal_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "twelve") -(_assert-equal_ (do ((x 1 (+ x 1)) - (y 0) - ) - ((= x 10) y) - (set! y (+ y x)) - ) - 45) - -(_assert-equal_ (do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i)) - #(0 1 2 3 4)) - - ; vector tests - -(_assert-equal_ (vector->string #(#\a #\b #\c) 0 2) "ab") -(_assert-equal_ (string->vector "hello" 0 2) #(#\h #\e)) -(_assert-equal_ (vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t")) -(_assert-equal_ (vector-copy #(1 2 3) 0 3) #(1 2 3)) -(_assert-equal_ (vector-append #(1 2 3) #(4 5 6) #(7 8 9)) #(1 2 3 4 5 6 7 8 9)) -(_assert-equal_ (vector-fill! (make-vector 3) #t 1 2) #(#f #t #f)) -(_assert-equal_ (vector-map + #(1 2 3) #(4 5 6)) #(5 7 9)) - - ; string tests - -(_assert-equal_ (string #\a #\b #\c) "abc") -(_assert-equal_ (string-map (lambda (x) (+ 1 x)) "HAL") "IBM") -(_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello ") -(_assert-equal_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello ") -(_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello ") -(_assert-equal_ (string-copy "hello" 0 1) "h") -(_assert-equal_ (string-copy "hello" 1) "ello") -(_assert-equal_ (string-copy "hello") "hello") -(_assert-equal_ (string-fill! (make-string 10) #\a) "aaaaaaaaaa") -(_assert-equal_ (string-fill! (make-string 10) #\a 1 2) " a ") -;(_assert-equal_ (string-for-each write-char "IBM\n") #t) - - ; char tests - -(_assert-equal_ (char? #\q) #t) -(_assert-equal_ (char? "h") #f) -(_assert-equal_ (char-upper-case? #\a) #f) -(_assert-equal_ (char-upper-case? #\B) #t) -(_assert-equal_ (char-upper-case? #\0) #f) -(_assert-equal_ (char-upper-case? #\space) #f) -(_assert-equal_ (char-lower-case? #\a) #t) -(_assert-equal_ (char-lower-case? #\B) #f) -(_assert-equal_ (char-lower-case? #\0) #f) -(_assert-equal_ (char-lower-case? #\space) #f) -(_assert-equal_ (char-alphabetic? #\a) #t) -(_assert-equal_ (char-alphabetic? #\B) #t) -(_assert-equal_ (char-alphabetic? #\0) #f) -(_assert-equal_ (char-alphabetic? #\space) #f) -(_assert-equal_ (char-numeric? #\a) #f) -(_assert-equal_ (char-numeric? #\B) #f) -(_assert-equal_ (char-numeric? #\0) #t) -(_assert-equal_ (char-numeric? #\space) #f) -(_assert-equal_ (char-whitespace? #\a) #f) -(_assert-equal_ (char-whitespace? #\B) #f) -(_assert-equal_ (char-whitespace? #\0) #f) -(_assert-equal_ (char-whitespace? #\space) #t) -(_assert-equal_ (char-upcase #\a) #\A) -(_assert-equal_ (char-upcase #\B) #\B) -(_assert-equal_ (char-upcase #\0) #\0) -(_assert-equal_ (char-upcase #\space) #\space) -(_assert-equal_ (char-downcase #\a) #\a) -(_assert-equal_ (char-downcase #\B) #\b) -(_assert-equal_ (char-downcase #\0) #\0) -(_assert-equal_ (char-downcase #\space) #\space) -(_assert-equal_ (digit-value #\1) 1) -(_assert-equal_ (digit-value #\a) #f) - diff --git a/src/scheme/test/hanoi.scheme b/src/scheme/test/hanoi.scheme deleted file mode 100755 index 0180de1e..00000000 --- a/src/scheme/test/hanoi.scheme +++ /dev/null @@ -1,177 +0,0 @@ -#!/home/keithp/bin/ao-scheme -; -; Towers of Hanoi -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; - - ; ANSI control sequences - -(define (move-to col row) - (for-each display (list "\033[" row ";" col "H")) - ) - -(define (clear) - (display "\033[2J") - ) - -(define (display-string x y str) - (move-to x y) - (display str) - ) - -(define (make-piece num max) - ; A piece for position 'num' - ; is num + 1 + num stars - ; centered in a field of max * - ; 2 + 1 characters with spaces - ; on either side. This way, - ; every piece is the same - ; number of characters - - (define (chars n c) - (if (zero? n) "" - (+ c (chars (- n 1) c)) - ) - ) - (+ (chars (- max num 1) " ") - (chars (+ (* num 2) 1) "*") - (chars (- max num 1) " ") - ) - ) - -(define (make-pieces max) - ; Make a list of numbers from 0 to max-1 - (define (nums cur max) - (if (= cur max) () - (cons cur (nums (+ cur 1) max)) - ) - ) - ; Create a list of pieces - - (map (lambda (x) (make-piece x max)) (nums 0 max)) - ) - - ; Here's all of the towers of pieces - ; This is generated when the program is run - -(define towers ()) - - ; position of the bottom of - ; the stacks set at runtime -(define bottom-y 0) -(define left-x 0) - -(define move-delay 25) - - ; Display one tower, clearing any - ; space above it - -(define (display-tower x y clear tower) - (cond ((= 0 clear) - (cond ((not (null? tower)) - (display-string x y (car tower)) - (display-tower x (+ y 1) 0 (cdr tower)) - ) - ) - ) - (else - (display-string x y " ") - (display-tower x (+ y 1) (- clear 1) tower) - ) - ) - ) - - ; Position of the top of the tower on the screen - ; Shorter towers start further down the screen - -(define (tower-pos tower) - (- bottom-y (length tower)) - ) - - ; Display all of the towers, spaced 20 columns apart - -(define (display-towers x towers) - (cond ((not (null? towers)) - (display-tower x 0 (tower-pos (car towers)) (car towers)) - (display-towers (+ x 20) (cdr towers))) - ) - ) - - ; Display all of the towers, then move the cursor - ; out of the way and flush the output - -(define (display-hanoi) - (display-towers left-x towers) - (move-to 1 23) - (flush-output) - (delay move-delay) - ) - - ; Reset towers to the starting state, with - ; all of the pieces in the first tower and the - ; other two empty - -(define (reset-towers len) - (set! towers (list (make-pieces len) () ())) - (set! bottom-y (+ len 3)) - ) - - ; Move a piece from the top of one tower - ; to the top of another - -(define (move-piece from to) - - ; references to the cons holding the two towers - - (define from-tower (list-tail towers from)) - (define to-tower (list-tail towers to)) - - ; stick the car of from-tower onto to-tower - - (set-car! to-tower (cons (caar from-tower) (car to-tower))) - - ; remove the car of from-tower - - (set-car! from-tower (cdar from-tower)) - ) - - ; The implementation of the game - -(define (_hanoi n from to use) - (cond ((= 1 n) - (move-piece from to) - (display-hanoi) - ) - (else - (_hanoi (- n 1) from use to) - (_hanoi 1 from to use) - (_hanoi (- n 1) use to from) - ) - ) - ) - - ; A pretty interface which - ; resets the state of the game, - ; clears the screen and runs - ; the program - -(define (hanoi len) - (reset-towers len) - (clear) - (display-hanoi) - (_hanoi len 0 1 2) - #t - ) - -(unless (null? (command-line)) (hanoi 6)) diff --git a/src/scheme/tiny-test/.gitignore b/src/scheme/tiny-test/.gitignore deleted file mode 100644 index 7c4c3956..00000000 --- a/src/scheme/tiny-test/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao-scheme-tiny diff --git a/src/scheme/tiny-test/Makefile b/src/scheme/tiny-test/Makefile deleted file mode 100644 index 61ef687a..00000000 --- a/src/scheme/tiny-test/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath ao_scheme_test.c ../test -vpath %.h .. -vpath %.scheme .. -vpath ao_scheme_make_const ../make-const - -DEFS= - -SRCS=$(SCHEME_SRCS) ao_scheme_test.c -HDRS=$(SCHEME_HDRS) ao_scheme_const.h - -OBJS=$(SRCS:.c=.o) - -CFLAGS=-O0 -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -ao-scheme-tiny: $(OBJS) - cc $(CFLAGS) -o $@ $(OBJS) -lm - ./ao-scheme-tiny ao_scheme_tiny_test.scheme - -$(OBJS): $(HDRS) - -ao_scheme_const.h: ao_scheme_make_const ao_scheme_basic_syntax.scheme ao_scheme_finish.scheme - $^ -o $@ -d FLOAT,VECTOR,QUASI,BIGINT,PORT,POSIX,GPIO,UNDEF - -clean:: - rm -f $(OBJS) ao-scheme-tiny ao_scheme_const.h - -install: ao-scheme-tiny - cp $^ $$HOME/bin diff --git a/src/scheme/tiny-test/ao_scheme_os.h b/src/scheme/tiny-test/ao_scheme_os.h deleted file mode 100644 index 17d66ae3..00000000 --- a/src/scheme/tiny-test/ao_scheme_os.h +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include -#include -#include - -#define AO_SCHEME_POOL_TOTAL 4096 - -static inline void -ao_scheme_abort(void) -{ - abort(); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND 100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_scheme_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/scheme/tiny-test/ao_scheme_tiny_const.scheme b/src/scheme/tiny-test/ao_scheme_tiny_const.scheme deleted file mode 100644 index d0c0e578..00000000 --- a/src/scheme/tiny-test/ao_scheme_tiny_const.scheme +++ /dev/null @@ -1,389 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (a b) - (list - def - (list quote a) - b) - ) - ) - -(begin - (def! append - (lambda args - (def! a-l - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (a-l (cdr a) b))) - ) - ) - ) - - (def! a-ls - (lambda (l) - (cond ((null? l) l) - ((null? (cdr l)) (car l)) - (else (a-l (car l) (a-ls (cdr l)))) - ) - ) - ) - (a-ls args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name a y z) sexprs ...) - ; - -(begin - (def (quote define) - (macro (a . b) - ; check for alternate lambda definition form - - (cond ((list? a) - (set! b - (cons lambda (cons (cdr a) b))) - (set! a (car a)) - ) - (else - (set! b (car b)) - ) - ) - (cons begin - (cons - (cons def - (cons (cons quote (cons a '())) - (cons b '()) - ) - ) - (cons - (cons quote (cons a '())) - '()) - ) - ) - ) - ) - 'define - ) - - ; basic list accessors - -(define (caar l) (car (car l))) - -(define (cadr l) (car (cdr l))) - -(define (cdar l) (cdr (car l))) - -(define (caddr l) (car (cdr (cdr l)))) - - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - - ; simple math operators - -(define zero? (macro (value) (list eqv? value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) (list > value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) (list < value 0))) - -(negative? 12) -(negative? -12) - -(define (abs a) (if (>= a 0) a (- a))) - -(abs 12) -(abs -12) - -(define max (lambda (a . b) - (while (not (null? b)) - (cond ((< a (car b)) - (set! a (car b))) - ) - (set! b (cdr b)) - ) - a) - ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (a . b) - (while (not (null? b)) - (cond ((> a (car b)) - (set! a (car b))) - ) - (set! b (cdr b)) - ) - a) - ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? a) (zero? (% a 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? a) (not (even? a))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - - -(define (list-tail a b) - (if (zero? b) - a - (list-tail (cdr a (- b 1))) - ) - ) - -(define (list-ref a b) - (car (list-tail a b)) - ) - -(define (list-tail a b) - (if (zero? b) - a - (list-tail (cdr a) (- b 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref a b) (car (list-tail a b))) - -(list-ref '(1 2 3) 2) - - - ; define a set of local - ; variables one at a time and - ; then evaluate a list of - ; sexprs - ; - ; (let* (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let* ((x 1) (y)) (set! y (+ x 1)) y) - -(define let* - (macro (a . b) - - ; - ; make the list of names in the let - ; - - (define (_n a) - (cond ((not (null? a)) - (cons (car (car a)) - (_n (cdr a)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (_v a b) - (cond ((null? a) b) (else - (cons - (list set - (list quote - (car (car a)) - ) - (cond ((null? (cdr (car a))) ()) - (else (cadr (car a)))) - ) - (_v (cdr a) b) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (_z a) - (cond ((null? a) ()) - (else (cons () (_z (cdr a)))) - ) - ) - ; build the lambda. - - (cons (cons lambda (cons (_n a) (_v a b))) (_z a)) - ) - ) - -(let* ((a 1) (y a)) (+ a y)) - -(define let let*) - ; recursive equality - -(define (equal? a b) - (cond ((eq? a b) #t) - ((pair? a) - (cond ((pair? b) - (cond ((equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - ) - ) - ) - ) - ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) - -(define member (lambda (obj a . test?) - (cond ((null? a) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car a)) - a - (member obj (cdr a) test?)) - ) - ) - ) - ) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) - -(define (memq obj a) (member obj a eq?)) - -(memq 2 '(1 2 3)) - -(memq 4 '(1 2 3)) - -(memq '(2) '((1) (2) (3))) - -(define (_assoc a b t?) - (if (null? b) - #f - (if (t? a (caar b)) - (car b) - (_assoc a (cdr b) t?) - ) - ) - ) - -(define (assq a b) (_assoc a b eq?)) -(define (assoc a b) (_assoc a b equal?)) - -(assq 'a '((a 1) (b 2) (c 3))) -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define string (lambda a (list->string a))) - -(display "apply\n") -(apply cons '(a b)) - -(define map - (lambda (a . b) - (define (args b) - (cond ((null? b) ()) - (else - (cons (caar b) (args (cdr b))) - ) - ) - ) - (define (next b) - (cond ((null? b) ()) - (else - (cons (cdr (car b)) (next (cdr b))) - ) - ) - ) - (define (domap b) - (cond ((null? (car b)) ()) - (else - (cons (apply a (args b)) (domap (next b))) - ) - ) - ) - (domap b) - ) - ) - -(map cadr '((a b) (d e) (g h))) - -(define for-each (lambda (a . b) - (apply map a b) - #t)) - -(for-each display '("hello" " " "world" "\n")) - -(define (newline) (write-char #\newline)) - -(newline) diff --git a/src/scheme/tiny-test/ao_scheme_tiny_test.scheme b/src/scheme/tiny-test/ao_scheme_tiny_test.scheme deleted file mode 100644 index 94c90ffe..00000000 --- a/src/scheme/tiny-test/ao_scheme_tiny_test.scheme +++ /dev/null @@ -1,56 +0,0 @@ - ; Basic syntax tests - -(define _assert-eq_ - (macro (a b) - (list cond - (list (list eq? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(define _assert-equal_ - (macro (a b) - (list cond - (list (list equal? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(_assert-eq_ (or #f #t) #t) -(_assert-eq_ (and #t #f) #f) -(_assert-eq_ (if (> 3 2) 'yes) 'yes) -(_assert-eq_ (if (> 3 2) 'yes 'no) 'yes) -(_assert-eq_ (if (> 2 3) 'no 'yes) 'yes) -(_assert-eq_ (if (> 2 3) 'no) #f) - -(_assert-eq_ (letrec ((a 1) (b a)) (+ a b)) 2) - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) - -(_assert-equal_ (member '(2) '((1) (2) (3))) '((2) (3))) -(_assert-equal_ (member '(4) '((1) (2) (3))) #f) - -(_assert-equal_ (memq 2 '(1 2 3)) '(2 3)) -(_assert-equal_ (memq 4 '(1 2 3)) #f) -(_assert-equal_ (memq '(2) '((1) (2) (3))) #f) - -(_assert-equal_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_assert-equal_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(_assert-equal_ (map cadr '((a b) (d e) (g h))) '(b e h)) - diff --git a/src/stmf0/Makefile-stmf0.defs b/src/stmf0/Makefile-stmf0.defs index fa6e6e86..4e9fa551 100644 --- a/src/stmf0/Makefile-stmf0.defs +++ b/src/stmf0/Makefile-stmf0.defs @@ -4,7 +4,7 @@ endif include $(TOPDIR)/Makedefs -vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math:$(TOPDIR)/scheme +vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math vpath make-altitude $(TOPDIR)/util vpath make-kalman $(TOPDIR)/util vpath kalman.5c $(TOPDIR)/kalman -- cgit v1.2.3