From d95486be96fe989f6984b3452c5c5d92897c5606 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Thu, 21 Dec 2017 20:40:28 -0700 Subject: update Releasing with wisdom from 1.8.4 release process --- Releasing | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Releasing b/Releasing index 9a295f03..ae3dd038 100644 --- a/Releasing +++ b/Releasing @@ -32,6 +32,8 @@ These are Bdale's notes on how to do a release. - make sure build environment is up to date sudo cowbuilder --update + - make sure ~/web/altusmetrum has no pending pullable commits + git checkout master - update the version in configure.ac if Keith hasn't already -- cgit v1.2.3 From 7b5892f75a75363a656ede8befb419245aa218b5 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 24 Dec 2017 14:28:29 -0800 Subject: altos/scheme: Add separate floor-quotient builtin Does what 'quotient' did before, now quotient rounds towards zero while floor-quotient rounds down. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 12 ++++++++++++ src/scheme/ao_scheme_builtin.txt | 1 + 2 files changed, 13 insertions(+) diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 81fd9010..e2532c98 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -393,6 +393,11 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) 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 @@ -436,6 +441,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) 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"); @@ -491,6 +497,12 @@ 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) { diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index 23adf6ed..bdadbd6a 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -31,6 +31,7 @@ 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>? -- cgit v1.2.3 From fc63968f90e3fab12e63d973a4ee7f16d80d765f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 24 Dec 2017 14:29:09 -0800 Subject: altos/scheme: Pull out per-frame vals while printing list of frames Was using the same vals for all frames, which just doesn't work well. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_frame.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index 16da62fb..9ae5bb72 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -153,12 +153,13 @@ ao_scheme_frame_write(ao_poly p, bool write) { struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); struct ao_scheme_frame *clear = frame; - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); 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) printf(", "); if (ao_scheme_print_mark_addr(frame)) { -- cgit v1.2.3 From 365eee3ebfe73204033089b363687228f97e5d98 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Wed, 3 Jan 2018 14:43:29 -0600 Subject: need to push telegps-v2.0 loader .bin file to corporate repo, too --- Releasing | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Releasing b/Releasing index ae3dd038..7908a064 100644 --- a/Releasing +++ b/Releasing @@ -122,7 +122,7 @@ These are Bdale's notes on how to do a release. src/telebt-v4.0/flash-loader/{*.elf,*.bin} \ src/teledongle-v3.0/flash-loader/*.elf \ src/telegps-v1.0/flash-loader/*.elf \ - src/telegps-v2.0/flash-loader/*.elf \ + src/telegps-v2.0/flash-loader/{*.elf,*.bin} \ src/telemega-v1.0/flash-loader/*.elf \ src/telemega-v2.0/flash-loader/*.elf \ src/telemega-v3.0/flash-loader/*.elf \ -- cgit v1.2.3 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 +++++++++++++++++++++++++++++++++++---------- src/scheme/ao_scheme_read.h | 3 ++- 2 files changed, 44 insertions(+), 13 deletions(-) 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) { diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index 1aa11a3a..d0b9b36a 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -65,10 +65,11 @@ # define IGNORE 0x0200 /* \0 - ' ' */ # define BACKSLASH 0x0400 /* \ */ # define STRINGC 0x0800 /* " */ -# define POUND 0x1000 /* # */ +# define HEX_LETTER 0x1000 /* 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_ */ -- cgit v1.2.3 From b7c34a2e5ecff19d61d337b8c84976cc46005ec4 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 3 Jan 2018 14:55:24 -0800 Subject: altos/scheme: support %x format for scheme printf read debugging uses this format. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_error.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c index 6a71ca51..6ca63f75 100644 --- a/src/scheme/ao_scheme_error.c +++ b/src/scheme/ao_scheme_error.c @@ -35,6 +35,9 @@ ao_scheme_vprintf(const char *format, va_list args) case 'd': printf("%d", va_arg(args, int)); break; + case 'x': + printf("%x", va_arg(args, int)); + break; case 's': printf("%s", va_arg(args, char *)); break; -- 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(-) 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 7bfc1eda398e8767e352cd6396ac61c7ea021079 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 3 Jan 2018 14:57:39 -0800 Subject: altos/scheme: Add start/end args to vector->list This is an r7rs extension which allows you to extract a subset of the vector. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 2 +- src/scheme/ao_scheme_builtin.c | 46 +++++++++++++++++++++++++++++++++--------- src/scheme/ao_scheme_vector.c | 12 ++++++++--- 3 files changed, 47 insertions(+), 13 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index d4c9bc05..428533b0 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -808,7 +808,7 @@ 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); +ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end); extern const struct ao_scheme_type ao_scheme_vector_type; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index e2532c98..0da68778 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -105,17 +105,23 @@ ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max return _ao_scheme_bool_true; } -ao_poly -ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +static ao_poly +ao_scheme_opt_arg(struct ao_scheme_cons *cons, int argc, ao_poly def) { - if (!cons) - return AO_SCHEME_NIL; - while (argc--) { + for (;;) { if (!cons) - return AO_SCHEME_NIL; + return def; + if (argc == 0) + return cons->car; cons = ao_scheme_cons_cdr(cons); + argc--; } - return cons->car; +} + +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +{ + return ao_scheme_opt_arg(cons, argc, AO_SCHEME_NIL); } ao_poly @@ -140,6 +146,18 @@ ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc) 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) { @@ -1120,11 +1138,21 @@ ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) { - if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) + int start, end; + + 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; - return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)))); + start = ao_scheme_opt_arg_int(_ao_scheme_atom_vector2d3elist, cons, 1, ao_scheme_int_poly(0)); + if (ao_scheme_exception) + 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)); } ao_poly diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index afdc89a8..083823f3 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -159,13 +159,19 @@ ao_scheme_list_to_vector(struct ao_scheme_cons *cons) } struct ao_scheme_cons * -ao_scheme_vector_to_list(struct ao_scheme_vector *vector) +ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end) { - unsigned int i; + int i; uint16_t length = vector->length; struct ao_scheme_cons *cons = NULL; - for (i = length; i-- > 0;) { + 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(); -- cgit v1.2.3 From 637795fcf8ca52af431acec183cc961dae121e57 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 3 Jan 2018 14:58:57 -0800 Subject: altos/scheme: Make for-each tail recursive Provides a native version of for-each that is tail recursive, rather than having it just use map and discard the return value. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_const.scheme | 48 ++++++++++++++++++++++++--------------- 1 file changed, 30 insertions(+), 18 deletions(-) diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme index 4616477f..29f000b3 100644 --- a/src/scheme/ao_scheme_const.scheme +++ b/src/scheme/ao_scheme_const.scheme @@ -512,12 +512,13 @@ (unless #f (write 'unless)) (define (reverse list) - (let ((result ())) - (while (not (null? list)) - (set! result (cons (car list) result)) - (set! list (cdr list)) - ) - result) + (define (_r old new) + (if (null? old) + new + (_r (cdr old) (cons (car old) new)) + ) + ) + (_r list ()) ) (reverse '(1 2 3)) @@ -664,36 +665,46 @@ (define map (lambda (proc . lists) - (define (args lists) + (define (_a lists) (cond ((null? lists) ()) (else - (cons (caar lists) (args (cdr lists))) + (cons (caar lists) (_a (cdr lists))) ) ) ) - (define (next lists) + (define (_n lists) (cond ((null? lists) ()) (else - (cons (cdr (car lists)) (next (cdr lists))) + (cons (cdr (car lists)) (_n (cdr lists))) ) ) ) - (define (domap lists) + (define (_m lists) (cond ((null? (car lists)) ()) (else - (cons (apply proc (args lists)) (domap (next lists))) + (cons (apply proc (_a lists)) (_m (_n lists))) ) ) ) - (domap lists) + (_m lists) ) ) (map cadr '((a b) (d e) (g h))) -(define for-each (lambda (proc . lists) - (apply map proc lists) - #t)) +(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) + ) + ) (for-each display '("hello" " " "world" "\n")) @@ -708,8 +719,9 @@ (string-map (lambda (x) (+ 1 x)) "HAL") -(define string-for-each (lambda (proc . strings) - (apply for-each proc (_string-ml strings)))) +(define string-for-each + (lambda (proc . strings) + (apply for-each proc (_string-ml strings)))) (string-for-each write-char "IBM\n") -- cgit v1.2.3 From 0a0327330dcbf5531cd0f8ca8b912fa51ef44f13 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 4 Jan 2018 02:22:02 -0800 Subject: altos/scheme: Make constant built pool as large as possible This allows building with as much constant data as will fit. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 428533b0..34fb2e88 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -71,7 +71,7 @@ ao_scheme_os_restore(void); #endif #ifdef AO_SCHEME_MAKE_CONST -#define AO_SCHEME_POOL_CONST 16384 +#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 -- cgit v1.2.3 From 036a5311cbc86dbc5a8f859778d52d588915e4e2 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 4 Jan 2018 02:23:40 -0800 Subject: altos/scheme: add make-string builtin Allocate a blank string. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 5 ++++- src/scheme/ao_scheme_builtin.c | 30 ++++++++++++++++++++++++++---- src/scheme/ao_scheme_builtin.txt | 1 + src/scheme/ao_scheme_string.c | 38 ++++++++++++++++++++++++++++++++++---- 4 files changed, 65 insertions(+), 9 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 34fb2e88..68803462 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -710,7 +710,10 @@ struct ao_scheme_string * ao_scheme_string_copy(struct ao_scheme_string *a); struct ao_scheme_string * -ao_scheme_string_make(char *a); +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); diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 0da68778..0b84a89a 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -762,17 +762,39 @@ ao_scheme_do_string_set(struct ao_scheme_cons *cons) 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) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", - _ao_scheme_atom_string2dset21, - ao_scheme_arg(cons, 0), - ao_scheme_arg(cons, 1)); + 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 diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index bdadbd6a..4739f121 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -63,6 +63,7 @@ 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? all lambda apply all f_lambda read_char read-char diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index dfc74966..2c636d7a 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -51,6 +51,7 @@ ao_scheme_string_alloc(int len) if (!s) return NULL; s->type = AO_SCHEME_STRING; + s->val[len] = '\0'; return s; } @@ -70,7 +71,19 @@ ao_scheme_string_copy(struct ao_scheme_string *a) } struct ao_scheme_string * -ao_scheme_string_make(char *a) +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) { struct ao_scheme_string *r; @@ -138,7 +151,6 @@ ao_scheme_string_pack(struct ao_scheme_cons *cons) return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); cons = ao_scheme_cons_cdr(cons); } - *rval++ = 0; return ao_scheme_string_poly(r); } @@ -183,14 +195,32 @@ ao_scheme_string_write(ao_poly p, bool write) putchar('"'); while ((c = *sval++)) { switch (c) { + case '\a': + printf("\\a"); + break; + case '\b': + printf("\\b"); + break; + case '\t': + printf ("\\t"); + break; case '\n': printf ("\\n"); break; case '\r': printf ("\\r"); break; - case '\t': - printf ("\\t"); + case '\f': + printf("\\f"); + break; + case '\v': + printf("\\v"); + break; + case '\"': + printf("\\\""); + break; + case '\\': + printf("\\\\"); break; default: if (c < ' ') -- cgit v1.2.3 From e030fba5ab556c88af918d08e1b62e63d6605638 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 4 Jan 2018 02:24:15 -0800 Subject: altos/scheme: Fix macro-detection debugging Just update to use ao_scheme_printf Signed-off-by: Keith Packard --- src/scheme/ao_scheme_make_const.c | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c index e34792c4..ae3afaa3 100644 --- a/src/scheme/ao_scheme_make_const.c +++ b/src/scheme/ao_scheme_make_const.c @@ -125,9 +125,9 @@ ao_scheme_macro_pop(void) #define DBG_MACRO 0 #if DBG_MACRO -int macro_scan_depth; +static int macro_scan_depth; -void indent(void) +static void indent(void) { int i; for (i = 0; i < macro_scan_depth; i++) @@ -157,7 +157,7 @@ ao_is_macro(ao_poly p) struct ao_scheme_lambda *lambda; ao_poly ret; - MACRO_DEBUG(indent(); printf ("is macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + 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)) @@ -192,7 +192,7 @@ ao_is_macro(ao_poly p) ret = AO_SCHEME_NIL; break; } - MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_scheme_poly_write(ret); printf("\n")); + MACRO_DEBUG(--macro_scan_depth; indent(); ao_scheme_printf ("... %v\n", ret);); return ret; } @@ -207,11 +207,11 @@ ao_has_macro(ao_poly p) if (p == AO_SCHEME_NIL) return AO_SCHEME_NIL; - MACRO_DEBUG(indent(); printf("has macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + 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(lambda->code); + p = ao_has_macro(ao_scheme_poly_cons(lambda->code)->cdr); break; case AO_SCHEME_CONS: cons = ao_scheme_poly_cons(p); @@ -235,7 +235,7 @@ ao_has_macro(ao_poly p) p = AO_SCHEME_NIL; break; } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_scheme_poly_write(p); printf("\n")); + MACRO_DEBUG(--macro_scan_depth; indent(); ao_scheme_printf("... %v\n", p)); return p; } @@ -424,16 +424,18 @@ main(int argc, char **argv) a = ao_scheme_atom_intern((char *) atoms[an].name); } - if (argv[optind]){ + while (argv[optind]) { in = fopen(argv[optind], "r"); if (!in) { perror(argv[optind]); exit(1); } - } - if (!ao_scheme_read_eval_abort()) { - fprintf(stderr, "eval failed\n"); - exit(1); + if (!ao_scheme_read_eval_abort()) { + fprintf(stderr, "eval failed\n"); + exit(1); + } + fclose(in); + optind++; } /* Reduce to referenced values */ -- cgit v1.2.3 From a6e01e7aafb1d1fdb15d633ec23d8fe51afd15df Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 4 Jan 2018 02:25:45 -0800 Subject: altos/scheme: Add builtin list-tail This is used enough to warrant a builtin, rather than lisp implementation Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 25 +++++++++++++++++++++++++ src/scheme/ao_scheme_builtin.txt | 1 + 2 files changed, 26 insertions(+) diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 0b84a89a..1bfe6942 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -230,6 +230,31 @@ ao_scheme_do_list_copy(struct ao_scheme_cons *cons) 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) { diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index 4739f121..7298add7 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -12,6 +12,7 @@ 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 -- cgit v1.2.3 From 243baa14a62e3efe5ae792c73db75f9c2cb86abb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 4 Jan 2018 02:26:21 -0800 Subject: altos/scheme: Allow make-vector value param to be optional It can default to #f Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 1bfe6942..4cb8b901 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -1144,12 +1144,12 @@ ao_scheme_do_make_vector(struct ao_scheme_cons *cons) { int32_t k; - if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2)) + if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 1, 2)) 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_arg(cons, 1))); + return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_opt_arg(cons, 1, _ao_scheme_bool_false))); } ao_poly -- 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(-) 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 0d9a3e0378f84ffc8447747150066eae33cd3229 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 4 Jan 2018 02:28:13 -0800 Subject: altos/scheme: Add vector and string funcs. Test everybody. Add a bunch of string and vector functions from r7rs. I think most everything is here now. Signed-off-by: Keith Packard --- src/scheme/Makefile-inc | 5 + src/scheme/ao_scheme_const.scheme | 345 +++++++++++++++++++++++-------------- src/scheme/ao_scheme_string.scheme | 152 ++++++++++++++++ src/scheme/ao_scheme_vector.scheme | 192 +++++++++++++++++++++ src/scheme/test/Makefile | 6 +- 5 files changed, 567 insertions(+), 133 deletions(-) create mode 100644 src/scheme/ao_scheme_string.scheme create mode 100644 src/scheme/ao_scheme_vector.scheme diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc index 1a080a4e..db5083df 100644 --- a/src/scheme/Makefile-inc +++ b/src/scheme/Makefile-inc @@ -23,3 +23,8 @@ SCHEME_HDRS=\ ao_scheme_os.h \ ao_scheme_read.h \ ao_scheme_builtin.h + +SCHEME_SCHEME=\ + ao_scheme_const.scheme \ + ao_scheme_vector.scheme \ + ao_scheme_string.scheme diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme index 29f000b3..107d60a6 100644 --- a/src/scheme/ao_scheme_const.scheme +++ b/src/scheme/ao_scheme_const.scheme @@ -13,6 +13,8 @@ ; ; Lisp code placed in ROM +(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit))))) + ; return a list containing all of the arguments (def (quote list) (lambda l l)) @@ -80,7 +82,7 @@ ; execute to resolve macros -(or #f #t) +(_?_ (or #f #t) #t) (begin (def! and @@ -109,7 +111,43 @@ ; execute to resolve macros -(and #t #f) +(_?_ (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 @@ -275,12 +313,24 @@ (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) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) +(_??_ (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) -(zero? 0) -(zero? "hello") +(_??_ (zero? 1) #f) +(_??_ (zero? 0) #t) +(_??_ (zero? "hello") #f) (define positive? (macro (value) `(> ,value 0))) -(positive? 12) -(positive? -12) +(_??_ (positive? 12) #t) +(_??_ (positive? -12) #f) (define negative? (macro (value) `(< ,value 0))) -(negative? 12) -(negative? -12) +(_??_ (negative? 12) #f) +(_??_ (negative? -12) #t) (define (abs x) (if (>= x 0) x (- x))) -(abs 12) -(abs -12) +(_??_ (abs 12) 12) +(_??_ (abs -12) 12) (define max (lambda (first . rest) (while (not (null? rest)) @@ -335,8 +385,8 @@ first) ) -(max 1 2 3) -(max 3 2 1) +(_??_ (max 1 2 3) 3) +(_??_ (max 3 2 1) 3) (define min (lambda (first . rest) (while (not (null? rest)) @@ -348,35 +398,37 @@ first) ) -(min 1 2 3) -(min 3 2 1) +(_??_ (min 1 2 3) 1) +(_??_ (min 3 2 1) 1) (define (even? x) (zero? (% x 2))) -(even? 2) -(even? -2) -(even? 3) -(even? -1) +(_??_ (even? 2) #t) +(_??_ (even? -2) #t) +(_??_ (even? 3) #f) +(_??_ (even? -1) #f) (define (odd? x) (not (even? x))) -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - +(_??_ (odd? 2) #f) +(_??_ (odd? -2) #f) +(_??_ (odd? 3) #t) +(_??_ (odd? -1) #t) -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x (- k 1))) - ) - ) +(_??_ (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 @@ -429,7 +481,7 @@ ) -(let ((x 1) (y)) (set! y 2) (+ x y)) +(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) ; define a set of local ; variables one at a time and @@ -501,15 +553,17 @@ ) ) -(let* ((x 1) (y x)) (+ x y)) +(_??_ (let* ((x 1) (y x)) (+ x y)) 2) (define when (macro (test . l) `(cond (,test ,@l)))) -(when #t (write 'when)) +(_??_ (when #t (+ 1 2)) 3) +(_??_ (when #f (+ 1 2)) #f) (define unless (macro (test . l) `(cond ((not ,test) ,@l)))) -(unless #f (write 'unless)) +(_??_ (unless #f (+ 2 3)) 5) +(_??_ (unless #t (+ 2 3)) #f) (define (reverse list) (define (_r old new) @@ -521,33 +575,27 @@ (_r list ()) ) -(reverse '(1 2 3)) - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref x k) (car (list-tail x k))) - -(list-ref '(1 2 3) 2) - - ; recursive equality +(_??_ (reverse '(1 2 3)) '(3 2 1)) -(define (equal? a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - (else #f) +(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)) -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) +(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) (define member (lambda (obj list . test?) (cond ((null? list) @@ -563,105 +611,118 @@ ) ) -(member '(2) '((1) (2) (3))) +(_??_ (member '(2) '((1) (2) (3))) '((2) (3))) -(member '(4) '((1) (2) (3))) +(_??_ (member '(4) '((1) (2) (3))) #f) (define (memq obj list) (member obj list eq?)) -(memq 2 '(1 2 3)) +(_??_ (memq 2 '(1 2 3)) '(2 3)) -(memq 4 '(1 2 3)) +(_??_ (memq 4 '(1 2 3)) #f) -(memq '(2) '((1) (2) (3))) +(_??_ (memq '(2) '((1) (2) (3))) #f) (define (memv obj list) (member obj list eqv?)) -(memv 2 '(1 2 3)) +(_??_ (memv 2 '(1 2 3)) '(2 3)) -(memv 4 '(1 2 3)) +(_??_ (memv 4 '(1 2 3)) #f) -(memv '(2) '((1) (2) (3))) +(_??_ (memv '(2) '((1) (2) (3))) #f) -(define (_assoc obj list test?) +(define (assoc obj list . compare) + (if (null? compare) + (set! compare equal?) + (set! compare (car compare)) + ) (if (null? list) #f - (if (test? obj (caar list)) + (if (compare obj (caar list)) (car list) - (_assoc obj (cdr list) test?) - ) + (assoc obj (cdr list) compare) + ) ) ) -(define (assq obj list) (_assoc obj list eq?)) -(define (assv obj list) (_assoc obj list eqv?)) -(define (assoc obj list) (_assoc obj list equal?)) +(define (assq obj list) (assoc obj list eq?)) +(define (assv obj list) (assoc obj list eqv?)) -(assq 'a '((a 1) (b 2) (c 3))) -(assv 'b '((a 1) (b 2) (c 3))) -(assoc '(c) '((a 1) (b 2) ((c) 3))) +(_??_ (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) -(char? "h") +(_??_ (char? #\q) #t) +(_??_ (char? "h") #f) (define (char-upper-case? c) (<= #\A c #\Z)) -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) +(_??_ (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) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) +(_??_ (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) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) +(_??_ (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) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) +(_??_ (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) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) +(_??_ (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) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) +(_??_ (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) -(char-downcase #\B) -(char-downcase #\0) -(char-downcase #\space) +(_??_ (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))) -(display "apply\n") -(apply cons '(a b)) +(_??_ (string #\a #\b #\c) "abc") + +(_??_ (apply cons '(a b)) '(a . b)) (define map (lambda (proc . lists) @@ -690,7 +751,7 @@ ) ) -(map cadr '((a b) (d e) (g h))) +(_??_ (map cadr '((a b) (d e) (g h))) '(b e h)) (define for-each (lambda (proc . lists) @@ -708,23 +769,6 @@ (for-each display '("hello" " " "world" "\n")) -(define (_string-ml strings) - (if (null? strings) () - (cons (string->list (car strings)) (_string-ml (cdr strings))) - ) - ) - -(define string-map (lambda (proc . strings) - (list->string (apply map proc (_string-ml strings)))))) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-for-each - (lambda (proc . strings) - (apply for-each proc (_string-ml strings)))) - -(string-for-each write-char "IBM\n") - (define (newline) (write-char #\newline)) (newline) @@ -746,7 +790,7 @@ -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) +(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) (define repeat @@ -816,4 +860,43 @@ ) ) -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) +(_??_ (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") + +(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)) #(0 1 2 3 4)) diff --git a/src/scheme/ao_scheme_string.scheme b/src/scheme/ao_scheme_string.scheme new file mode 100644 index 00000000..10e6fa4f --- /dev/null +++ b/src/scheme/ao_scheme_string.scheme @@ -0,0 +1,152 @@ +; +; 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-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") "IBM") + +(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) "hello ") +(_??_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello ") +(_??_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello ") + +(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) "h") +(_??_ (string-copy "hello" 1) "ello") +(_??_ (string-copy "hello") "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) "aaaaaaaaaa") +(_??_ (string-fill! (make-string 10) #\a 1 2) " a ") + +(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") #t) diff --git a/src/scheme/ao_scheme_vector.scheme b/src/scheme/ao_scheme_vector.scheme new file mode 100644 index 00000000..bf40204b --- /dev/null +++ b/src/scheme/ao_scheme_vector.scheme @@ -0,0 +1,192 @@ +; +; 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) "ab") + +(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) #(#\h #\e)) + +(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) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t")) + +(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) #(1 2 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)) #(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) #(#f #t #f)) + + ; 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)) #(5 7 9)) diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index ee46118e..8858f0f6 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -3,6 +3,8 @@ 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 @@ -20,8 +22,8 @@ ao-scheme: $(OBJS) $(OBJS): $(HDRS) -ao_scheme_const.h: ../make-const/ao_scheme_make_const ../ao_scheme_const.scheme - ../make-const/ao_scheme_make_const -o $@ ../ao_scheme_const.scheme +ao_scheme_const.h: ao_scheme_make_const $(SCHEME_SCHEME) + $^ -o $@ clean:: rm -f $(OBJS) ao-scheme ao_scheme_const.h -- cgit v1.2.3 From 39df849f0717d92a7d5bdf8aa5904bd4db1b467f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 6 Jan 2018 17:21:45 -0800 Subject: altos/scheme: add 'install' target to install both test and tiny test Signed-off-by: Keith Packard --- src/scheme/Makefile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/scheme/Makefile b/src/scheme/Makefile index e600d5f7..be312754 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -18,4 +18,8 @@ test/ao-scheme: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const 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: -- 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 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(-) 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 043c5b56ffc2d8171769f6e988eaad6e457bad89 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 11:47:57 -0800 Subject: altos/kernel: Use ao_put_string for syntax error message Avoid using puts, which can be a large library function. Signed-off-by: Keith Packard --- src/kernel/ao_cmd.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/kernel/ao_cmd.c b/src/kernel/ao_cmd.c index 405fd126..7bb4654e 100644 --- a/src/kernel/ao_cmd.c +++ b/src/kernel/ao_cmd.c @@ -355,7 +355,7 @@ report(void) switch(ao_cmd_status) { case ao_cmd_lex_error: case ao_cmd_syntax_error: - puts("Syntax error"); + ao_put_string("Syntax error\n"); ao_cmd_status = 0; default: break; -- cgit v1.2.3 From ee62272bec67b5784a4ee4e12d8a59677bf9d112 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 11:49:09 -0800 Subject: altos/stmf0: Remove packet counters from non-debug build These counters are only useful for helping debug the USB driver. Signed-off-by: Keith Packard --- src/stmf0/ao_usb_stm.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/stmf0/ao_usb_stm.c b/src/stmf0/ao_usb_stm.c index 59aed3aa..0f395123 100644 --- a/src/stmf0/ao_usb_stm.c +++ b/src/stmf0/ao_usb_stm.c @@ -531,11 +531,13 @@ ao_usb_set_configuration(void) #endif } +#if USB_STATUS static uint16_t control_count; static uint16_t int_count; static uint16_t in_count; static uint16_t out_count; static uint16_t reset_count; +#endif /* The USB memory must be accessed in 16-bit units */ @@ -895,7 +897,9 @@ stm_usb_isr(void) switch (ep) { case 0: +#if USB_STATUS ++control_count; +#endif if (ao_usb_epr_ctr_rx(epr)) { if (ao_usb_epr_setup(epr)) ao_usb_ep0_receive |= AO_USB_EP0_GOT_SETUP; @@ -907,7 +911,9 @@ stm_usb_isr(void) ao_usb_ep0_handle(ao_usb_ep0_receive); break; case AO_USB_OUT_EPR: +#if USB_STATUS ++out_count; +#endif if (ao_usb_epr_ctr_rx(epr)) { _rx_dbg1("RX ISR", epr); ao_usb_out_avail = 1; @@ -917,7 +923,9 @@ stm_usb_isr(void) } break; case AO_USB_IN_EPR: +#if USB_STATUS ++in_count; +#endif _tx_dbg1("TX ISR", epr); if (ao_usb_epr_ctr_tx(epr)) { ao_usb_in_pending = 0; @@ -935,7 +943,9 @@ stm_usb_isr(void) break; #endif case AO_USB_INT_EPR: +#if USB_STATUS ++int_count; +#endif if (ao_usb_epr_ctr_tx(epr)) _ao_usb_set_stat_tx(AO_USB_INT_EPR, STM_USB_EPR_STAT_TX_NAK); break; @@ -944,7 +954,9 @@ stm_usb_isr(void) } if (istr & (1 << STM_USB_ISTR_RESET)) { +#if USB_STATUS ++reset_count; +#endif debug ("\treset\n"); ao_usb_set_ep0(); } -- cgit v1.2.3 From eead259673c6594d41cfab796c8674c8bf1863cc Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 11:51:07 -0800 Subject: altos/stmf0: Stop shadowing USB tx buffers in system RAM Use the 16-bit USB memory directly, avoiding the buffer space and the copy Signed-off-by: Keith Packard --- src/stmf0/ao_usb_stm.c | 69 ++++++++++++++++++++++++++++++++------------------ 1 file changed, 44 insertions(+), 25 deletions(-) diff --git a/src/stmf0/ao_usb_stm.c b/src/stmf0/ao_usb_stm.c index 0f395123..0595c2b8 100644 --- a/src/stmf0/ao_usb_stm.c +++ b/src/stmf0/ao_usb_stm.c @@ -99,12 +99,9 @@ static uint16_t ao_usb_int_tx_offset; /* Pointer to bulk data tx/rx buffers in USB memory */ #if AO_USB_HAS_IN -static uint16_t ao_usb_in_tx_offset; -static uint16_t *ao_usb_in_tx_buffer; - -/* System ram shadow of USB buffer; writing individual bytes is - * too much of a pain (sigh) */ -static uint8_t ao_usb_tx_buffer[AO_USB_IN_SIZE]; +static uint16_t ao_usb_in_tx_offset[2]; +static uint16_t *ao_usb_in_tx_buffer[2]; +static uint8_t ao_usb_in_tx_which; static uint8_t ao_usb_tx_count; #endif @@ -119,12 +116,9 @@ static uint8_t ao_usb_rx_count, ao_usb_rx_pos; #endif #if AO_USB_HAS_IN2 -static uint16_t ao_usb_in2_tx_offset; -static uint16_t *ao_usb_in2_tx_buffer; - -/* System ram shadow of USB buffer; writing individual bytes is - * too much of a pain (sigh) */ -static uint8_t ao_usb_tx2_buffer[AO_USB_IN_SIZE]; +static uint16_t ao_usb_in2_tx_offset[2]; +static uint16_t *ao_usb_in2_tx_buffer[2]; +static uint8_t ao_usb_in_tx2_which; static uint8_t ao_usb_tx2_count; #endif @@ -378,29 +372,44 @@ ao_usb_alloc_buffers(void) #if AO_USB_HAS_INT + sram_addr += (sram_addr & 1); ao_usb_int_tx_offset = sram_addr; sram_addr += AO_USB_INT_SIZE; #endif #if AO_USB_HAS_OUT + sram_addr += (sram_addr & 1); ao_usb_out_rx_buffer = ao_usb_packet_buffer_addr(sram_addr); ao_usb_out_rx_offset = sram_addr; sram_addr += AO_USB_OUT_SIZE; #endif #if AO_USB_HAS_IN - ao_usb_in_tx_buffer = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_in_tx_offset = sram_addr; + sram_addr += (sram_addr & 1); + ao_usb_in_tx_buffer[0] = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_in_tx_offset[0] = sram_addr; + sram_addr += AO_USB_IN_SIZE; + ao_usb_in_tx_buffer[1] = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_in_tx_offset[1] = sram_addr; sram_addr += AO_USB_IN_SIZE; + ao_usb_in_tx_which = 0; #endif #if AO_USB_HAS_IN2 - ao_usb_in2_tx_buffer = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_in2_tx_offset = sram_addr; + sram_addr += (sram_addr & 1); + ao_usb_in2_tx_buffer[0] = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_in2_tx_offset[0] = sram_addr; sram_addr += AO_USB_IN_SIZE; + + sram_addr += (sram_addr & 1); + ao_usb_in2_tx_buffer[1] = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_in2_tx_offset[1] = sram_addr; + sram_addr += AO_USB_IN_SIZE; + ao_usb_in2_tx_which = 0; #endif #if AO_USB_DIRECTIO + sram_addr += (sram_addr & 1); ao_usb_sram_addr = sram_addr; #endif } @@ -489,7 +498,7 @@ ao_usb_set_configuration(void) #if AO_USB_HAS_IN /* Set up the IN end point */ - ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = ao_usb_in_tx_offset; + ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = 0; ao_usb_bdt[AO_USB_IN_EPR].single.count_tx = 0; ao_usb_init_ep(AO_USB_IN_EPR, @@ -501,7 +510,7 @@ ao_usb_set_configuration(void) #if AO_USB_HAS_IN2 /* Set up the IN2 end point */ - ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = ao_usb_in2_tx_offset; + ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = 0; ao_usb_bdt[AO_USB_IN2_EPR].single.count_tx = 0; ao_usb_init_ep(AO_USB_IN2_EPR, @@ -568,6 +577,16 @@ ao_usb_copy_rx(uint8_t *dst, uint16_t *base, uint16_t bytes) *dst = *base; } +static uint8_t +ao_usb_tx_byte(uint16_t *base, uint8_t tx_count, char byte) +{ + if (tx_count & 1) + base[tx_count >> 1] |= ((uint16_t) byte) << 8; + else + base[tx_count >> 1] = (uint16_t) (uint8_t) byte; + return tx_count + 1; +} + /* Send an IN data packet */ static void ao_usb_ep0_flush(void) @@ -984,10 +1003,10 @@ _ao_usb_in_send(void) ao_usb_in_pending = 1; if (ao_usb_tx_count != AO_USB_IN_SIZE) ao_usb_in_flushed = 1; - ao_usb_copy_tx(ao_usb_tx_buffer, ao_usb_in_tx_buffer, ao_usb_tx_count); - ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = ao_usb_in_tx_offset; + ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = ao_usb_in_tx_offset[ao_usb_in_tx_which]; ao_usb_bdt[AO_USB_IN_EPR].single.count_tx = ao_usb_tx_count; ao_usb_tx_count = 0; + ao_usb_in_tx_which = 1 - ao_usb_in_tx_which; _ao_usb_set_stat_tx(AO_USB_IN_EPR, STM_USB_EPR_STAT_TX_VALID); _tx_dbg0("in_send end"); } @@ -1041,7 +1060,7 @@ ao_usb_putchar(char c) _ao_usb_in_wait(); ao_usb_in_flushed = 0; - ao_usb_tx_buffer[ao_usb_tx_count++] = (uint8_t) c; + ao_usb_tx_count = ao_usb_tx_byte(ao_usb_in_tx_buffer[ao_usb_in_tx_which], ao_usb_tx_count, c); /* Send the packet when full */ if (ao_usb_tx_count == AO_USB_IN_SIZE) { @@ -1065,10 +1084,10 @@ _ao_usb_in2_send(void) ao_usb_in2_pending = 1; if (ao_usb_tx2_count != AO_USB_IN_SIZE) ao_usb_in2_flushed = 1; - ao_usb_copy_tx(ao_usb_tx2_buffer, ao_usb_in2_tx_buffer, ao_usb_tx2_count); - ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = ao_usb_in_tx_offset; - ao_usb_bdt[AO_USB_IN2_EPR].single.count_tx = ao_usb_tx_count; + ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = ao_usb_in2_tx_offset[ao_usb_in2_tx_which]; + ao_usb_bdt[AO_USB_IN2_EPR].single.count_tx = ao_usb_tx2_count; ao_usb_tx2_count = 0; + ao_usb_in2_tx_which = 1 - ao_usb_in2_tx_which; _ao_usb_set_stat_tx(AO_USB_IN2_EPR, STM_USB_EPR_STAT_TX_VALID); _tx_dbg0("in2_send end"); } @@ -1122,7 +1141,7 @@ ao_usb_putchar2(char c) _ao_usb_in2_wait(); ao_usb_in2_flushed = 0; - ao_usb_tx2_buffer[ao_usb_tx2_count++] = (uint8_t) c; + ao_usb_tx2_count = ao_usb_tx_byte(ao_usb_in2_tx_buffer[ao_usb_in2_tx_which], ao_usb_tx2_count, c); /* Send the packet when full */ if (ao_usb_tx2_count == AO_USB_IN_SIZE) { -- cgit v1.2.3 From 42072f591690b8258d957ab7a9b2f5d911676b39 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 12:43:13 -0800 Subject: altos/stmf0: Use double buffering for USB tx data This shouldn't have much of an effect, but shows how double buffering works. Signed-off-by: Keith Packard --- src/stmf0/ao_usb_stm.c | 78 ++++++++++++++++++++++++++++++++++++-------------- src/stmf0/stm32f0.h | 2 ++ 2 files changed, 59 insertions(+), 21 deletions(-) diff --git a/src/stmf0/ao_usb_stm.c b/src/stmf0/ao_usb_stm.c index 0595c2b8..0963b64a 100644 --- a/src/stmf0/ao_usb_stm.c +++ b/src/stmf0/ao_usb_stm.c @@ -292,12 +292,27 @@ _ao_usb_set_stat_tx(int ep, uint32_t stat_tx) epr_write &= STM_USB_EPR_PRESERVE_MASK; epr_write |= STM_USB_EPR_INVARIANT; epr_write |= set_toggle(epr_old, - STM_USB_EPR_STAT_TX_MASK << STM_USB_EPR_STAT_TX, - stat_tx << STM_USB_EPR_STAT_TX); + STM_USB_EPR_STAT_TX_MASK << STM_USB_EPR_STAT_TX, + stat_tx << STM_USB_EPR_STAT_TX); stm_usb.epr[ep].r = epr_write; _tx_dbg1("set_stat_tx bottom", epr_write); } +static void +_ao_usb_toggle_dtog(int ep, uint32_t dtog_rx, uint32_t dtog_tx) +{ + uint16_t epr_write; + + _tx_dbg1("toggle_dtog top", dtog_rx); + epr_write = stm_usb.epr[ep].r; + epr_write &= STM_USB_EPR_PRESERVE_MASK; + epr_write |= STM_USB_EPR_INVARIANT; + epr_write |= ((dtog_rx << STM_USB_EPR_DTOG_RX) | + (dtog_tx << STM_USB_EPR_DTOG_TX)); + stm_usb.epr[ep].r = epr_write; + _tx_dbg1("toggle_dtog bottom", epr_write); +} + static void ao_usb_set_stat_tx(int ep, uint32_t stat_tx) { @@ -331,25 +346,28 @@ ao_usb_set_stat_rx(int ep, uint32_t stat_rx) { */ static void -ao_usb_init_ep(uint8_t ep, uint32_t addr, uint32_t type, uint32_t stat_rx, uint32_t stat_tx) +ao_usb_init_ep(uint8_t ep, uint32_t addr, uint32_t type, uint32_t stat_rx, uint32_t stat_tx, uint32_t kind, uint32_t dtog_rx, uint32_t dtog_tx) { uint16_t epr; ao_arch_block_interrupts(); epr = stm_usb.epr[ep].r; epr = ((0 << STM_USB_EPR_CTR_RX) | - (epr & (1 << STM_USB_EPR_DTOG_RX)) | - set_toggle(epr, - (STM_USB_EPR_STAT_RX_MASK << STM_USB_EPR_STAT_RX), - (stat_rx << STM_USB_EPR_STAT_RX)) | (type << STM_USB_EPR_EP_TYPE) | - (0 << STM_USB_EPR_EP_KIND) | + (kind << STM_USB_EPR_EP_KIND) | (0 << STM_USB_EPR_CTR_TX) | - (epr & (1 << STM_USB_EPR_DTOG_TX)) | + (addr << STM_USB_EPR_EA) | set_toggle(epr, + + (1 << STM_USB_EPR_DTOG_RX) | + (STM_USB_EPR_STAT_RX_MASK << STM_USB_EPR_STAT_RX) | + (1 << STM_USB_EPR_DTOG_TX) | (STM_USB_EPR_STAT_TX_MASK << STM_USB_EPR_STAT_TX), - (stat_tx << STM_USB_EPR_STAT_TX)) | - (addr << STM_USB_EPR_EA)); + + (dtog_rx << STM_USB_EPR_DTOG_RX) | + (stat_rx << STM_USB_EPR_STAT_RX) | + (dtog_tx << STM_USB_EPR_DTOG_TX) | + (stat_tx << STM_USB_EPR_STAT_TX))); stm_usb.epr[ep].r = epr; ao_arch_release_interrupts(); debug ("writing epr[%d] 0x%04x wrote 0x%04x\n", @@ -440,14 +458,16 @@ ao_usb_set_ep0(void) ao_usb_init_ep(AO_USB_CONTROL_EPR, AO_USB_CONTROL_EP, STM_USB_EPR_EP_TYPE_CONTROL, STM_USB_EPR_STAT_RX_VALID, - STM_USB_EPR_STAT_TX_NAK); + STM_USB_EPR_STAT_TX_NAK, + STM_USB_EPR_EP_KIND_NO_STATUS_OUT, 0, 0); /* Clear all of the other endpoints */ for (e = 1; e < 8; e++) { ao_usb_init_ep(e, 0, STM_USB_EPR_EP_TYPE_CONTROL, STM_USB_EPR_STAT_RX_DISABLED, - STM_USB_EPR_STAT_TX_DISABLED); + STM_USB_EPR_STAT_TX_DISABLED, + STM_USB_EPR_EP_KIND_SNGL_BUF, 0, 0); } ao_usb_set_address(0); @@ -480,7 +500,8 @@ ao_usb_set_configuration(void) AO_USB_INT_EP, STM_USB_EPR_EP_TYPE_INTERRUPT, STM_USB_EPR_STAT_RX_DISABLED, - STM_USB_EPR_STAT_TX_NAK); + STM_USB_EPR_STAT_TX_NAK, + STM_USB_EPR_EP_KIND_SNGL_BUF, 0, 0); #endif #if AO_USB_HAS_OUT @@ -493,19 +514,25 @@ ao_usb_set_configuration(void) AO_USB_OUT_EP, STM_USB_EPR_EP_TYPE_BULK, STM_USB_EPR_STAT_RX_VALID, - STM_USB_EPR_STAT_TX_DISABLED); + STM_USB_EPR_STAT_TX_DISABLED, + STM_USB_EPR_EP_KIND_SNGL_BUF, 0, 0); #endif #if AO_USB_HAS_IN /* Set up the IN end point */ - ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = 0; - ao_usb_bdt[AO_USB_IN_EPR].single.count_tx = 0; + ao_usb_bdt[AO_USB_IN_EPR].double_tx[0].addr = ao_usb_in_tx_offset[0]; + ao_usb_bdt[AO_USB_IN_EPR].double_tx[0].count = 0; + ao_usb_bdt[AO_USB_IN_EPR].double_tx[1].addr = ao_usb_in_tx_offset[1]; + ao_usb_bdt[AO_USB_IN_EPR].double_tx[1].count = 0; + /* set 'our' buffer to 0, and the device buffer to 1 */ ao_usb_init_ep(AO_USB_IN_EPR, AO_USB_IN_EP, STM_USB_EPR_EP_TYPE_BULK, STM_USB_EPR_STAT_RX_DISABLED, - STM_USB_EPR_STAT_TX_NAK); + STM_USB_EPR_STAT_TX_NAK, + STM_USB_EPR_EP_KIND_DBL_BUF, + 0, 1); #endif #if AO_USB_HAS_IN2 @@ -517,7 +544,9 @@ ao_usb_set_configuration(void) AO_USB_IN2_EP, STM_USB_EPR_EP_TYPE_BULK, STM_USB_EPR_STAT_RX_DISABLED, - STM_USB_EPR_STAT_TX_NAK); + STM_USB_EPR_STAT_TX_NAK, + STM_USB_EPR_EP_KIND_DBL_BUF, + 0, 1); #endif ao_usb_in_flushed = 0; @@ -1003,11 +1032,18 @@ _ao_usb_in_send(void) ao_usb_in_pending = 1; if (ao_usb_tx_count != AO_USB_IN_SIZE) ao_usb_in_flushed = 1; - ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = ao_usb_in_tx_offset[ao_usb_in_tx_which]; - ao_usb_bdt[AO_USB_IN_EPR].single.count_tx = ao_usb_tx_count; + ao_usb_bdt[AO_USB_IN_EPR].double_tx[ao_usb_in_tx_which].count = ao_usb_tx_count; ao_usb_tx_count = 0; + + /* Toggle our usage */ ao_usb_in_tx_which = 1 - ao_usb_in_tx_which; + + /* Toggle the SW_BUF flag */ + _ao_usb_toggle_dtog(AO_USB_IN_EPR, 1, 0); + + /* Mark the outgoing buffer as valid */ _ao_usb_set_stat_tx(AO_USB_IN_EPR, STM_USB_EPR_STAT_TX_VALID); + _tx_dbg0("in_send end"); } diff --git a/src/stmf0/stm32f0.h b/src/stmf0/stm32f0.h index 61faf2e4..1dbe6a12 100644 --- a/src/stmf0/stm32f0.h +++ b/src/stmf0/stm32f0.h @@ -1906,7 +1906,9 @@ extern struct stm_usb stm_usb; #define STM_USB_EPR_EP_TYPE_INTERRUPT 3 #define STM_USB_EPR_EP_TYPE_MASK 3 #define STM_USB_EPR_EP_KIND 8 +#define STM_USB_EPR_EP_KIND_SNGL_BUF 0 /* Bulk */ #define STM_USB_EPR_EP_KIND_DBL_BUF 1 /* Bulk */ +#define STM_USB_EPR_EP_KIND_NO_STATUS_OUT 0 /* Control */ #define STM_USB_EPR_EP_KIND_STATUS_OUT 1 /* Control */ #define STM_USB_EPR_CTR_TX 7 #define STM_USB_CTR_TX_WRITE_INVARIANT 1 -- cgit v1.2.3 From 8545ed42bd29152f4937fb6457aba5fbd57e7691 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 17:43:42 -0800 Subject: altos/stmf0: use double buffering for USB rx data This also allows us to stop shadowing USB rx buffers in system ram Signed-off-by: Keith Packard --- src/stmf0/ao_usb_stm.c | 114 +++++++++++++++++++++++++++++++------------------ src/stmf0/stm32f0.h | 2 + 2 files changed, 75 insertions(+), 41 deletions(-) diff --git a/src/stmf0/ao_usb_stm.c b/src/stmf0/ao_usb_stm.c index 0963b64a..5b9af00b 100644 --- a/src/stmf0/ao_usb_stm.c +++ b/src/stmf0/ao_usb_stm.c @@ -106,12 +106,9 @@ static uint8_t ao_usb_tx_count; #endif #if AO_USB_HAS_OUT -static uint16_t ao_usb_out_rx_offset; -static uint16_t *ao_usb_out_rx_buffer; - -/* System ram shadow of USB buffer; writing individual bytes is - * too much of a pain (sigh) */ -static uint8_t ao_usb_rx_buffer[AO_USB_OUT_SIZE]; +static uint16_t ao_usb_out_rx_offset[2]; +static uint16_t *ao_usb_out_rx_buffer[2]; +static uint8_t ao_usb_out_rx_which; static uint8_t ao_usb_rx_count, ao_usb_rx_pos; #endif @@ -211,10 +208,18 @@ static inline uint32_t ao_usb_epr_dtog_rx(uint32_t epr) { return (epr >> STM_USB_EPR_DTOG_RX) & 1; } +static inline uint32_t ao_usb_epr_sw_buf_tx(uint32_t epr) { + return (epr >> STM_USB_EPR_SW_BUF_TX) & 1; +} + static inline uint32_t ao_usb_epr_dtog_tx(uint32_t epr) { return (epr >> STM_USB_EPR_DTOG_TX) & 1; } +static inline uint32_t ao_usb_epr_sw_buf_rx(uint32_t epr) { + return (epr >> STM_USB_EPR_SW_BUF_RX) & 1; +} + /* * Set current device address and mark the * interface as active @@ -298,6 +303,14 @@ _ao_usb_set_stat_tx(int ep, uint32_t stat_tx) _tx_dbg1("set_stat_tx bottom", epr_write); } +static void +ao_usb_set_stat_tx(int ep, uint32_t stat_tx) +{ + ao_arch_block_interrupts(); + _ao_usb_set_stat_tx(ep, stat_tx); + ao_arch_release_interrupts(); +} + static void _ao_usb_toggle_dtog(int ep, uint32_t dtog_rx, uint32_t dtog_tx) { @@ -313,14 +326,6 @@ _ao_usb_toggle_dtog(int ep, uint32_t dtog_rx, uint32_t dtog_tx) _tx_dbg1("toggle_dtog bottom", epr_write); } -static void -ao_usb_set_stat_tx(int ep, uint32_t stat_tx) -{ - ao_arch_block_interrupts(); - _ao_usb_set_stat_tx(ep, stat_tx); - ao_arch_release_interrupts(); -} - static void _ao_usb_set_stat_rx(int ep, uint32_t stat_rx) { uint16_t epr_write, epr_old; @@ -342,11 +347,14 @@ ao_usb_set_stat_rx(int ep, uint32_t stat_rx) { } /* - * Set just endpoint 0, for use during startup + * Initialize an entpoint */ static void -ao_usb_init_ep(uint8_t ep, uint32_t addr, uint32_t type, uint32_t stat_rx, uint32_t stat_tx, uint32_t kind, uint32_t dtog_rx, uint32_t dtog_tx) +ao_usb_init_ep(uint8_t ep, uint16_t addr, uint16_t type, + uint16_t stat_rx, uint16_t stat_tx, + uint16_t kind, + uint16_t dtog_rx, uint16_t dtog_tx) { uint16_t epr; @@ -397,9 +405,14 @@ ao_usb_alloc_buffers(void) #if AO_USB_HAS_OUT sram_addr += (sram_addr & 1); - ao_usb_out_rx_buffer = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_out_rx_offset = sram_addr; + ao_usb_out_rx_buffer[0] = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_out_rx_offset[0] = sram_addr; + sram_addr += AO_USB_OUT_SIZE; + sram_addr += (sram_addr & 1); + ao_usb_out_rx_buffer[1] = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_out_rx_offset[1] = sram_addr; sram_addr += AO_USB_OUT_SIZE; + ao_usb_out_rx_which = 1; #endif #if AO_USB_HAS_IN @@ -506,16 +519,21 @@ ao_usb_set_configuration(void) #if AO_USB_HAS_OUT /* Set up the OUT end point */ - ao_usb_bdt[AO_USB_OUT_EPR].single.addr_rx = ao_usb_out_rx_offset; - ao_usb_bdt[AO_USB_OUT_EPR].single.count_rx = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | - (((AO_USB_OUT_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); + ao_usb_bdt[AO_USB_OUT_EPR].double_rx[0].addr = ao_usb_out_rx_offset[0]; + ao_usb_bdt[AO_USB_OUT_EPR].double_rx[0].count = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | + (((AO_USB_OUT_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); + ao_usb_bdt[AO_USB_OUT_EPR].double_rx[1].addr = ao_usb_out_rx_offset[1]; + ao_usb_bdt[AO_USB_OUT_EPR].double_rx[1].count = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | + (((AO_USB_OUT_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); + + /* set 'our' buffer to one, and the device buffer to 0 */ ao_usb_init_ep(AO_USB_OUT_EPR, AO_USB_OUT_EP, STM_USB_EPR_EP_TYPE_BULK, STM_USB_EPR_STAT_RX_VALID, STM_USB_EPR_STAT_TX_DISABLED, - STM_USB_EPR_EP_KIND_SNGL_BUF, 0, 0); + STM_USB_EPR_EP_KIND_DBL_BUF, 0, 1); #endif #if AO_USB_HAS_IN @@ -606,14 +624,22 @@ ao_usb_copy_rx(uint8_t *dst, uint16_t *base, uint16_t bytes) *dst = *base; } -static uint8_t +static inline void ao_usb_tx_byte(uint16_t *base, uint8_t tx_count, char byte) { if (tx_count & 1) base[tx_count >> 1] |= ((uint16_t) byte) << 8; else base[tx_count >> 1] = (uint16_t) (uint8_t) byte; - return tx_count + 1; +} + +static inline char +ao_usb_rx_byte(uint16_t *base, uint8_t rx_count) +{ + if (rx_count & 1) + return (char) (base[rx_count>>1] >> 8); + else + return (char) base[rx_count>>1]; } /* Send an IN data packet */ @@ -1096,7 +1122,7 @@ ao_usb_putchar(char c) _ao_usb_in_wait(); ao_usb_in_flushed = 0; - ao_usb_tx_count = ao_usb_tx_byte(ao_usb_in_tx_buffer[ao_usb_in_tx_which], ao_usb_tx_count, c); + ao_usb_tx_byte(ao_usb_in_tx_buffer[ao_usb_in_tx_which], ao_usb_tx_count++, c); /* Send the packet when full */ if (ao_usb_tx_count == AO_USB_IN_SIZE) { @@ -1177,7 +1203,8 @@ ao_usb_putchar2(char c) _ao_usb_in2_wait(); ao_usb_in2_flushed = 0; - ao_usb_tx2_count = ao_usb_tx_byte(ao_usb_in2_tx_buffer[ao_usb_in2_tx_which], ao_usb_tx2_count, c); + ao_usb_tx_byte(ao_usb_in2_tx_buffer[ao_usb_in2_tx_which], ao_usb_tx2_count, c); + ao_usb_tx2_count++; /* Send the packet when full */ if (ao_usb_tx2_count == AO_USB_IN_SIZE) { @@ -1193,20 +1220,24 @@ ao_usb_putchar2(char c) static void _ao_usb_out_recv(void) { - _rx_dbg0("out_recv top"); + _rx_dbg1("out_recv top", stm_usb.epr[AO_USB_OUT_EPR].r); + + /* Clear packet available field until we get another interrupt */ ao_usb_out_avail = 0; - ao_usb_rx_count = ao_usb_bdt[AO_USB_OUT_EPR].single.count_rx & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; + /* Switch to new buffer */ + ao_usb_out_rx_which = 1 - ao_usb_out_rx_which; - _rx_dbg1("out_recv count", ao_usb_rx_count); - debug ("recv %d\n", ao_usb_rx_count); - debug_data("Fill OUT len %d:", ao_usb_rx_count); - ao_usb_copy_rx(ao_usb_rx_buffer, ao_usb_out_rx_buffer, ao_usb_rx_count); - debug_data("\n"); + ao_usb_rx_count = ao_usb_bdt[AO_USB_OUT_EPR].double_rx[ao_usb_out_rx_which].count & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; ao_usb_rx_pos = 0; - /* ACK the packet */ - _ao_usb_set_stat_rx(AO_USB_OUT_EPR, STM_USB_EPR_STAT_RX_VALID); + /* Toggle the SW_BUF_RX bit */ + _ao_usb_toggle_dtog(AO_USB_OUT_EPR, 0, 1); + +// /* Ack the packet */ +// _ao_usb_set_stat_rx(AO_USB_OUT_EPR, STM_USB_EPR_STAT_RX_VALID); + + _rx_dbg1("out_recv count", ao_usb_rx_count); } int @@ -1221,17 +1252,18 @@ _ao_usb_pollchar(void) if (ao_usb_rx_pos != ao_usb_rx_count) break; - _rx_dbg0("poll check"); +// _rx_dbg0("poll check"); /* Check to see if a packet has arrived */ if (!ao_usb_out_avail) { - _rx_dbg0("poll none"); +// _rx_dbg0("poll none"); return AO_READ_AGAIN; } _ao_usb_out_recv(); } /* Pull a character out of the fifo */ - c = ao_usb_rx_buffer[ao_usb_rx_pos++]; + c = ao_usb_rx_byte(ao_usb_out_rx_buffer[ao_usb_out_rx_which], ao_usb_rx_pos++); + _rx_dbg1("char", c); return c; } @@ -1510,8 +1542,8 @@ struct ao_usb_dbg { #define NUM_USB_DBG 128 -static struct ao_usb_dbg dbg[128]; -static int dbg_i; +struct ao_usb_dbg dbg[128]; +int dbg_i; static void _dbg(int line, char *msg, uint32_t value) { @@ -1532,7 +1564,7 @@ static void _dbg(int line, char *msg, uint32_t value) dbg[dbg_i].rx_count = ao_usb_rx_count; dbg[dbg_i].rx_pos = ao_usb_rx_pos; dbg[dbg_i].out_avail = ao_usb_out_avail; - dbg[dbg_i].out_epr = stm_usb.epr[AO_USB_OUT_EPR]; + dbg[dbg_i].out_epr = stm_usb.epr[AO_USB_OUT_EPR].r; #endif if (++dbg_i == NUM_USB_DBG) dbg_i = 0; diff --git a/src/stmf0/stm32f0.h b/src/stmf0/stm32f0.h index 1dbe6a12..277fa223 100644 --- a/src/stmf0/stm32f0.h +++ b/src/stmf0/stm32f0.h @@ -1890,6 +1890,7 @@ extern struct stm_usb stm_usb; #define STM_USB_EPR_CTR_RX 15 #define STM_USB_EPR_CTR_RX_WRITE_INVARIANT 1 #define STM_USB_EPR_DTOG_RX 14 +#define STM_USB_EPR_SW_BUF_TX 14 #define STM_USB_EPR_DTOG_RX_WRITE_INVARIANT 0 #define STM_USB_EPR_STAT_RX 12 #define STM_USB_EPR_STAT_RX_DISABLED 0 @@ -1913,6 +1914,7 @@ extern struct stm_usb stm_usb; #define STM_USB_EPR_CTR_TX 7 #define STM_USB_CTR_TX_WRITE_INVARIANT 1 #define STM_USB_EPR_DTOG_TX 6 +#define STM_USB_EPR_SW_BUF_RX 6 #define STM_USB_EPR_DTOG_TX_WRITE_INVARIANT 0 #define STM_USB_EPR_STAT_TX 4 #define STM_USB_EPR_STAT_TX_DISABLED 0 -- cgit v1.2.3 From db7f7c6c7f956058250b8057c6c27284f6f22e53 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 21:43:22 -0800 Subject: ao-chaosread: add --raw and --cooked flags Allow reading from the cooked endpoint as well as the raw one. Signed-off-by: Keith Packard --- ao-tools/ao-chaosread/ao-chaosread.1 | 14 ++++++++++++++ ao-tools/ao-chaosread/ao-chaosread.c | 22 ++++++++++++++++------ 2 files changed, 30 insertions(+), 6 deletions(-) diff --git a/ao-tools/ao-chaosread/ao-chaosread.1 b/ao-tools/ao-chaosread/ao-chaosread.1 index ead8afb2..e6ed2fac 100644 --- a/ao-tools/ao-chaosread/ao-chaosread.1 +++ b/ao-tools/ao-chaosread/ao-chaosread.1 @@ -33,6 +33,20 @@ one found. \-l length | --length length Set the amount of data to read. Suffixes 'k', 'M' and 'G' are supported. The default is 1k. +.TP +\-i | --infinite +Read an unlimited amount of data. +.TP +\-b | --bytes +For each 16-bit value read, output bits 1-8 as a byte, don't output +bit 0 or bits 9-15 at all. +.TP +\-c | --cooked +Read whitened data from the device. The default is to read raw data +from the noise source. +.TP +\-r | --raw +Read raw data from the noise source. This is the default. .SH USAGE .I ao-chaosread reads noise data. diff --git a/ao-tools/ao-chaosread/ao-chaosread.c b/ao-tools/ao-chaosread/ao-chaosread.c index 6d860139..8a814a00 100644 --- a/ao-tools/ao-chaosread/ao-chaosread.c +++ b/ao-tools/ao-chaosread/ao-chaosread.c @@ -172,10 +172,11 @@ chaoskey_close(struct chaoskey *ck) free(ck); } -#define ENDPOINT 0x86 +#define COOKED_ENDPOINT 0x85 +#define RAW_ENDPOINT 0x86 int -chaoskey_read(struct chaoskey *ck, void *buffer, int len) +chaoskey_read(struct chaoskey *ck, int endpoint, void *buffer, int len) { uint8_t *buf = buffer; int total = 0; @@ -184,7 +185,7 @@ chaoskey_read(struct chaoskey *ck, void *buffer, int len) int ret; int transferred; - ret = libusb_bulk_transfer(ck->handle, ENDPOINT, buf, len, &transferred, 10000); + ret = libusb_bulk_transfer(ck->handle, endpoint, buf, len, &transferred, 10000); if (ret) { if (total) return total; @@ -205,12 +206,14 @@ static const struct option options[] = { { .name = "length", .has_arg = 1, .val = 'l' }, { .name = "infinite", .has_arg = 0, .val = 'i' }, { .name = "bytes", .has_arg = 0, .val = 'b' }, + { .name = "cooked", .has_arg = 0, .val = 'c' }, + { .name = "raw", .has_arg = 0, .val = 'r' }, { 0, 0, 0, 0}, }; static void usage(char *program) { - fprintf(stderr, "usage: %s [--serial=] [--length=[kMG]] [--infinite] [--bytes]\n", program); + fprintf(stderr, "usage: %s [--serial=] [--length=[kMG]] [--infinite] [--bytes] [--cooked] [--raw]\n", program); exit(1); } @@ -228,8 +231,9 @@ main (int argc, char **argv) int this_time; int infinite = 0; int bytes = 0; + int endpoint = RAW_ENDPOINT; - while ((c = getopt_long(argc, argv, "s:l:ib", options, NULL)) != -1) { + while ((c = getopt_long(argc, argv, "s:l:ibcr", options, NULL)) != -1) { switch (c) { case 's': serial = optarg; @@ -252,6 +256,12 @@ main (int argc, char **argv) case 'b': bytes = 1; break; + case 'c': + endpoint = COOKED_ENDPOINT; + break; + case 'r': + endpoint = RAW_ENDPOINT; + break; default: usage(argv[0]); break; @@ -269,7 +279,7 @@ main (int argc, char **argv) this_time = sizeof(buf); if (!infinite && length < sizeof(buf)) this_time = (int) length; - got = chaoskey_read(ck, buf, this_time); + got = chaoskey_read(ck, endpoint, buf, this_time); if (got < 0) { perror("read"); exit(1); -- cgit v1.2.3 From 48d164e3d4b2ef27fae20fae63b8014803a7b178 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 21:44:39 -0800 Subject: altos/stmf0: Use double buffering for ChaosKey This improves the USB performance of ChaosKey so that it doesn't NAK during data transfers at all. Signed-off-by: Keith Packard --- src/drivers/ao_trng_send.c | 96 ++++++---------- src/stmf0/ao_adc_fast.c | 2 +- src/stmf0/ao_adc_fast.h | 2 +- src/stmf0/ao_arch_funcs.h | 15 ++- src/stmf0/ao_usb_stm.c | 267 +++++++++++++++++++++++---------------------- src/stmf0/registers.ld | 1 + src/stmf0/stm32f0.h | 5 + 7 files changed, 187 insertions(+), 201 deletions(-) diff --git a/src/drivers/ao_trng_send.c b/src/drivers/ao_trng_send.c index 7cda053d..4e02c0ce 100644 --- a/src/drivers/ao_trng_send.c +++ b/src/drivers/ao_trng_send.c @@ -31,6 +31,29 @@ static AO_TICK_TYPE trng_power_time; static uint8_t random_mutex; +static void +ao_trng_start(void) +{ + if (!trng_running) { + ao_mutex_get(&random_mutex); + if (!trng_running) { + AO_TICK_TYPE delay; + + delay = trng_power_time + TRNG_ENABLE_DELAY - ao_time(); + if (delay > TRNG_ENABLE_DELAY) + delay = TRNG_ENABLE_DELAY; + + /* Delay long enough for the HV power supply + * to stabilize so that the first bits we read + * aren't of poor quality + */ + ao_delay(delay); + trng_running = TRUE; + } + ao_mutex_put(&random_mutex); + } +} + #if AO_USB_HAS_IN2 static struct ao_task ao_trng_send_raw_task; @@ -54,34 +77,13 @@ ao_trng_get_raw(uint16_t *buf) static void ao_trng_send_raw(void) { - static uint16_t *buffer[2]; + uint16_t *buffer[2]; int usb_buf_id; - if (!buffer[0]) { - buffer[0] = ao_usb_alloc(); - buffer[1] = ao_usb_alloc(); - if (!buffer[0]) - ao_exit(); - } - - usb_buf_id = 0; + usb_buf_id = ao_usb_alloc2(buffer); for (;;) { - ao_mutex_get(&random_mutex); - if (!trng_running) { - AO_TICK_TYPE delay; - - delay = trng_power_time + TRNG_ENABLE_DELAY - ao_time(); - if (delay > TRNG_ENABLE_DELAY) - delay = TRNG_ENABLE_DELAY; - - /* Delay long enough for the HV power supply - * to stabilize so that the first bits we read - * aren't of poor quality - */ - ao_delay(delay); - trng_running = TRUE; - } + ao_trng_start(); #ifdef AO_LED_TRNG_RAW ao_led_on(AO_LED_TRNG_RAW); #endif @@ -89,9 +91,7 @@ ao_trng_send_raw(void) #ifdef AO_LED_TRNG_RAW ao_led_off(AO_LED_TRNG_RAW); #endif - ao_mutex_put(&random_mutex); - ao_usb_write2(buffer[usb_buf_id], AO_USB_IN_SIZE); - usb_buf_id = 1-usb_buf_id; + usb_buf_id = ao_usb_write2(AO_USB_IN_SIZE); } } @@ -105,7 +105,7 @@ ao_trng_get_cooked(uint16_t *buf) uint16_t i; uint16_t t; uint32_t *rnd = (uint32_t *) (void *) ao_adc_ring; - uint8_t mismatch = 0; + uint8_t mismatch = 1; t = ao_adc_get(AO_USB_IN_SIZE) >> 1; /* one 16-bit value per output byte */ for (i = 0; i < AO_USB_IN_SIZE / sizeof (uint16_t); i++) { @@ -131,20 +131,13 @@ ao_trng_get_cooked(uint16_t *buf) static void ao_trng_send(void) { - static uint16_t *buffer[2]; - int usb_buf_id; - int good_bits; - int failed; - int s; - - if (!buffer[0]) { - buffer[0] = ao_usb_alloc(); - buffer[1] = ao_usb_alloc(); - if (!buffer[0]) - ao_exit(); - } + uint16_t *buffer[2]; + int usb_buf_id; + int good_bits; + int failed; + int s; - usb_buf_id = 0; + usb_buf_id = ao_usb_alloc(buffer); #ifdef AO_TRNG_ENABLE_PORT ao_gpio_set(AO_TRNG_ENABLE_PORT, AO_TRNG_ENABLE_BIT, AO_TRNG_ENABLE_PIN, 1); @@ -191,21 +184,7 @@ ao_trng_send(void) #endif for (;;) { - ao_mutex_get(&random_mutex); - if (!trng_running) { - AO_TICK_TYPE delay; - - delay = trng_power_time + TRNG_ENABLE_DELAY - ao_time(); - if (delay > TRNG_ENABLE_DELAY) - delay = TRNG_ENABLE_DELAY; - - /* Delay long enough for the HV power supply - * to stabilize so that the first bits we read - * aren't of poor quality - */ - ao_delay(delay); - trng_running = TRUE; - } + ao_trng_start(); #ifdef AO_LED_TRNG_COOKED ao_led_on(AO_LED_TRNG_COOKED); #endif @@ -213,14 +192,11 @@ ao_trng_send(void) #ifdef AO_LED_TRNG_COOKED ao_led_off(AO_LED_TRNG_COOKED); #endif - ao_mutex_put(&random_mutex); if (good_bits) { - ao_usb_write(buffer[usb_buf_id], AO_USB_IN_SIZE); - usb_buf_id = 1-usb_buf_id; + usb_buf_id = ao_usb_write(AO_USB_IN_SIZE); failed = 0; } else { failed++; - ao_delay(AO_MS_TO_TICKS(10)); if (failed > 10) { ao_usb_disable(); ao_panic(AO_PANIC_DMA); diff --git a/src/stmf0/ao_adc_fast.c b/src/stmf0/ao_adc_fast.c index 5ce3a396..fbf4ad2e 100644 --- a/src/stmf0/ao_adc_fast.c +++ b/src/stmf0/ao_adc_fast.c @@ -154,7 +154,7 @@ ao_adc_init(void) #endif /* Set the clock */ - stm_adc.cfgr2 = STM_ADC_CFGR2_CKMODE_ADCCLK << STM_ADC_CFGR2_CKMODE; + stm_adc.cfgr2 = STM_ADC_CFGR2_CKMODE_PCLK_2 << STM_ADC_CFGR2_CKMODE; /* Shortest sample time */ stm_adc.smpr = STM_ADC_SMPR_SMP_1_5 << STM_ADC_SMPR_SMP; diff --git a/src/stmf0/ao_adc_fast.h b/src/stmf0/ao_adc_fast.h index 3f0b0547..504651e5 100644 --- a/src/stmf0/ao_adc_fast.h +++ b/src/stmf0/ao_adc_fast.h @@ -26,7 +26,7 @@ void ao_adc_init(void); /* Total ring size in samples */ -#define AO_ADC_RING_SIZE 256 +#define AO_ADC_RING_SIZE 1024 extern uint16_t ao_adc_ring[AO_ADC_RING_SIZE] __attribute__((aligned(4))); diff --git a/src/stmf0/ao_arch_funcs.h b/src/stmf0/ao_arch_funcs.h index 01d51f90..56a3bc75 100644 --- a/src/stmf0/ao_arch_funcs.h +++ b/src/stmf0/ao_arch_funcs.h @@ -488,14 +488,17 @@ static inline void ao_arch_start_scheduler(void) { /* ao_usb_stm.c */ #if AO_USB_DIRECTIO -uint16_t * -ao_usb_alloc(void); +uint8_t +ao_usb_alloc(uint16_t *buffers[2]); -void -ao_usb_write(uint16_t *buffer, uint16_t len); +uint8_t +ao_usb_alloc2(uint16_t *buffers[2]); -void -ao_usb_write2(uint16_t *buffer, uint16_t len); +uint8_t +ao_usb_write(uint16_t len); + +uint8_t +ao_usb_write2(uint16_t len); #endif /* AO_USB_DIRECTIO */ #endif /* _AO_ARCH_FUNCS_H_ */ diff --git a/src/stmf0/ao_usb_stm.c b/src/stmf0/ao_usb_stm.c index 5b9af00b..bf08abc1 100644 --- a/src/stmf0/ao_usb_stm.c +++ b/src/stmf0/ao_usb_stm.c @@ -82,15 +82,12 @@ static uint8_t ao_usb_ep0_out_len; */ /* Buffer description tables */ -static union stm_usb_bdt *ao_usb_bdt; -/* USB address of end of allocated storage */ -#if AO_USB_DIRECTIO -static uint16_t ao_usb_sram_addr; -#endif + +#define ao_usb_bdt ((union stm_usb_bdt *) (intptr_t) (void *) stm_usb_sram) /* Pointer to ep0 tx/rx buffers in USB memory */ -static uint16_t *ao_usb_ep0_tx_buffer; -static uint16_t *ao_usb_ep0_rx_buffer; +static uint16_t ao_usb_ep0_tx_offset; +static uint16_t ao_usb_ep0_rx_offset; #if AO_USB_HAS_INT /* Pointer to interrupt buffer in USB memory */ @@ -99,22 +96,19 @@ static uint16_t ao_usb_int_tx_offset; /* Pointer to bulk data tx/rx buffers in USB memory */ #if AO_USB_HAS_IN -static uint16_t ao_usb_in_tx_offset[2]; -static uint16_t *ao_usb_in_tx_buffer[2]; +static uint16_t ao_usb_in_tx_offset; static uint8_t ao_usb_in_tx_which; static uint8_t ao_usb_tx_count; #endif #if AO_USB_HAS_OUT -static uint16_t ao_usb_out_rx_offset[2]; -static uint16_t *ao_usb_out_rx_buffer[2]; +static uint16_t ao_usb_out_rx_offset; static uint8_t ao_usb_out_rx_which; static uint8_t ao_usb_rx_count, ao_usb_rx_pos; #endif #if AO_USB_HAS_IN2 -static uint16_t ao_usb_in2_tx_offset[2]; -static uint16_t *ao_usb_in2_tx_buffer[2]; +static uint16_t ao_usb_in_tx2_offset; static uint8_t ao_usb_in_tx2_which; static uint8_t ao_usb_tx2_count; #endif @@ -179,6 +173,16 @@ static inline uint16_t *ao_usb_packet_buffer_addr(uint16_t sram_addr) return (uint16_t *) (void *) (stm_usb_sram + sram_addr); } +static inline uint16_t ao_usb_packet_get(uint16_t sram_addr) +{ + return ao_usb_packet_buffer_addr(sram_addr)[0]; +} + +static inline void ao_usb_packet_put(uint16_t sram_addr, uint16_t val) +{ + ao_usb_packet_buffer_addr(sram_addr)[0] = val; +} + static inline uint16_t ao_usb_packet_buffer_offset(uint16_t *addr) { return (uint16_t) ((uint8_t *) addr - stm_usb_sram); @@ -387,16 +391,15 @@ ao_usb_alloc_buffers(void) { uint16_t sram_addr = 0; - ao_usb_bdt = (void *) stm_usb_sram; + /* allocate space for BDT, which is at the start of SRAM */ sram_addr += 8 * STM_USB_BDT_SIZE; - ao_usb_ep0_tx_buffer = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_ep0_tx_offset = sram_addr; sram_addr += AO_USB_CONTROL_SIZE; - ao_usb_ep0_rx_buffer = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_ep0_rx_offset = sram_addr; sram_addr += AO_USB_CONTROL_SIZE; - #if AO_USB_HAS_INT sram_addr += (sram_addr & 1); ao_usb_int_tx_offset = sram_addr; @@ -405,43 +408,20 @@ ao_usb_alloc_buffers(void) #if AO_USB_HAS_OUT sram_addr += (sram_addr & 1); - ao_usb_out_rx_buffer[0] = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_out_rx_offset[0] = sram_addr; - sram_addr += AO_USB_OUT_SIZE; - sram_addr += (sram_addr & 1); - ao_usb_out_rx_buffer[1] = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_out_rx_offset[1] = sram_addr; - sram_addr += AO_USB_OUT_SIZE; - ao_usb_out_rx_which = 1; + ao_usb_out_rx_offset = sram_addr; + sram_addr += AO_USB_OUT_SIZE * 2; #endif #if AO_USB_HAS_IN sram_addr += (sram_addr & 1); - ao_usb_in_tx_buffer[0] = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_in_tx_offset[0] = sram_addr; - sram_addr += AO_USB_IN_SIZE; - ao_usb_in_tx_buffer[1] = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_in_tx_offset[1] = sram_addr; - sram_addr += AO_USB_IN_SIZE; - ao_usb_in_tx_which = 0; + ao_usb_in_tx_offset = sram_addr; + sram_addr += AO_USB_IN_SIZE * 2; #endif #if AO_USB_HAS_IN2 sram_addr += (sram_addr & 1); - ao_usb_in2_tx_buffer[0] = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_in2_tx_offset[0] = sram_addr; - sram_addr += AO_USB_IN_SIZE; - - sram_addr += (sram_addr & 1); - ao_usb_in2_tx_buffer[1] = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_in2_tx_offset[1] = sram_addr; - sram_addr += AO_USB_IN_SIZE; - ao_usb_in2_tx_which = 0; -#endif - -#if AO_USB_DIRECTIO - sram_addr += (sram_addr & 1); - ao_usb_sram_addr = sram_addr; + ao_usb_in_tx2_offset = sram_addr; + sram_addr += AO_USB_IN_SIZE * 2; #endif } @@ -450,11 +430,11 @@ ao_usb_init_btable(void) { /* Set up EP 0 - a Control end point with 32 bytes of in and out buffers */ - ao_usb_bdt[0].single.addr_tx = ao_usb_packet_buffer_offset(ao_usb_ep0_tx_buffer); - ao_usb_bdt[0].single.count_tx = 0; + stm_usb_bdt[0].single.addr_tx = ao_usb_ep0_tx_offset; + stm_usb_bdt[0].single.count_tx = 0; - ao_usb_bdt[0].single.addr_rx = ao_usb_packet_buffer_offset(ao_usb_ep0_rx_buffer); - ao_usb_bdt[0].single.count_rx = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | + stm_usb_bdt[0].single.addr_rx = ao_usb_ep0_rx_offset; + stm_usb_bdt[0].single.count_rx = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | (((AO_USB_CONTROL_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); } @@ -506,8 +486,8 @@ ao_usb_set_configuration(void) #if AO_USB_HAS_INT /* Set up the INT end point */ - ao_usb_bdt[AO_USB_INT_EPR].single.addr_tx = ao_usb_int_tx_offset; - ao_usb_bdt[AO_USB_INT_EPR].single.count_tx = 0; + stm_usb_bdt[AO_USB_INT_EPR].single.addr_tx = ao_usb_int_tx_offset; + stm_usb_bdt[AO_USB_INT_EPR].single.count_tx = 0; ao_usb_init_ep(AO_USB_INT_EPR, AO_USB_INT_EP, @@ -519,12 +499,12 @@ ao_usb_set_configuration(void) #if AO_USB_HAS_OUT /* Set up the OUT end point */ - ao_usb_bdt[AO_USB_OUT_EPR].double_rx[0].addr = ao_usb_out_rx_offset[0]; - ao_usb_bdt[AO_USB_OUT_EPR].double_rx[0].count = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | + stm_usb_bdt[AO_USB_OUT_EPR].double_rx[0].addr = ao_usb_out_rx_offset; + stm_usb_bdt[AO_USB_OUT_EPR].double_rx[0].count = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | (((AO_USB_OUT_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); - ao_usb_bdt[AO_USB_OUT_EPR].double_rx[1].addr = ao_usb_out_rx_offset[1]; - ao_usb_bdt[AO_USB_OUT_EPR].double_rx[1].count = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | + stm_usb_bdt[AO_USB_OUT_EPR].double_rx[1].addr = ao_usb_out_rx_offset + AO_USB_OUT_SIZE; + stm_usb_bdt[AO_USB_OUT_EPR].double_rx[1].count = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | (((AO_USB_OUT_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); /* set 'our' buffer to one, and the device buffer to 0 */ @@ -534,14 +514,17 @@ ao_usb_set_configuration(void) STM_USB_EPR_STAT_RX_VALID, STM_USB_EPR_STAT_TX_DISABLED, STM_USB_EPR_EP_KIND_DBL_BUF, 0, 1); + + /* At first receive, we'll flip this back to 0 */ + ao_usb_out_rx_which = 1; #endif #if AO_USB_HAS_IN /* Set up the IN end point */ - ao_usb_bdt[AO_USB_IN_EPR].double_tx[0].addr = ao_usb_in_tx_offset[0]; - ao_usb_bdt[AO_USB_IN_EPR].double_tx[0].count = 0; - ao_usb_bdt[AO_USB_IN_EPR].double_tx[1].addr = ao_usb_in_tx_offset[1]; - ao_usb_bdt[AO_USB_IN_EPR].double_tx[1].count = 0; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[0].addr = ao_usb_in_tx_offset; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[0].count = 0; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[1].addr = ao_usb_in_tx_offset + AO_USB_IN_SIZE; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[1].count = 0; /* set 'our' buffer to 0, and the device buffer to 1 */ ao_usb_init_ep(AO_USB_IN_EPR, @@ -551,12 +534,17 @@ ao_usb_set_configuration(void) STM_USB_EPR_STAT_TX_NAK, STM_USB_EPR_EP_KIND_DBL_BUF, 0, 1); + + /* First transmit data goes to buffer 0 */ + ao_usb_in_tx_which = 0; #endif #if AO_USB_HAS_IN2 /* Set up the IN2 end point */ - ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = 0; - ao_usb_bdt[AO_USB_IN2_EPR].single.count_tx = 0; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[0].addr = ao_usb_in_tx2_offset; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[0].count = 0; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[1].addr = ao_usb_in_tx2_offset + AO_USB_IN_SIZE; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[1].count = 0; ao_usb_init_ep(AO_USB_IN2_EPR, AO_USB_IN2_EP, @@ -565,6 +553,9 @@ ao_usb_set_configuration(void) STM_USB_EPR_STAT_TX_NAK, STM_USB_EPR_EP_KIND_DBL_BUF, 0, 1); + + /* First transmit data goes to buffer 0 */ + ao_usb_in_tx2_which = 0; #endif ao_usb_in_flushed = 0; @@ -599,47 +590,36 @@ static uint16_t reset_count; */ static void -ao_usb_copy_tx(const uint8_t *src, uint16_t *base, uint16_t bytes) +ao_usb_tx_byte(uint16_t offset, uint8_t byte) { - while (bytes >= 2) { - *base++ = src[0] | (src[1] << 8); - src += 2; - bytes -= 2; - } - if (bytes) - *base = *src; + if (offset & 1) + ao_usb_packet_put(offset - 1, + ao_usb_packet_get(offset - 1) | ((uint16_t) byte) << 8); + else + ao_usb_packet_put(offset, (uint16_t) byte); } -static void -ao_usb_copy_rx(uint8_t *dst, uint16_t *base, uint16_t bytes) +static uint8_t +ao_usb_rx_byte(uint16_t offset) { - while (bytes >= 2) { - uint16_t s = *base++; - dst[0] = s; - dst[1] = s >> 8; - dst += 2; - bytes -= 2; - } - if (bytes) - *dst = *base; + if (offset & 1) + return (uint8_t) ((ao_usb_packet_get(offset - 1)) >> 8); + else + return (uint8_t) ao_usb_packet_get(offset); } -static inline void -ao_usb_tx_byte(uint16_t *base, uint8_t tx_count, char byte) +static void +ao_usb_copy_tx(const uint8_t *src, uint16_t offset, uint16_t bytes) { - if (tx_count & 1) - base[tx_count >> 1] |= ((uint16_t) byte) << 8; - else - base[tx_count >> 1] = (uint16_t) (uint8_t) byte; + while (bytes--) + ao_usb_tx_byte(offset++, *src++); } -static inline char -ao_usb_rx_byte(uint16_t *base, uint8_t rx_count) +static void +ao_usb_copy_rx(uint8_t *dst, uint16_t offset, uint16_t bytes) { - if (rx_count & 1) - return (char) (base[rx_count>>1] >> 8); - else - return (char) base[rx_count>>1]; + while (bytes--) + *dst++ = ao_usb_rx_byte(offset++); } /* Send an IN data packet */ @@ -664,12 +644,12 @@ ao_usb_ep0_flush(void) ao_usb_ep0_in_len -= this_len; debug_data ("Flush EP0 len %d:", this_len); - ao_usb_copy_tx(ao_usb_ep0_in_data, ao_usb_ep0_tx_buffer, this_len); + ao_usb_copy_tx(ao_usb_ep0_in_data, ao_usb_ep0_tx_offset, this_len); debug_data ("\n"); ao_usb_ep0_in_data += this_len; /* Mark the endpoint as TX valid to send the packet */ - ao_usb_bdt[AO_USB_CONTROL_EPR].single.count_tx = this_len; + stm_usb_bdt[AO_USB_CONTROL_EPR].single.count_tx = this_len; ao_usb_set_stat_tx(AO_USB_CONTROL_EPR, STM_USB_EPR_STAT_TX_VALID); debug ("queue tx. epr 0 now %08x\n", stm_usb.epr[AO_USB_CONTROL_EPR]); } @@ -678,7 +658,7 @@ ao_usb_ep0_flush(void) static void ao_usb_ep0_fill(void) { - uint16_t len = ao_usb_bdt[0].single.count_rx & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; + uint16_t len = stm_usb_bdt[0].single.count_rx & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; if (len > ao_usb_ep0_out_len) len = ao_usb_ep0_out_len; @@ -686,7 +666,7 @@ ao_usb_ep0_fill(void) /* Pull all of the data out of the packet */ debug_data ("Fill EP0 len %d:", len); - ao_usb_copy_rx(ao_usb_ep0_out_data, ao_usb_ep0_rx_buffer, len); + ao_usb_copy_rx(ao_usb_ep0_out_data, ao_usb_ep0_rx_offset, len); debug_data ("\n"); ao_usb_ep0_out_data += len; @@ -1058,7 +1038,7 @@ _ao_usb_in_send(void) ao_usb_in_pending = 1; if (ao_usb_tx_count != AO_USB_IN_SIZE) ao_usb_in_flushed = 1; - ao_usb_bdt[AO_USB_IN_EPR].double_tx[ao_usb_in_tx_which].count = ao_usb_tx_count; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[ao_usb_in_tx_which].count = ao_usb_tx_count; ao_usb_tx_count = 0; /* Toggle our usage */ @@ -1122,7 +1102,7 @@ ao_usb_putchar(char c) _ao_usb_in_wait(); ao_usb_in_flushed = 0; - ao_usb_tx_byte(ao_usb_in_tx_buffer[ao_usb_in_tx_which], ao_usb_tx_count++, c); + ao_usb_tx_byte(ao_usb_in_tx_offset + AO_USB_IN_SIZE * ao_usb_in_tx_which + ao_usb_tx_count++, c); /* Send the packet when full */ if (ao_usb_tx_count == AO_USB_IN_SIZE) { @@ -1146,11 +1126,15 @@ _ao_usb_in2_send(void) ao_usb_in2_pending = 1; if (ao_usb_tx2_count != AO_USB_IN_SIZE) ao_usb_in2_flushed = 1; - ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = ao_usb_in2_tx_offset[ao_usb_in2_tx_which]; - ao_usb_bdt[AO_USB_IN2_EPR].single.count_tx = ao_usb_tx2_count; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[ao_usb_in_tx2_which].count = ao_usb_tx2_count; ao_usb_tx2_count = 0; - ao_usb_in2_tx_which = 1 - ao_usb_in2_tx_which; + + /* Toggle our usage */ + ao_usb_in_tx2_which = 1 - ao_usb_in_tx2_which; + + /* Mark the outgoing buffer as valid */ _ao_usb_set_stat_tx(AO_USB_IN2_EPR, STM_USB_EPR_STAT_TX_VALID); + _tx_dbg0("in2_send end"); } @@ -1203,8 +1187,7 @@ ao_usb_putchar2(char c) _ao_usb_in2_wait(); ao_usb_in2_flushed = 0; - ao_usb_tx_byte(ao_usb_in2_tx_buffer[ao_usb_in2_tx_which], ao_usb_tx2_count, c); - ao_usb_tx2_count++; + ao_usb_tx_byte(ao_usb_in_tx2_offset + AO_USB_IN_SIZE * ao_usb_in_tx2_which + ao_usb_tx2_count++, c); /* Send the packet when full */ if (ao_usb_tx2_count == AO_USB_IN_SIZE) { @@ -1228,7 +1211,7 @@ _ao_usb_out_recv(void) /* Switch to new buffer */ ao_usb_out_rx_which = 1 - ao_usb_out_rx_which; - ao_usb_rx_count = ao_usb_bdt[AO_USB_OUT_EPR].double_rx[ao_usb_out_rx_which].count & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; + ao_usb_rx_count = stm_usb_bdt[AO_USB_OUT_EPR].double_rx[ao_usb_out_rx_which].count & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; ao_usb_rx_pos = 0; /* Toggle the SW_BUF_RX bit */ @@ -1262,7 +1245,7 @@ _ao_usb_pollchar(void) } /* Pull a character out of the fifo */ - c = ao_usb_rx_byte(ao_usb_out_rx_buffer[ao_usb_out_rx_which], ao_usb_rx_pos++); + c = ao_usb_rx_byte(ao_usb_out_rx_offset + ao_usb_out_rx_which * AO_USB_OUT_SIZE + ao_usb_rx_pos++); _rx_dbg1("char", c); return c; } @@ -1281,18 +1264,18 @@ ao_usb_getchar(void) #endif #if AO_USB_DIRECTIO -uint16_t * -ao_usb_alloc(void) -{ - uint16_t *buffer; - buffer = ao_usb_packet_buffer_addr(ao_usb_sram_addr); - ao_usb_sram_addr += AO_USB_IN_SIZE; - return buffer; +#if AO_USB_HAS_IN +uint8_t +ao_usb_alloc(uint16_t *buffers[2]) +{ + buffers[0] = ao_usb_packet_buffer_addr(ao_usb_in_tx_offset); + buffers[1] = ao_usb_packet_buffer_addr(ao_usb_in_tx_offset + AO_USB_IN_SIZE); + return ao_usb_in_tx_which; } -void -ao_usb_write(uint16_t *buffer, uint16_t len) +uint8_t +ao_usb_write(uint16_t len) { ao_arch_block_interrupts(); @@ -1304,12 +1287,6 @@ ao_usb_write(uint16_t *buffer, uint16_t len) continue; } - /* Flush any pending regular I/O */ - if (ao_usb_tx_count) { - _ao_usb_in_send(); - continue; - } - /* Wait for an idle IN buffer */ if (ao_usb_in_pending) { ao_sleep(&ao_usb_in_pending); @@ -1320,15 +1297,35 @@ ao_usb_write(uint16_t *buffer, uint16_t len) ao_usb_in_pending = 1; ao_usb_in_flushed = (len != AO_USB_IN_SIZE); - ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = ao_usb_packet_buffer_offset(buffer); - ao_usb_bdt[AO_USB_IN_EPR].single.count_tx = len; + + stm_usb_bdt[AO_USB_IN_EPR].double_tx[ao_usb_in_tx_which].count = len; + + /* Toggle our usage */ + ao_usb_in_tx_which = 1 - ao_usb_in_tx_which; + + /* Toggle the SW_BUF flag */ + _ao_usb_toggle_dtog(AO_USB_IN_EPR, 1, 0); + + /* Mark the outgoing buffer as valid */ _ao_usb_set_stat_tx(AO_USB_IN_EPR, STM_USB_EPR_STAT_TX_VALID); + ao_arch_release_interrupts(); + return ao_usb_in_tx_which; } +#endif #if AO_USB_HAS_IN2 -void -ao_usb_write2(uint16_t *buffer, uint16_t len) + +uint8_t +ao_usb_alloc2(uint16_t *buffers[2]) +{ + buffers[0] = ao_usb_packet_buffer_addr(ao_usb_in_tx2_offset); + buffers[1] = ao_usb_packet_buffer_addr(ao_usb_in_tx2_offset + AO_USB_IN_SIZE); + return ao_usb_in_tx2_which; +} + +uint8_t +ao_usb_write2(uint16_t len) { ao_arch_block_interrupts(); @@ -1340,12 +1337,6 @@ ao_usb_write2(uint16_t *buffer, uint16_t len) continue; } - /* Flush any pending regular I/O */ - if (ao_usb_tx2_count) { - _ao_usb_in2_send(); - continue; - } - /* Wait for an idle IN buffer */ if (ao_usb_in2_pending) { ao_sleep(&ao_usb_in2_pending); @@ -1356,10 +1347,20 @@ ao_usb_write2(uint16_t *buffer, uint16_t len) ao_usb_in2_pending = 1; ao_usb_in2_flushed = (len != AO_USB_IN_SIZE); - ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = ao_usb_packet_buffer_offset(buffer); - ao_usb_bdt[AO_USB_IN2_EPR].single.count_tx = len; + + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[ao_usb_in_tx2_which].count = len; + + /* Toggle our usage */ + ao_usb_in_tx2_which = 1 - ao_usb_in_tx2_which; + + /* Toggle the SW_BUF flag */ + _ao_usb_toggle_dtog(AO_USB_IN2_EPR, 1, 0); + + /* Mark the outgoing buffer as valid */ _ao_usb_set_stat_tx(AO_USB_IN2_EPR, STM_USB_EPR_STAT_TX_VALID); ao_arch_release_interrupts(); + + return ao_usb_in_tx2_which; } #endif #endif diff --git a/src/stmf0/registers.ld b/src/stmf0/registers.ld index 1f9862b1..c301a7ce 100644 --- a/src/stmf0/registers.ld +++ b/src/stmf0/registers.ld @@ -26,6 +26,7 @@ stm_crs = 0x40006c00; stm_bxcan = 0x40006400; stm_usb_sram = 0x40006000; +stm_usb_bdt = 0x40006000; stm_usb = 0x40005c00; stm_i2c1 = 0x40005400; diff --git a/src/stmf0/stm32f0.h b/src/stmf0/stm32f0.h index 277fa223..968c1295 100644 --- a/src/stmf0/stm32f0.h +++ b/src/stmf0/stm32f0.h @@ -2000,7 +2000,12 @@ union stm_usb_bdt { #define STM_USB_BDT_SIZE 8 +/* We'll use the first block of usb SRAM for the BDT */ extern uint8_t stm_usb_sram[] __attribute__((aligned(4))); +extern union stm_usb_bdt stm_usb_bdt[STM_USB_BDT_SIZE] __attribute__((aligned(4))); + +#define stm_usb_sram ((uint8_t *) 0x40006000) +#define stm_usb_bdt ((union stm_usb_bdt *) 0x40006000) struct stm_exti { vuint32_t imr; -- cgit v1.2.3 From 283553f0f118cef1dbcfbf5e86a43575a610d27f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 23:04:22 -0800 Subject: altos/scheme: Split tests out from build sources Run tests on both tiny and full scheme test programs. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_advanced_syntax.scheme | 86 +++++------- src/scheme/ao_scheme_basic_syntax.scheme | 61 +++------ src/scheme/ao_scheme_char.scheme | 64 ++++----- src/scheme/ao_scheme_port.scheme | 4 + src/scheme/ao_scheme_string.scheme | 22 +-- src/scheme/ao_scheme_vector.scheme | 14 +- src/scheme/test/Makefile | 1 + src/scheme/test/ao_scheme_test.c | 4 + src/scheme/test/ao_scheme_test.scheme | 175 ++++++++++++++++++++++++ src/scheme/tiny-test/Makefile | 2 + src/scheme/tiny-test/ao_scheme_test.c | 116 ---------------- src/scheme/tiny-test/ao_scheme_tiny_test.scheme | 56 ++++++++ 12 files changed, 347 insertions(+), 258 deletions(-) create mode 100644 src/scheme/test/ao_scheme_test.scheme delete mode 100644 src/scheme/tiny-test/ao_scheme_test.c create mode 100644 src/scheme/tiny-test/ao_scheme_tiny_test.scheme diff --git a/src/scheme/ao_scheme_advanced_syntax.scheme b/src/scheme/ao_scheme_advanced_syntax.scheme index 79d4ba65..4cddc803 100644 --- a/src/scheme/ao_scheme_advanced_syntax.scheme +++ b/src/scheme/ao_scheme_advanced_syntax.scheme @@ -40,20 +40,10 @@ '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) - ) - ) - ) +(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) @@ -175,7 +165,7 @@ ; `(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))) +`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) ; define a set of local ; variables all at once and @@ -229,29 +219,33 @@ ) -(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) +(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)) 3) -(_??_ (when #f (+ 1 2)) #f) +(when #t (+ 1 2)) +(when #f (+ 1 2)) (define unless (macro (test . l) `(cond ((not ,test) ,@l)))) -(_??_ (unless #f (+ 2 3)) 5) -(_??_ (unless #t (+ 2 3)) #f) +(unless #f (+ 2 3)) +(unless #t (+ 2 3)) (define (cdar l) (cdr (car l))) -(_??_ (cdar '((1 2) (3 4))) '(2)) +(cdar '((1 2) (3 4))) (define (cddr l) (cdr (cdr l))) -(_??_ (cddr '(1 2 3)) '(3)) +(cddr '(1 2 3)) (define (caddr l) (car (cdr (cdr l)))) -(_??_ (caddr '(1 2 3 4)) 3) +(caddr '(1 2 3 4)) (define (reverse list) (define (_r old new) @@ -263,7 +257,7 @@ (_r list ()) ) -(_??_ (reverse '(1 2 3)) '(3 2 1)) +(reverse '(1 2 3)) (define make-list (lambda (a . b) @@ -281,9 +275,9 @@ ) ) -(_??_ (make-list 10 'a) '(a a a a a a a a a a)) +(make-list 10 'a) -(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) +(make-list 10) (define for-each (lambda (proc . lists) @@ -299,20 +293,18 @@ ) ) -(_??_ (let ((a 0)) - (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) - a - ) - 6) +(let ((a 0)) + (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) + a + ) -(_??_ (call-with-current-continuation +(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) @@ -359,11 +351,11 @@ ) ) -(_??_ (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") +(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) @@ -388,15 +380,9 @@ ) ) -(_??_ (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)) +(do ((x 1 (+ x 1)) + (y 0) + ) + ((= x 10) y) + (set! y (+ y x)) + ) diff --git a/src/scheme/ao_scheme_basic_syntax.scheme b/src/scheme/ao_scheme_basic_syntax.scheme index 563364a9..4cd3e167 100644 --- a/src/scheme/ao_scheme_basic_syntax.scheme +++ b/src/scheme/ao_scheme_basic_syntax.scheme @@ -13,8 +13,6 @@ ; ; 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!) @@ -28,7 +26,7 @@ (begin (def! append - (lambda args + (lambda a (def! _a (lambda (a b) (cond ((null? a) b) @@ -45,7 +43,7 @@ ) ) ) - (_b args) + (_b a) ) ) 'append) @@ -122,7 +120,7 @@ ; execute to resolve macros -(_?_ (or #f #t) #t) +(or #f #t) (define and (macro a @@ -149,7 +147,7 @@ ; execute to resolve macros -(_?_ (and #t #f) #f) +(and #t #f) ; (if ) ; (if 3 2) 'yes) 'yes) -(_?_ (if (> 3 2) 'yes 'no) 'yes) -(_?_ (if (> 2 3) 'no 'yes) 'yes) -(_?_ (if (> 2 3) 'no) #f) +(if (> 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) (define letrec (macro (a . b) @@ -230,7 +228,7 @@ ) ) -(_?_ (letrec ((a 1) (b a)) (+ a b)) 2) +(letrec ((a 1) (b a)) (+ a b)) ; letrec is sufficient for let* @@ -259,10 +257,7 @@ ) ) -(_?_ (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))))) +(equal? '(a b c) '(a b c)) ; basic list accessors @@ -270,18 +265,6 @@ (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)) ) @@ -301,14 +284,14 @@ ) ) -(_??_ (member '(2) '((1) (2) (3))) '((2) (3))) -(_??_ (member '(4) '((1) (2) (3))) #f) +(member '(2) '((1) (2) (3))) +(member '(4) '((1) (2) (3))) (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) +(memq 2 '(1 2 3)) +(memq 4 '(1 2 3)) +(memq '(2) '((1) (2) (3))) (define (assoc a b . t?) (if (null? t?) @@ -324,12 +307,11 @@ ) ) +(assoc '(c) '((a 1) (b 2) ((c) 3))) + (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)) +(assq 'a '((a 1) (b 2) (c 3))) (define map (lambda (proc . lists) @@ -358,7 +340,7 @@ ) ) -(_??_ (map cadr '((a b) (d e) (g h))) '(b e h)) +(map cadr '((a b) (d e) (g h))) ; use map as for-each in basic ; mode @@ -430,8 +412,3 @@ (define (newline) (write-char #\newline)) (newline) - -(define (eof-object? a) - (equal? a 'eof) - ) - diff --git a/src/scheme/ao_scheme_char.scheme b/src/scheme/ao_scheme_char.scheme index c0353834..fdb7fa64 100644 --- a/src/scheme/ao_scheme_char.scheme +++ b/src/scheme/ao_scheme_char.scheme @@ -15,60 +15,60 @@ (define char? integer?) -(_??_ (char? #\q) #t) -(_??_ (char? "h") #f) +(char? #\q) +(char? "h") (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) +(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) #t) -(_??_ (char-lower-case? #\B) #f) -(_??_ (char-lower-case? #\0) #f) -(_??_ (char-lower-case? #\space) #f) +(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) #t) -(_??_ (char-alphabetic? #\B) #t) -(_??_ (char-alphabetic? #\0) #f) -(_??_ (char-alphabetic? #\space) #f) +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) (define (char-numeric? c) (<= #\0 c #\9)) -(_??_ (char-numeric? #\a) #f) -(_??_ (char-numeric? #\B) #f) -(_??_ (char-numeric? #\0) #t) -(_??_ (char-numeric? #\space) #f) +(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) #f) -(_??_ (char-whitespace? #\B) #f) -(_??_ (char-whitespace? #\0) #f) -(_??_ (char-whitespace? #\space) #t) +(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) #\A) -(_??_ (char-upcase #\B) #\B) -(_??_ (char-upcase #\0) #\0) -(_??_ (char-upcase #\space) #\space) +(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) #\a) -(_??_ (char-downcase #\B) #\b) -(_??_ (char-downcase #\0) #\0) -(_??_ (char-downcase #\space) #\space) +(char-downcase #\a) +(char-downcase #\B) +(char-downcase #\0) +(char-downcase #\space) (define (digit-value c) (if (char-numeric? c) @@ -76,5 +76,5 @@ #f) ) -(_??_ (digit-value #\1) 1) -(_??_ (digit-value #\a) #f) +(digit-value #\1) +(digit-value #\a) diff --git a/src/scheme/ao_scheme_port.scheme b/src/scheme/ao_scheme_port.scheme index e4fa06cc..886aed25 100644 --- a/src/scheme/ao_scheme_port.scheme +++ b/src/scheme/ao_scheme_port.scheme @@ -26,6 +26,10 @@ (newline) (newline (open-output-file "/dev/null")) +(define (eof-object? a) + (equal? a 'eof) + ) + (define (load name) (let ((p (open-input-file name)) (e)) diff --git a/src/scheme/ao_scheme_string.scheme b/src/scheme/ao_scheme_string.scheme index feeca37b..99f16fab 100644 --- a/src/scheme/ao_scheme_string.scheme +++ b/src/scheme/ao_scheme_string.scheme @@ -15,7 +15,7 @@ (define string (lambda chars (list->string chars))) -(_??_ (string #\a #\b #\c) "abc") +(string #\a #\b #\c) (define string-map (lambda (proc . strings) @@ -38,7 +38,7 @@ ) ) -(_??_ (string-map (lambda (x) (+ 1 x)) "HAL") "IBM") +(string-map (lambda (x) (+ 1 x)) "HAL") (define string-copy! (lambda (t a f . args) @@ -76,9 +76,9 @@ ) ) -(_??_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello ") -(_??_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello ") -(_??_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello ") +(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)) @@ -100,9 +100,9 @@ ) ) -(_??_ (string-copy "hello" 0 1) "h") -(_??_ (string-copy "hello" 1) "ello") -(_??_ (string-copy "hello") "hello") +(string-copy "hello" 0 1) +(string-copy "hello" 1) +(string-copy "hello") (define substring string-copy) @@ -130,8 +130,8 @@ ) ) -(_??_ (string-fill! (make-string 10) #\a) "aaaaaaaaaa") -(_??_ (string-fill! (make-string 10) #\a 1 2) " a ") +(string-fill! (make-string 10) #\a) +(string-fill! (make-string 10) #\a 1 2) (define string-for-each (lambda (proc . strings) @@ -153,4 +153,4 @@ ) ) -(_??_ (string-for-each write-char "IBM\n") #t) +(string-for-each write-char "IBM\n") diff --git a/src/scheme/ao_scheme_vector.scheme b/src/scheme/ao_scheme_vector.scheme index bf40204b..6c25aae5 100644 --- a/src/scheme/ao_scheme_vector.scheme +++ b/src/scheme/ao_scheme_vector.scheme @@ -35,7 +35,7 @@ ) ) -(_??_ (vector->string #(#\a #\b #\c) 0 2) "ab") +(vector->string #(#\a #\b #\c) 0 2) (define string->vector (lambda (s . args) @@ -58,7 +58,7 @@ ) ) -(_??_ (string->vector "hello" 0 2) #(#\h #\e)) +(string->vector "hello" 0 2) (define vector-copy! (lambda (t a f . args) @@ -98,7 +98,7 @@ ; simple vector-copy test -(_??_ (vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t")) +(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) @@ -121,7 +121,7 @@ ) ) -(_??_ (vector-copy #(1 2 3) 0 3) #(1 2 3)) +(vector-copy #(1 2 3) 0 3) (define vector-append (lambda a @@ -138,7 +138,7 @@ ) ) -(_??_ (vector-append #(1 2 3) #(4 5 6) #(7 8 9)) #(1 2 3 4 5 6 7 8 9)) +(vector-append #(1 2 3) #(4 5 6) #(7 8 9)) (define vector-fill! (lambda (v a . args) @@ -164,7 +164,7 @@ ) ) -(_??_ (vector-fill! (make-vector 3) #t 1 2) #(#f #t #f)) +(vector-fill! (make-vector 3) #t 1 2) ; like 'map', but for vectors @@ -189,4 +189,4 @@ ) ) -(_??_ (vector-map + #(1 2 3) #(4 5 6)) #(5 7 9)) +(vector-map + #(1 2 3) #(4 5 6)) diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index 686d809b..a8129217 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -19,6 +19,7 @@ CFLAGS=$(DFLAGS) $(OFLAGS) $(PGFLAGS) -g -Wall -Wextra -I. -I.. -Wpointer-arith ao-scheme: $(OBJS) cc $(CFLAGS) -o $@ $(OBJS) -lm + ./ao-scheme ao_scheme_test.scheme $(OBJS): $(HDRS) diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index ed10d3be..195b8b46 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -131,7 +131,9 @@ main (int argc, char **argv) usage(argv[0]); exit(0); case 'l': +#ifdef AO_SCHEME_FEATURE_POSIX ao_scheme_set_argv(&argv[argc]); +#endif run_file(optarg); break; default: @@ -139,7 +141,9 @@ main (int argc, char **argv) exit(1); } } +#ifdef AO_SCHEME_FEATURE_POSIX ao_scheme_set_argv(argv + optind); +#endif if (argv[optind]) { run_file(argv[optind]); } else { diff --git a/src/scheme/test/ao_scheme_test.scheme b/src/scheme/test/ao_scheme_test.scheme new file mode 100644 index 00000000..41aaeda1 --- /dev/null +++ b/src/scheme/test/ao_scheme_test.scheme @@ -0,0 +1,175 @@ + ; 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/tiny-test/Makefile b/src/scheme/tiny-test/Makefile index ca71a665..61ef687a 100644 --- a/src/scheme/tiny-test/Makefile +++ b/src/scheme/tiny-test/Makefile @@ -2,6 +2,7 @@ include ../Makefile-inc vpath %.o . vpath %.c .. +vpath ao_scheme_test.c ../test vpath %.h .. vpath %.scheme .. vpath ao_scheme_make_const ../make-const @@ -17,6 +18,7 @@ CFLAGS=-O0 -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wfo ao-scheme-tiny: $(OBJS) cc $(CFLAGS) -o $@ $(OBJS) -lm + ./ao-scheme-tiny ao_scheme_tiny_test.scheme $(OBJS): $(HDRS) diff --git a/src/scheme/tiny-test/ao_scheme_test.c b/src/scheme/tiny-test/ao_scheme_test.c deleted file mode 100644 index 89b8e5fa..00000000 --- a/src/scheme/tiny-test/ao_scheme_test.c +++ /dev/null @@ -1,116 +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 - -static char save_file[] = "scheme.image"; - -int -ao_scheme_os_save(void) -{ - FILE *save = fopen(save_file, "w"); - - if (!save) { - perror(save_file); - return 0; - } - fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); - fclose(save); - return 1; -} - -int -ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - fseek(restore, offset, SEEK_SET); - ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); - fclose(restore); - if (ret != 1) - return 0; - return 1; -} - -int -ao_scheme_os_restore(void) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); - fclose(restore); - if (ret != AO_SCHEME_POOL_TOTAL) - return 0; - return 1; -} - -int -main (int argc, char **argv) -{ - (void) argc; - - while (*++argv) { - FILE *in = fopen(*argv, "r"); - if (!in) { - perror(*argv); - exit(1); - } - ao_scheme_read_eval_print(in, stdout, false); - fclose(in); - } - ao_scheme_read_eval_print(stdin, stdout, true); - -#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 -} diff --git a/src/scheme/tiny-test/ao_scheme_tiny_test.scheme b/src/scheme/tiny-test/ao_scheme_tiny_test.scheme new file mode 100644 index 00000000..94c90ffe --- /dev/null +++ b/src/scheme/tiny-test/ao_scheme_tiny_test.scheme @@ -0,0 +1,56 @@ + ; 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)) + -- cgit v1.2.3 From bf37c22c6cdd4a90117bdc809e5c063a079082ad Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 23:05:02 -0800 Subject: altos/scheme: Allow individual lisp keywords to be feature-conditional This lets us build a smaller lisp that is just missing some aliases for existing functionality to save rom space. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.txt | 4 +-- src/scheme/ao_scheme_make_builtin | 51 ++++++++++++++++++++++++++++----------- 2 files changed, 39 insertions(+), 16 deletions(-) diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index 8f9a6381..fd29d607 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -49,8 +49,8 @@ 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? exact-integer? -all f_lambda numberp number? real? +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! diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin index 5b76944f..a34affce 100644 --- a/src/scheme/ao_scheme_make_builtin +++ b/src/scheme/ao_scheme_make_builtin @@ -1,10 +1,15 @@ #!/usr/bin/nickle +typedef struct { + string name; + string feature; +} lisp_name_t; + typedef struct { string feature; string type; string c_name; - string[*] lisp_names; + lisp_name_t[*] lisp_names; } builtin_t; string[string] type_map = { @@ -16,14 +21,26 @@ string[string] type_map = { "feature" => "feature", }; -string[*] +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) { - string[...] lisp = {}; + lisp_name_t[...] lisp = {}; if (dim(tokens) < 4) - return (string[1]) { tokens[dim(tokens) - 1] }; - return (string[dim(tokens)-3]) { [i] = tokens[i+3] }; + 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 @@ -98,7 +115,7 @@ dump_casename(builtin_t[*] builtins) { 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]); + builtins[i].c_name, builtins[i].lisp_names[0].name); dump_endif(builtins[i]); } printf("\tdefault: return (char *) \"???\";\n"); @@ -128,7 +145,7 @@ dump_arrayname(builtin_t[*] builtins) { dump_ifdef(builtins[i]); printf("\t[builtin_%s] = _ao_scheme_atom_", builtins[i].c_name); - cify_lisp(builtins[i].lisp_names[0]); + cify_lisp(builtins[i].lisp_names[0].name); printf(",\n"); dump_endif(builtins[i]); } @@ -180,9 +197,12 @@ dump_consts(builtin_t[*] builtins) { 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", - builtins[i].feature, - builtins[i].lisp_names[j], + feature, + builtins[i].lisp_names[j].name, builtins[i].type, builtins[i].c_name); } @@ -201,8 +221,8 @@ dump_atoms(builtin_t[*] builtins) { 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]); - printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); + cify_lisp(builtins[i].lisp_names[j].name); + printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j].name); } } } @@ -217,9 +237,12 @@ dump_atom_names(builtin_t[*] builtins) { 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", - builtins[i].feature, - builtins[i].lisp_names[j]); + feature, + builtins[i].lisp_names[j].name); } } } @@ -235,7 +258,7 @@ dump_syntax_atoms(builtin_t[*] builtins) { 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("\t\"%s\",\n", builtins[i].lisp_names[j].name); } } } -- cgit v1.2.3 From 6ae22601bbf018193ac093fb0f745ebe213bfb64 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 23:06:22 -0800 Subject: altos/scheme: remove debug code from vector write Signed-off-by: Keith Packard --- src/scheme/ao_scheme_vector.c | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index a716ca0c..e7328e32 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -84,7 +84,7 @@ 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, j; + unsigned int i; int was_marked = 0; struct vl *ve; @@ -103,17 +103,12 @@ ao_scheme_vector_write(FILE *out, ao_poly v, bool write) if (was_marked) { fputs("...", out); } else { - fputs("#(\n", out); + fputs("#(", out); for (i = 0; i < vector->length; i++) { - printf("%3d: ", i); - for (j = 0; j < vd; j++) - printf("."); + if (i != 0) + putc(' ', out); 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) -- cgit v1.2.3 From f8a967959b2f5ca3486ab3422f30fe4ad4ba17a8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 7 Jan 2018 23:06:51 -0800 Subject: altos/lambdakey-v1.0: Add LED function back in We've made things smaller, so there's (barely) space for this now. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 5 +++-- src/lambdakey-v1.0/ao_pins.h | 6 +++--- src/lambdakey-v1.0/ao_scheme_os.h | 2 +- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index cfa009bb..9d30c521 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -32,6 +32,7 @@ ALTOS_SRC = \ ao_interrupt.c \ ao_product.c \ ao_cmd.c \ + ao_led.c \ ao_notask.c \ ao_stdio.c \ ao_stdio_newlib.c \ @@ -72,8 +73,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: ao_scheme_make_const ao_scheme_basic_syntax.scheme ao_scheme_finish.scheme - $^ -o $@ -d GPIO,FLOAT,VECTOR,QUASI,BIGINT,POSIX,PORT,SAVE,UNDEF +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) stm-load $(PROG) diff --git a/src/lambdakey-v1.0/ao_pins.h b/src/lambdakey-v1.0/ao_pins.h index f330213d..58a75080 100644 --- a/src/lambdakey-v1.0/ao_pins.h +++ b/src/lambdakey-v1.0/ao_pins.h @@ -22,15 +22,15 @@ #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); }) +#define fputs(s,file) ({ (void) (file); ao_put_string(s); }) #undef getc #define getc(file) ({ (void) (file); getchar(); }) +#define fflush(file) ({ (void) (file); flush(); }) #define HAS_TASK 0 #define HAS_AO_DELAY 1 -#if 0 +#if 1 #define LED_PORT_ENABLE STM_RCC_AHBENR_IOPBEN #define LED_PORT (&stm_gpiob) #define LED_PIN_RED 4 diff --git a/src/lambdakey-v1.0/ao_scheme_os.h b/src/lambdakey-v1.0/ao_scheme_os.h index 6a2ab819..8af199c2 100644 --- a/src/lambdakey-v1.0/ao_scheme_os.h +++ b/src/lambdakey-v1.0/ao_scheme_os.h @@ -20,7 +20,7 @@ #include "ao.h" -#define AO_SCHEME_POOL 3584 +#define AO_SCHEME_POOL 3792 #define AO_SCHEME_TOKEN_MAX 64 #ifndef __BYTE_ORDER -- 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(-) 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 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 From b95db5819885da89504d5e11decfda98cfac37aa Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 12 Jan 2018 22:27:41 -0800 Subject: altoslib/altosuilib: Validate rom image is for target device This should avoid mis-programming devices with incorrect firmware. Signed-off-by: Keith Packard --- altoslib/AltosFlash.java | 10 ++- altoslib/AltosHexfile.java | 137 ++++++++++++++++++++++++++++++++++++++---- altoslib/AltosProgrammer.java | 6 +- altoslib/AltosRomconfig.java | 71 +++++++++++++++++----- altoslib/AltosSelfFlash.java | 41 +++++++++---- altoslib/AltosUsbId.java | 26 ++++++++ altoslib/Makefile.am | 1 + altosuilib/AltosFlashUI.java | 37 +++++++++++- 8 files changed, 281 insertions(+), 48 deletions(-) create mode 100644 altoslib/AltosUsbId.java diff --git a/altoslib/AltosFlash.java b/altoslib/AltosFlash.java index c8db1f77..9bf0da25 100644 --- a/altoslib/AltosFlash.java +++ b/altoslib/AltosFlash.java @@ -254,7 +254,7 @@ public class AltosFlash extends AltosProgrammer { clock_init(); int remain = image.data.length; - int flash_addr = image.address; + int flash_addr = (int) image.address; int image_start = 0; action("start", 0); @@ -295,7 +295,7 @@ public class AltosFlash extends AltosProgrammer { if (!aborted) { action("done", 100); if (debug != null) { - debug.set_pc(image.address); + debug.set_pc((int) image.address); debug.resume(); } } @@ -331,12 +331,16 @@ public class AltosFlash extends AltosProgrammer { rom_config = romconfig; } - public AltosRomconfig romconfig() throws InterruptedException { + public AltosRomconfig target_romconfig() throws InterruptedException { if (!check_rom_config()) return null; return rom_config; } + public AltosRomconfig image_romconfig() { + return new AltosRomconfig(image); + } + public AltosFlash(File file, AltosLink link, AltosFlashListener listener) throws IOException, FileNotFoundException, InterruptedException { this.file = file; diff --git a/altoslib/AltosHexfile.java b/altoslib/AltosHexfile.java index 7ab121ad..6aa98383 100644 --- a/altoslib/AltosHexfile.java +++ b/altoslib/AltosHexfile.java @@ -46,7 +46,7 @@ class HexFileInputStream extends PushbackInputStream { } class HexRecord implements Comparable { - public int address; + public long address; public int type; public byte checksum; public byte[] data; @@ -110,7 +110,14 @@ class HexRecord implements Comparable { public int compareTo(Object other) { HexRecord o = (HexRecord) other; - return address - o.address; + + long diff = address - o.address; + + if (diff > 0) + return 1; + if (diff < 0) + return -1; + return 0; } public String toString() { @@ -119,8 +126,8 @@ class HexRecord implements Comparable { public HexRecord(HexFileInputStream input) throws IOException, EOFException { read_state state = read_state.marker; - int nhexbytes = 0; - int hex = 0; + long nhexbytes = 0; + long hex = 0; int ndata = 0; byte got_checksum; @@ -154,7 +161,7 @@ class HexRecord implements Comparable { switch (state) { case length: - data = new byte[hex]; + data = new byte[(int) hex]; state = read_state.address; nhexbytes = 4; break; @@ -164,7 +171,7 @@ class HexRecord implements Comparable { nhexbytes = 2; break; case type: - type = hex; + type = (int) hex; if (data.length > 0) state = read_state.data; else @@ -211,12 +218,21 @@ class HexRecord implements Comparable { } public class AltosHexfile { - public int address; + public long address; + public long max_address; public byte[] data; LinkedList symlist = new LinkedList(); - public byte get_byte(int a) { - return data[a - address]; + public byte get_byte(long a) { + return data[(int) (a - address)]; + } + + public int get_u8(long a) { + return ((int) get_byte(a)) & 0xff; + } + + public int get_u16(long a) { + return get_u8(a) | (get_u8(a+1) << 8); } /* CC1111-based products have the romconfig stuff located @@ -237,6 +253,15 @@ public class AltosHexfile { new AltosHexsym("ao_usb_descriptors", ao_usb_descriptors_addr) }; + static final int AO_USB_DESC_DEVICE = 1; + static final int AO_USB_DESC_STRING = 3; + + static final int AO_ROMCONFIG_VERSION_INDEX = 0; + static final int AO_ROMCONFIG_CHECK_INDEX = 1; + static final int AO_SERIAL_NUMBER_INDEX = 2; + static final int AO_RADIO_CAL_INDEX = 3; + static final int AO_USB_DESCRIPTORS_INDEX = 4; + private void add_cc_symbols() { for (int i = 0; i < cc_symbols.length; i++) symlist.add(cc_symbols[i]); @@ -262,6 +287,92 @@ public class AltosHexfile { return null; } + private long find_usb_descriptors() { + AltosHexsym usb_descriptors = lookup_symbol("ao_usb_descriptors"); + long a; + + if (usb_descriptors == null) + return -1; + + /* Walk the descriptors looking for the device */ + a = usb_descriptors.address; + while (get_u8(a+1) != AO_USB_DESC_DEVICE) { + int delta = get_u8(a); + a += delta; + if (delta == 0 || a >= max_address) + return -1; + } + return a; + } + + public AltosUsbId find_usb_id() { + long a = find_usb_descriptors(); + + if (a == -1) + return null; + + /* Walk the descriptors looking for the device */ + while (get_u8(a+1) != AO_USB_DESC_DEVICE) { + int delta = get_u8(a); + a += delta; + if (delta == 0 || a >= max_address) + return null; + } + + return new AltosUsbId(get_u16(a + 8), + get_u16(a + 10)); + } + + public String find_usb_product() { + long a = find_usb_descriptors(); + int num_strings; + int product_string; + + if (a == -1) + return null; + + product_string = get_u8(a+15); + + /* Walk the descriptors looking for the device */ + num_strings = 0; + for (;;) { + if (get_u8(a+1) == AO_USB_DESC_STRING) { + ++num_strings; + if (num_strings == product_string + 1) + break; + } + + int delta = get_u8(a); + a += delta; + if (delta == 0 || a >= max_address) + return null; + } + + int product_len = get_u8(a); + + System.out.printf("Product is at %x length %d\n", a, product_len); + + for (int i = 0; i < product_len; i++) + System.out.printf(" %2d: %02x\n", i, get_u8(a+i)); + + if (product_len <= 0) + return null; + + String product = ""; + + for (int i = 0; i < product_len - 2; i += 2) { + int c = get_u16(a + 2 + i); + + System.out.printf("character %x\n", c); + + product += Character.toString((char) c); + } + + System.out.printf("product %s\n", product); + + return product; + } + private String make_string(byte[] data, int start, int length) { String s = ""; for (int i = 0; i < length; i++) @@ -269,9 +380,10 @@ public class AltosHexfile { return s; } - public AltosHexfile(byte[] bytes, int offset) { + public AltosHexfile(byte[] bytes, long offset) { data = bytes; address = offset; + max_address = address + bytes.length; } public AltosHexfile(FileInputStream file) throws IOException { @@ -335,7 +447,8 @@ public class AltosHexfile { throw new IOException("hex file too large"); data = new byte[(int) (bound - base)]; - address = (int) base; + address = base; + max_address = bound; Arrays.fill(data, (byte) 0xff); /* Paint the records into the new array */ @@ -366,4 +479,4 @@ public class AltosHexfile { } } } -} \ No newline at end of file +} diff --git a/altoslib/AltosProgrammer.java b/altoslib/AltosProgrammer.java index 0a828a32..e4f57578 100644 --- a/altoslib/AltosProgrammer.java +++ b/altoslib/AltosProgrammer.java @@ -28,7 +28,9 @@ public abstract class AltosProgrammer { abstract public void abort(); - abstract public AltosRomconfig romconfig() throws InterruptedException; + abstract public AltosRomconfig target_romconfig() throws InterruptedException; + + abstract public AltosRomconfig image_romconfig(); abstract public void set_romconfig(AltosRomconfig config); -} \ No newline at end of file +} diff --git a/altoslib/AltosRomconfig.java b/altoslib/AltosRomconfig.java index 46ee2b6e..1fbb4115 100644 --- a/altoslib/AltosRomconfig.java +++ b/altoslib/AltosRomconfig.java @@ -26,20 +26,31 @@ public class AltosRomconfig { public int check; public int serial_number; public int radio_calibration; + public AltosUsbId usb_id; + public String usb_product; - static private int find_offset(AltosHexfile hexfile, String name, int len) throws AltosNoSymbol { + static private long find_address(AltosHexfile hexfile, String name, int len) throws AltosNoSymbol { AltosHexsym symbol = hexfile.lookup_symbol(name); - if (symbol == null) - throw new AltosNoSymbol(name); - int offset = (int) symbol.address - hexfile.address; - if (offset < 0 || hexfile.data.length < offset + len) + if (symbol == null) { + System.out.printf("no symbol %s\n", name); throw new AltosNoSymbol(name); - return offset; + } + if (hexfile.address <= symbol.address && symbol.address + len < hexfile.max_address) { + System.out.printf("%s: %x\n", name, symbol.address); + return symbol.address; + } + System.out.printf("invalid symbol addr %x range is %x - %x\n", + symbol.address, hexfile.address, hexfile.max_address); + throw new AltosNoSymbol(name); + } + + static private int find_offset(AltosHexfile hexfile, String name, int len) throws AltosNoSymbol { + return (int) (find_address(hexfile, name, len) - hexfile.address); } static int get_int(AltosHexfile hexfile, String name, int len) throws AltosNoSymbol { byte[] bytes = hexfile.data; - int start = find_offset(hexfile, name, len); + int start = (int) find_offset(hexfile, name, len); int v = 0; int o = 0; @@ -112,13 +123,17 @@ public class AltosRomconfig { public AltosRomconfig(AltosHexfile hexfile) { try { + System.out.printf("Attempting symbols\n"); version = get_int(hexfile, ao_romconfig_version, 2); + System.out.printf("version %d\n", version); check = get_int(hexfile, ao_romconfig_check, 2); + System.out.printf("check %d\n", check); if (check == (~version & 0xffff)) { switch (version) { case 2: case 1: serial_number = get_int(hexfile, ao_serial_number, 2); + System.out.printf("serial %d\n", serial_number); try { radio_calibration = get_int(hexfile, ao_radio_cal, 4); } catch (AltosNoSymbol missing) { @@ -128,6 +143,19 @@ public class AltosRomconfig { break; } } + System.out.printf("attempting usbid\n"); + usb_id = hexfile.find_usb_id(); + if (usb_id == null) + System.out.printf("No usb id\n"); + else + System.out.printf("usb id: %04x:%04x\n", + usb_id.vid, usb_id.pid); + usb_product = hexfile.find_usb_product(); + if (usb_product == null) + System.out.printf("No usb product\n"); + else + System.out.printf("usb product: %s\n", usb_product); + } catch (AltosNoSymbol missing) { valid = false; } @@ -137,9 +165,16 @@ public class AltosRomconfig { ao_romconfig_version, ao_romconfig_check, ao_serial_number, - ao_radio_cal + ao_radio_cal, + ao_usb_descriptors, }; + private static int fetch_len(String name) { + if (name.equals(ao_usb_descriptors)) + return 256; + return 2; + } + private final static String[] required_names = { ao_romconfig_version, ao_romconfig_check, @@ -153,13 +188,16 @@ public class AltosRomconfig { return false; } - public static int fetch_base(AltosHexfile hexfile) throws AltosNoSymbol { - int base = 0x7fffffff; + public static long fetch_base(AltosHexfile hexfile) throws AltosNoSymbol { + long base = 0xffffffffL; for (String name : fetch_names) { try { - int addr = find_offset(hexfile, name, 2) + hexfile.address; + int len = fetch_len(name); + long addr = find_address(hexfile, name, len); + if (addr < base) base = addr; + System.out.printf("symbol %s at %x base %x\n", name, addr, base); } catch (AltosNoSymbol ns) { if (name_required(name)) throw (ns); @@ -168,19 +206,22 @@ public class AltosRomconfig { return base; } - public static int fetch_bounds(AltosHexfile hexfile) throws AltosNoSymbol { - int bounds = 0; + public static long fetch_bounds(AltosHexfile hexfile) throws AltosNoSymbol { + long bounds = 0; for (String name : fetch_names) { try { - int addr = find_offset(hexfile, name, 2) + hexfile.address; + int len = fetch_len(name); + long addr = find_address(hexfile, name, len) + len; if (addr > bounds) bounds = addr; + System.out.printf("symbol %s at %x bounds %x\n", name, addr, bounds); } catch (AltosNoSymbol ns) { if (name_required(name)) throw (ns); } } - return bounds + 2; + + return bounds; } public void write (AltosHexfile hexfile) throws IOException { diff --git a/altoslib/AltosSelfFlash.java b/altoslib/AltosSelfFlash.java index 53782172..c7ea147f 100644 --- a/altoslib/AltosSelfFlash.java +++ b/altoslib/AltosSelfFlash.java @@ -45,18 +45,33 @@ public class AltosSelfFlash extends AltosProgrammer { int b; byte[] data = new byte[len]; + System.out.printf("read_memory %x %d\n", addr, len); for (int offset = 0; offset < len; offset += 0x100) { link.printf("R %x\n", addr + offset); byte[] reply = link.get_binary_reply(5000, 0x100); if (reply == null) throw new IOException("Read device memory timeout"); - for (b = 0; b < len; b++) + for (b = 0; b < 0x100 && b + offset < len; b++) data[b+offset] = reply[b]; } return data; } + AltosHexfile read_hexfile(long addr, int len) throws InterruptedException { + try { + byte[] mem = read_memory(addr, len); + + AltosHexfile hexfile = new AltosHexfile(mem, addr); + + if (image != null) + hexfile.add_symbols(image); + return hexfile; + } catch (IOException ie) { + return null; + } + } + void write_memory(long addr, byte[] data, int start, int len) { int b; link.printf("W %x\n", addr); @@ -143,18 +158,14 @@ public class AltosSelfFlash extends AltosProgrammer { private AltosHexfile get_rom() throws InterruptedException { try { - int base = AltosRomconfig.fetch_base(image); - int bounds = AltosRomconfig.fetch_bounds(image); - byte[] data = read_memory(base, bounds - base); - AltosHexfile hexfile = new AltosHexfile(data, base); - hexfile.add_symbols(image); - return hexfile; - } catch (AltosNoSymbol none) { - return null; - } catch (IOException ie) { + long base = AltosRomconfig.fetch_base(image); + long bounds = AltosRomconfig.fetch_bounds(image); + + System.out.printf("rom base %x bounds %x\n", base, bounds); + return read_hexfile(base, (int) (bounds - base)); + } catch (AltosNoSymbol ns) { return null; } - } public boolean check_rom_config() throws InterruptedException { @@ -173,12 +184,16 @@ public class AltosSelfFlash extends AltosProgrammer { rom_config = romconfig; } - public AltosRomconfig romconfig() throws InterruptedException { + public AltosRomconfig target_romconfig() throws InterruptedException { if (!check_rom_config()) return null; return rom_config; } + public AltosRomconfig image_romconfig() { + return new AltosRomconfig(image); + } + public AltosSelfFlash(File file, AltosLink link, AltosFlashListener listener) throws IOException, FileNotFoundException, InterruptedException { this.file = file; @@ -187,4 +202,4 @@ public class AltosSelfFlash extends AltosProgrammer { input = new FileInputStream(file); image = new AltosHexfile(input); } -} \ No newline at end of file +} diff --git a/altoslib/AltosUsbId.java b/altoslib/AltosUsbId.java new file mode 100644 index 00000000..e3794304 --- /dev/null +++ b/altoslib/AltosUsbId.java @@ -0,0 +1,26 @@ +/* + * 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. + */ + +package org.altusmetrum.altoslib_12; + +public class AltosUsbId { + public int vid; + public int pid; + + + public AltosUsbId(int vid, int pid) { + this.vid = vid; + this.pid = pid; + } +} diff --git a/altoslib/Makefile.am b/altoslib/Makefile.am index 2a1cb8e4..7c5d767d 100644 --- a/altoslib/Makefile.am +++ b/altoslib/Makefile.am @@ -99,6 +99,7 @@ altoslib_JAVA = \ AltosRomconfig.java \ AltosSavedState.java \ AltosSelfFlash.java \ + AltosUsbId.java \ AltosSensorMM.java \ AltosSensorEMini.java \ AltosSensorTM.java \ diff --git a/altosuilib/AltosFlashUI.java b/altosuilib/AltosFlashUI.java index ca089ca8..c717e47c 100644 --- a/altosuilib/AltosFlashUI.java +++ b/altosuilib/AltosFlashUI.java @@ -276,8 +276,37 @@ public class AltosFlashUI return true; } - boolean update_rom_config_info(AltosRomconfig existing_config) { + boolean rom_config_matches (AltosRomconfig a, AltosRomconfig b) { + if (a.usb_id != null && b.usb_id != null && + (a.usb_id.vid != b.usb_id.vid || + a.usb_id.pid != b.usb_id.pid)) + return false; + + if (a.usb_product != null && b.usb_product != null && + !a.usb_product.equals(b.usb_product)) + return false; + + return true; + } + + boolean update_rom_config_info(AltosRomconfig existing_config, AltosRomconfig image_config) { AltosRomconfig new_config; + + if (!rom_config_matches(existing_config, image_config)) { + int ret = JOptionPane.showConfirmDialog(this, + String.format("Device is %04x:%04x %s\nImage is %04x:%04x %s\nFlash anyways?", + existing_config.usb_id.vid, + existing_config.usb_id.pid, + existing_config.usb_product, + image_config.usb_id.vid, + image_config.usb_id.pid, + image_config.usb_product), + "Image doesn't match Device", + JOptionPane.YES_NO_OPTION); + if (ret != JOptionPane.YES_OPTION) + return false; + } + new_config = AltosRomconfigUI.show(frame, existing_config); if (new_config == null) return false; @@ -335,13 +364,15 @@ public class AltosFlashUI else programmer = new AltosSelfFlash(ui.file, link, this); - final AltosRomconfig current_config = programmer.romconfig(); + final AltosRomconfig current_config = programmer.target_romconfig(); + + final AltosRomconfig image_config = programmer.image_romconfig(); final Semaphore await_rom_config = new Semaphore(0); SwingUtilities.invokeLater(new Runnable() { public void run() { ui.programmer = programmer; - ui.update_rom_config_info(current_config); + ui.update_rom_config_info(current_config, image_config); await_rom_config.release(); } }); -- cgit v1.2.3 From 54e8e033ccf47526e5ff08f93c105ef75334924e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 13 Jan 2018 21:29:08 -0800 Subject: libaltos: Use case-insensitive compare when matching BT MACs We use the BT MAC vendor portion to figure out which port to connect to as that is simpler and takes less network traffic than actually doing discovery. However, on Windows, we were generating the address in lower case and comparing against upper case vendors, which didn't work out too well. Signed-off-by: Keith Packard --- libaltos/libaltos_common.c | 31 +++++++++++++++++++++++-------- libaltos/libaltos_windows.c | 4 ++-- 2 files changed, 25 insertions(+), 10 deletions(-) diff --git a/libaltos/libaltos_common.c b/libaltos/libaltos_common.c index f577de02..713a775c 100644 --- a/libaltos/libaltos_common.c +++ b/libaltos/libaltos_common.c @@ -76,24 +76,39 @@ altos_putchar(struct altos_file *file, char c) } struct bt_vendor_map { - char vendor[10]; - int port; + const char vendor[10]; + int port; }; static const struct bt_vendor_map altos_bt_vendor_map[] = { { .vendor = "00:12:6f:", 1 }, /* Rayson */ - { .vendor = "8C:DE:52:", 6 }, /* ISSC */ - { .vendor = "D8:80:39:", 6 }, /* Microchip */ + { .vendor = "8c:de:52:", 6 }, /* ISSC */ + { .vendor = "d8:80:39:", 6 }, /* Microchip */ }; #define NUM_BT_VENDOR_MAP (sizeof altos_bt_vendor_map / sizeof altos_bt_vendor_map[0]) #define BT_PORT_DEFAULT 1 +static inline int +ao_tolower(int c) { + if ('A' <= c && c <= 'Z') + return c + 'a' - 'A'; + return c; +} + int altos_bt_port(struct altos_bt_device *device) { - unsigned i; - for (i = 0; i < NUM_BT_VENDOR_MAP; i++) - if (strncmp (device->addr, altos_bt_vendor_map[i].vendor, strlen(altos_bt_vendor_map[i].vendor)) == 0) - return altos_bt_vendor_map[i].port; + unsigned i, j; + for (i = 0; i < NUM_BT_VENDOR_MAP; i++) { + const char *vendor = altos_bt_vendor_map[i].vendor; + for (j = 0; ; j++) { + if (vendor[j] == '\0') + return altos_bt_vendor_map[i].port; + if (device->addr[j] == '\0') + break; + if (ao_tolower(device->addr[j]) != vendor[j]) + break; + } + } return BT_PORT_DEFAULT; } diff --git a/libaltos/libaltos_windows.c b/libaltos/libaltos_windows.c index 4f9f1807..846e2217 100644 --- a/libaltos/libaltos_windows.c +++ b/libaltos/libaltos_windows.c @@ -639,7 +639,7 @@ static void ba2str(BTH_ADDR ba, char *str) { - sprintf(str, "%02x:%02x:%02x:%02x:%02x:%02x", + sprintf(str, "%02X:%02X:%02X:%02X:%02X:%02X", get_byte(ba, 0), get_byte(ba, 1), get_byte(ba, 2), @@ -755,8 +755,8 @@ altos_bt_open(struct altos_bt_device *device) altos_set_last_winsock_error(); closesocket(file->socket); free(file); + log_message("Connection attempted to address %s port %d\n", device->addr, sockaddr_bth.port); return NULL; } return &file->file; } - -- cgit v1.2.3 From 78a90fc760b88ab66c5c238289afc38356e29d8a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 12 Feb 2018 15:36:12 -0800 Subject: Add TeleGPS v2.0 binaries to distribution Signed-off-by: Keith Packard --- altosui/Makefile.am | 3 ++- altosui/altos-windows.nsi.in | 1 + telegps/Makefile.am | 3 ++- telegps/telegps-windows.nsi.in | 1 + 4 files changed, 6 insertions(+), 2 deletions(-) diff --git a/altosui/Makefile.am b/altosui/Makefile.am index 6f206c3d..805c5550 100644 --- a/altosui/Makefile.am +++ b/altosui/Makefile.am @@ -150,7 +150,8 @@ FIRMWARE_EMEGA_1_0=$(top_srcdir)/src/easymega-v1.0/easymega-v1.0-$(VERSION).ihx FIRMWARE_EMEGA=$(FIRMWARE_EMEGA_1_0) FIRMWARE_TGPS_1_0=$(top_srcdir)/src/telegps-v1.0/telegps-v1.0-$(VERSION).ihx -FIRMWARE_TGPS=$(FIRMWARE_TGPS_1_0) +FIRMWARE_TGPS_2_0=$(top_srcdir)/src/telegps-v2.0/telegps-v2.0-$(VERSION).ihx +FIRMWARE_TGPS=$(FIRMWARE_TGPS_1_0) $(FIRMWARE_TGPS_2_0) FIRMWARE=$(FIRMWARE_TM) $(FIRMWARE_TELEMINI) $(FIRMWARE_TD) $(FIRMWARE_TBT) $(FIRMWARE_TMEGA) $(FIRMWARE_EMINI) $(FIRMWARE_TGPS) $(FIRMWARE_EMEGA) diff --git a/altosui/altos-windows.nsi.in b/altosui/altos-windows.nsi.in index 31139513..23d6f6bd 100644 --- a/altosui/altos-windows.nsi.in +++ b/altosui/altos-windows.nsi.in @@ -128,6 +128,7 @@ Section "Firmware" File "../src/telemini-v1.0/telemini-v1.0-${VERSION}.ihx" File "../src/telemini-v3.0/telemini-v3.0-${VERSION}.ihx" File "../src/telegps-v1.0/telegps-v1.0-${VERSION}.ihx" + File "../src/telegps-v2.0/telegps-v2.0-${VERSION}.ihx" File "../src/teledongle-v0.2/teledongle-v0.2-${VERSION}.ihx" File "../src/teledongle-v3.0/teledongle-v3.0-${VERSION}.ihx" File "../src/telebt-v1.0/telebt-v1.0-${VERSION}.ihx" diff --git a/telegps/Makefile.am b/telegps/Makefile.am index 9dd2ceac..2fe231f1 100644 --- a/telegps/Makefile.am +++ b/telegps/Makefile.am @@ -112,7 +112,8 @@ FIRMWARE_TBT_4_0=$(top_srcdir)/src/telebt-v4.0/telebt-v4.0-$(VERSION).ihx FIRMWARE_TBT=$(FIRMWARE_TBT_1_0) $(FIRMWARE_TBT_3_0) $(FIRMWARE_TBT_4_0) FIRMWARE_TG_1_0=$(top_srcdir)/src/telegps-v1.0/telegps-v1.0-$(VERSION).ihx -FIRMWARE_TG=$(FIRMWARE_TG_1_0) +FIRMWARE_TG_2_0=$(top_srcdir)/src/telegps-v2.0/telegps-v2.0-$(VERSION).ihx +FIRMWARE_TG=$(FIRMWARE_TG_1_0) $(FIRMWARE_TG_2_0) FIRMWARE=$(FIRMWARE_TG) $(FIRMWARE_TD) $(FIRMWARE_TBT) diff --git a/telegps/telegps-windows.nsi.in b/telegps/telegps-windows.nsi.in index d0cd969c..e6ce9f84 100644 --- a/telegps/telegps-windows.nsi.in +++ b/telegps/telegps-windows.nsi.in @@ -121,6 +121,7 @@ Section "TeleGPS, TeleDongle and TeleBT Firmware" SetOutPath $INSTDIR File "../src/telegps-v1.0/telegps-v1.0-${VERSION}.ihx" + File "../src/telegps-v2.0/telegps-v2.0-${VERSION}.ihx" File "../src/teledongle-v0.2/teledongle-v0.2-${VERSION}.ihx" File "../src/teledongle-v3.0/teledongle-v3.0-${VERSION}.ihx" File "../src/telebt-v1.0/telebt-v1.0-${VERSION}.ihx" -- cgit v1.2.3 From 46d8197bb80ce3fe4cdc7b36c3be211366093bd5 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 16 Mar 2018 14:49:04 -0700 Subject: ao-bringup: Don't wait for user when testing EasyMini igniters I always have the LEDs ready to go before starting the turnon process. Signed-off-by: Keith Packard --- ao-bringup/test-easymini | 2 +- ao-bringup/test-igniters-nowait | 26 ++++++++++++++++++++++++++ 2 files changed, 27 insertions(+), 1 deletion(-) create mode 100755 ao-bringup/test-igniters-nowait diff --git a/ao-bringup/test-easymini b/ao-bringup/test-easymini index 7850b550..ddcfcd54 100755 --- a/ao-bringup/test-easymini +++ b/ao-bringup/test-easymini @@ -21,7 +21,7 @@ while [ $found -eq 0 ]; do echo -e '\e[34m'Testing $product $serial $dev'\e[39m' echo "" - ./test-igniters "$dev" drogue main + ./test-igniters-nowait "$dev" drogue main echo "" echo "Testing baro sensor" diff --git a/ao-bringup/test-igniters-nowait b/ao-bringup/test-igniters-nowait new file mode 100755 index 00000000..849f91de --- /dev/null +++ b/ao-bringup/test-igniters-nowait @@ -0,0 +1,26 @@ +#!/bin/sh + +dev="$1" +shift + +for igniter in "$@"; do + pass="n" + while [ $pass != "y" ]; do + + echo "Testing $igniter igniter." + ../ao-tools/ao-test-igniter/ao-test-igniter --tty="$dev" $igniter + + case $? in + 0) + echo "pass" + pass="y" + ;; + *) + echo -n "Failed. Try again. Press enter to continue..." + read foo < /dev/tty + ;; + esac + done +done + +exit 0 -- cgit v1.2.3 From 7068149704e6de67ece670227445e987421cd600 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 16 Mar 2018 14:50:29 -0700 Subject: chaoskey: Create unified ROM image with both loader and app Flash the whole thing all at once to reduce the number of steps during turnon. Signed-off-by: Keith Packard --- ao-bringup/turnon_chaoskey | 8 ++++---- src/chaoskey-v1.0/Makefile | 9 ++++++++- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/ao-bringup/turnon_chaoskey b/ao-bringup/turnon_chaoskey index 4a255bff..d710e5ff 100755 --- a/ao-bringup/turnon_chaoskey +++ b/ao-bringup/turnon_chaoskey @@ -24,14 +24,14 @@ echo "Expectations:" echo "\tChaosKey v$VERSION powered from USB" echo -FLASH_FILE=~/altusmetrumllc/Binaries/loaders/chaoskey-v1.0-altos-flash-*.bin -ALTOS_FILE=~/altusmetrumllc/Binaries/chaoskey-v1.0-*.elf +FLASH_FILE=~/altusmetrumllc/Binaries/chaoskey-v1.0-all-*.bin +#ALTOS_FILE=~/altusmetrumllc/Binaries/chaoskey-v1.0-*.elf $DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE || true -sleep 2 +#sleep 2 -$USBLOAD --serial=1 $ALTOS_FILE || exit 1 +#$USBLOAD --serial=1 $ALTOS_FILE || exit 1 sleep 1 diff --git a/src/chaoskey-v1.0/Makefile b/src/chaoskey-v1.0/Makefile index f2c168ba..dea5b483 100644 --- a/src/chaoskey-v1.0/Makefile +++ b/src/chaoskey-v1.0/Makefile @@ -51,12 +51,13 @@ CFLAGS = $(PRODUCT_DEF) $(STMF0_CFLAGS) -g -Os PROGNAME=chaoskey-v1.0 PROG=$(PROGNAME)-$(VERSION).elf HEX=$(PROGNAME)-$(VERSION).ihx +BIN=$(PROGNAME)-all-$(VERSION).bin METAINFO=org.altusmetrum.ChaosKey.metainfo.xml SRC=$(ALTOS_SRC) ao_chaoskey.c OBJ=$(SRC:.c=.o) -all: $(PROG) $(HEX) +all: $(PROG) $(HEX) $(BIN) $(PROG): Makefile $(OBJ) altos.ld $(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $(PROG) $(OBJ) $(LIBS) @@ -66,6 +67,12 @@ ao_product.h: ao-make-product.5c ../Version $(OBJ): $(INC) +$(BIN): $(PROG) $(LOADER) + $(MAKEBIN) --output=$@ --base=$(FLASH_ADDR) $(LOADER) $(PROG) + +$(LOADER): + +cd flash-loader && make + %.cab: $(PROG) $(HEX) $(METAINFO) gcab --create --nopath $@ $(PROG) $(HEX) $(METAINFO) -- cgit v1.2.3 From 788d02a3caf0f14f3c84ff6ae7e2a2fff302e91b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 16 Mar 2018 14:51:22 -0700 Subject: ao-bringup: Check for Loader USB id before attempting dfu-util This lets me restart the turnon process after the boot loader has been flashed. Signed-off-by: Keith Packard --- ao-bringup/turnon_easymini | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ao-bringup/turnon_easymini b/ao-bringup/turnon_easymini index 7db72665..3bef3145 100755 --- a/ao-bringup/turnon_easymini +++ b/ao-bringup/turnon_easymini @@ -52,11 +52,13 @@ ALTOS_FILE=~/altusmetrumllc/Binaries/easymini-v2.0-*.elf #FLASH_FILE=../src/$BASE-v$VERSION/flash-loader/$BASE-v$VERSION-altos-flash-*.elf #ALTOS_FILE=../src/$BASE-v$VERSION/*.ihx -echo $DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE +if lsusb -d 0483:df11 | grep -q STM; then + echo $DFU_UTIL -v -v -R -a 0 -s 0x08000000:leave -D $FLASH_FILE -$DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE || exit 1 + $DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE -sleep 2 + sleep 2 +fi echo $USBLOAD $ALTOS_FILE -- cgit v1.2.3 From 1ea6188a9c78ab0642001110cac6c3b35e8ccc88 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 16 Mar 2018 14:52:09 -0700 Subject: ao-usbload: Flip product names in loader error message I was reversing the 'target' vs 'image' names in the error message, leading to a bit of confusion. Signed-off-by: Keith Packard --- ao-tools/ao-usbload/ao-usbload.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ao-tools/ao-usbload/ao-usbload.c b/ao-tools/ao-usbload/ao-usbload.c index 758eb696..31ee138a 100644 --- a/ao-tools/ao-usbload/ao-usbload.c +++ b/ao-tools/ao-usbload/ao-usbload.c @@ -402,9 +402,9 @@ main (int argc, char **argv) old_len = ucs2len(old_product); if (new_len != old_len || memcmp(new_product, old_product, new_len * 2) != 0) { fprintf(stderr, "USB product mismatch (device is "); - putucs2str(new_product, stderr); - fprintf(stderr, ", image is "); putucs2str(old_product, stderr); + fprintf(stderr, ", image is "); + putucs2str(new_product, stderr); fprintf(stderr, ")\n"); done(cc, 1); } -- cgit v1.2.3 From 4894d965d73231b5c74810d826c7c97fa1bd7803 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 16 Mar 2018 14:53:14 -0700 Subject: altos: Make panic beeps use fixed frequencies This ensures that the beeps will work even before the configuration has been loaded. Signed-off-by: Keith Packard --- src/kernel/ao_beep.h | 6 ++++++ src/kernel/ao_panic.c | 8 ++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/src/kernel/ao_beep.h b/src/kernel/ao_beep.h index 085dd5b1..1306af62 100644 --- a/src/kernel/ao_beep.h +++ b/src/kernel/ao_beep.h @@ -42,9 +42,15 @@ #else #define AO_BEEP_MID AO_BEEP_MID_DEFAULT #endif + +#define AO_BEEP_MID_PANIC AO_BEEP_MID_DEFAULT + #define AO_BEEP_LOW AO_BEEP_MID * 150 / 94 /* 2500Hz */ #define AO_BEEP_HIGH AO_BEEP_MID * 75 / 94 /* 5000Hz */ +#define AO_BEEP_LOW_PANIC (AO_BEEP_MID_PANIC * 150 / 94) +#define AO_BEEP_HIGH_PANIC (AO_BEEP_MID_PANIC * 75 / 94) + #define AO_BEEP_OFF 0 /* off */ #define AO_BEEP_g 240 /* 1562.5Hz */ diff --git a/src/kernel/ao_panic.c b/src/kernel/ao_panic.c index 3feecd5a..bd55eb9c 100644 --- a/src/kernel/ao_panic.c +++ b/src/kernel/ao_panic.c @@ -64,9 +64,9 @@ ao_panic(uint8_t reason) ao_panic_delay(20); #if HAS_BEEP for (n = 0; n < 5; n++) { - ao_beep(AO_BEEP_HIGH); + ao_beep(AO_BEEP_HIGH_PANIC); ao_panic_delay(1); - ao_beep(AO_BEEP_LOW); + ao_beep(AO_BEEP_LOW_PANIC); ao_panic_delay(1); } ao_beep(AO_BEEP_OFF); @@ -78,7 +78,7 @@ ao_panic(uint8_t reason) #endif if (reason & 0x40) { ao_led_on(AO_LED_PANIC); - ao_beep(AO_BEEP_HIGH); + ao_beep(AO_BEEP_HIGH_PANIC); ao_panic_delay(40); ao_led_off(AO_LED_PANIC); ao_beep(AO_BEEP_OFF); @@ -86,7 +86,7 @@ ao_panic(uint8_t reason) } for (n = 0; n < (reason & 0x3f); n++) { ao_led_on(AO_LED_PANIC); - ao_beep(AO_BEEP_MID); + ao_beep(AO_BEEP_MID_PANIC); ao_panic_delay(10); ao_led_off(AO_LED_PANIC); ao_beep(AO_BEEP_OFF); -- cgit v1.2.3 From bd0021d431165a6c896a6022691a447e27fd555e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 16 Mar 2018 14:54:04 -0700 Subject: altos/stmf0: Add some common definitions for flash loaders Signed-off-by: Keith Packard --- src/stmf0/Makefile.defs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/stmf0/Makefile.defs b/src/stmf0/Makefile.defs index 3da42874..a0aa558b 100644 --- a/src/stmf0/Makefile.defs +++ b/src/stmf0/Makefile.defs @@ -4,6 +4,10 @@ endif include $(TOPDIR)/stmf0/Makefile-stmf0.defs +LOADER=flash-loader/$(PROGNAME)-altos-flash-$(VERSION).elf +MAKEBIN=$(TOPDIR)/../ao-tools/ao-makebin/ao-makebin +FLASH_ADDR=0x08000000 + LDFLAGS=$(CFLAGS) -L$(TOPDIR)/stmf0 -Wl,-Taltos.ld -n .DEFAULT_GOAL=all -- cgit v1.2.3 From 529c04026dec55d9d0922689e56f1d23b0ff6095 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 17 Mar 2018 11:25:00 -0700 Subject: doc: Add release notes for 1.8.5 Signed-off-by: Keith Packard --- doc/Makefile | 1 + doc/easymini-release-notes.inc | 4 ++++ doc/release-notes-1.8.5.inc | 18 ++++++++++++++++++ doc/release-notes.inc | 3 +++ doc/telegps-release-notes.inc | 5 ++++- 5 files changed, 30 insertions(+), 1 deletion(-) create mode 100644 doc/release-notes-1.8.5.inc diff --git a/doc/Makefile b/doc/Makefile index 7d33149d..efa7f9d3 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -3,6 +3,7 @@ # RELNOTES_INC=\ + release-notes-1.8.5.inc \ release-notes-1.8.4.inc \ release-notes-1.8.3.inc \ release-notes-1.8.2.inc \ diff --git a/doc/easymini-release-notes.inc b/doc/easymini-release-notes.inc index dae928a6..2d289b12 100644 --- a/doc/easymini-release-notes.inc +++ b/doc/easymini-release-notes.inc @@ -1,5 +1,9 @@ [appendix] == Release Notes + :leveloffset: 2 + include::release-notes-1.8.5.raw[] + + <<<< :leveloffset: 2 include::release-notes-1.8.4.raw[] diff --git a/doc/release-notes-1.8.5.inc b/doc/release-notes-1.8.5.inc new file mode 100644 index 00000000..5b940efd --- /dev/null +++ b/doc/release-notes-1.8.5.inc @@ -0,0 +1,18 @@ += Release Notes for Version 1.8.5 +:toc!: +:doctype: article + + Version 1.8.5 includes fixes to the ground software support + for TeleBT v4, along with a few other minor updates. + + == AltOS + + * Fix startup beeps that indicate sensor failures. + + == AltosUI, TeleGPS + + * When updating device firmware, make sure selected firmware + matches target device. + + * Correct Bluetooth device matching when looking for TeleBT + devices. diff --git a/doc/release-notes.inc b/doc/release-notes.inc index 50b27ab5..b7c7f5a7 100644 --- a/doc/release-notes.inc +++ b/doc/release-notes.inc @@ -1,6 +1,9 @@ [appendix] == Release Notes + :leveloffset: 2 + include::release-notes-1.8.5.raw[] + <<<< :leveloffset: 2 include::release-notes-1.8.4.raw[] diff --git a/doc/telegps-release-notes.inc b/doc/telegps-release-notes.inc index 5c5da8f6..f451c2c8 100644 --- a/doc/telegps-release-notes.inc +++ b/doc/telegps-release-notes.inc @@ -2,10 +2,13 @@ == Release Notes :leveloffset: 2 - include::release-notes-1.8.4.raw[] + include::release-notes-1.8.5.raw[] <<<< + :leveloffset: 2 + include::release-notes-1.8.4.raw[] + <<<< :leveloffset: 2 include::release-notes-1.8.3.raw[] -- cgit v1.2.3 From 78e5ae58c2ad5ba7246a649c0bd15ff68b5d0e74 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 17 Mar 2018 11:26:29 -0700 Subject: Bump version to 1.8.5 Signed-off-by: Keith Packard --- configure.ac | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/configure.ac b/configure.ac index 7f27dfad..82e0f3d0 100644 --- a/configure.ac +++ b/configure.ac @@ -18,13 +18,13 @@ dnl dnl Process this file with autoconf to create configure. AC_PREREQ(2.57) -AC_INIT([altos], 1.8.4) -ANDROID_VERSION=16 +AC_INIT([altos], 1.8.5) +ANDROID_VERSION=17 AC_CONFIG_SRCDIR([src/kernel/ao.h]) AM_INIT_AUTOMAKE([foreign dist-bzip2]) AM_MAINTAINER_MODE -RELEASE_DATE=2017-12-21 +RELEASE_DATE=2018-03-17 AC_SUBST(RELEASE_DATE) VERSION_DASH=`echo $VERSION | sed 's/\./-/g'` -- cgit v1.2.3 From 39023ed6e29103a85bfad505506fa0dbf4dc1112 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Sun, 18 Mar 2018 15:42:48 -0600 Subject: doc: update copyright year in doc/altusmetrum-docinfo.xml --- doc/altusmetrum-docinfo.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/altusmetrum-docinfo.xml b/doc/altusmetrum-docinfo.xml index 235111fc..3ea79f8b 100644 --- a/doc/altusmetrum-docinfo.xml +++ b/doc/altusmetrum-docinfo.xml @@ -18,7 +18,7 @@ Towns - 2017 + 2018 Bdale Garbee and Keith Packard -- cgit v1.2.3 From 59e23c27c2a85d7d748223e444b24d19937afe47 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Sun, 18 Mar 2018 15:49:07 -0600 Subject: preparing to release 1.8.5 --- ChangeLog | 458 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ pdclib | 2 +- 2 files changed, 459 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 5d4e10bd..90220e0d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,461 @@ +commit 7b614380f307cb5e27f2a05281bc76c4ace93334 +Merge: 16a9d861 39023ed6 +Author: Bdale Garbee +Date: Sun Mar 18 15:47:31 2018 -0600 + + Merge branch 'master' into branch-1.8 + +commit 39023ed6e29103a85bfad505506fa0dbf4dc1112 +Author: Bdale Garbee +Date: Sun Mar 18 15:42:48 2018 -0600 + + doc: update copyright year in doc/altusmetrum-docinfo.xml + +commit 84146083da782c335ba7f040b238c3f51ba2f484 +Merge: ee79a205 78e5ae58 +Author: Bdale Garbee +Date: Sun Mar 18 15:33:44 2018 -0600 + + Merge branch 'master' of ssh://git.gag.com/scm/git/fw/altos + +commit 78e5ae58c2ad5ba7246a649c0bd15ff68b5d0e74 +Author: Keith Packard +Date: Sat Mar 17 11:26:29 2018 -0700 + + Bump version to 1.8.5 + + Signed-off-by: Keith Packard + +commit 529c04026dec55d9d0922689e56f1d23b0ff6095 +Author: Keith Packard +Date: Sat Mar 17 11:25:00 2018 -0700 + + doc: Add release notes for 1.8.5 + + Signed-off-by: Keith Packard + +commit bd0021d431165a6c896a6022691a447e27fd555e +Author: Keith Packard +Date: Fri Mar 16 14:54:04 2018 -0700 + + altos/stmf0: Add some common definitions for flash loaders + + Signed-off-by: Keith Packard + +commit 4894d965d73231b5c74810d826c7c97fa1bd7803 +Author: Keith Packard +Date: Fri Mar 16 14:53:14 2018 -0700 + + altos: Make panic beeps use fixed frequencies + + This ensures that the beeps will work even before the configuration + has been loaded. + + Signed-off-by: Keith Packard + +commit 1ea6188a9c78ab0642001110cac6c3b35e8ccc88 +Author: Keith Packard +Date: Fri Mar 16 14:52:09 2018 -0700 + + ao-usbload: Flip product names in loader error message + + I was reversing the 'target' vs 'image' names in the error message, + leading to a bit of confusion. + + Signed-off-by: Keith Packard + +commit 788d02a3caf0f14f3c84ff6ae7e2a2fff302e91b +Author: Keith Packard +Date: Fri Mar 16 14:51:22 2018 -0700 + + ao-bringup: Check for Loader USB id before attempting dfu-util + + This lets me restart the turnon process after the boot loader has been + flashed. + + Signed-off-by: Keith Packard + +commit 7068149704e6de67ece670227445e987421cd600 +Author: Keith Packard +Date: Fri Mar 16 14:50:29 2018 -0700 + + chaoskey: Create unified ROM image with both loader and app + + Flash the whole thing all at once to reduce the number of steps during + turnon. + + Signed-off-by: Keith Packard + +commit 46d8197bb80ce3fe4cdc7b36c3be211366093bd5 +Author: Keith Packard +Date: Fri Mar 16 14:49:04 2018 -0700 + + ao-bringup: Don't wait for user when testing EasyMini igniters + + I always have the LEDs ready to go before starting the turnon process. + + Signed-off-by: Keith Packard + +commit ee79a205e118ea8730a02cc327d8fb79cc5f74ff +Merge: 365eee3e 78a90fc7 +Author: Bdale Garbee +Date: Mon Feb 12 16:38:57 2018 -0700 + + Merge branch 'master' of ssh://git.gag.com/scm/git/fw/altos + +commit 78a90fc760b88ab66c5c238289afc38356e29d8a +Author: Keith Packard +Date: Mon Feb 12 15:36:12 2018 -0800 + + Add TeleGPS v2.0 binaries to distribution + + Signed-off-by: Keith Packard + +commit 54e8e033ccf47526e5ff08f93c105ef75334924e +Author: Keith Packard +Date: Sat Jan 13 21:29:08 2018 -0800 + + libaltos: Use case-insensitive compare when matching BT MACs + + We use the BT MAC vendor portion to figure out which port to connect + to as that is simpler and takes less network traffic than actually + doing discovery. However, on Windows, we were generating the address + in lower case and comparing against upper case vendors, which didn't + work out too well. + + Signed-off-by: Keith Packard + +commit b95db5819885da89504d5e11decfda98cfac37aa +Author: Keith Packard +Date: Fri Jan 12 22:27:41 2018 -0800 + + altoslib/altosuilib: Validate rom image is for target device + + This should avoid mis-programming devices with incorrect firmware. + + Signed-off-by: Keith Packard + +commit f26cc1a677f577da533425a15485fcaa24626b23 +Author: Keith Packard +Date: Wed Jan 10 23:11:40 2018 -0800 + + 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 + +commit 4b52fc6eea9a478cb3dd42dcd32c92838df39734 +Author: Keith Packard +Date: Mon Jan 8 13:46:17 2018 -0800 + + 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 + +commit f8a967959b2f5ca3486ab3422f30fe4ad4ba17a8 +Author: Keith Packard +Date: Sun Jan 7 23:06:51 2018 -0800 + + altos/lambdakey-v1.0: Add LED function back in + + We've made things smaller, so there's (barely) space for this now. + + Signed-off-by: Keith Packard + +commit 6ae22601bbf018193ac093fb0f745ebe213bfb64 +Author: Keith Packard +Date: Sun Jan 7 23:06:22 2018 -0800 + + altos/scheme: remove debug code from vector write + + Signed-off-by: Keith Packard + +commit bf37c22c6cdd4a90117bdc809e5c063a079082ad +Author: Keith Packard +Date: Sun Jan 7 23:05:02 2018 -0800 + + altos/scheme: Allow individual lisp keywords to be feature-conditional + + This lets us build a smaller lisp that is just missing some aliases + for existing functionality to save rom space. + + Signed-off-by: Keith Packard + +commit 283553f0f118cef1dbcfbf5e86a43575a610d27f +Author: Keith Packard +Date: Sun Jan 7 23:04:22 2018 -0800 + + altos/scheme: Split tests out from build sources + + Run tests on both tiny and full scheme test programs. + + Signed-off-by: Keith Packard + +commit 48d164e3d4b2ef27fae20fae63b8014803a7b178 +Author: Keith Packard +Date: Sun Jan 7 21:44:39 2018 -0800 + + altos/stmf0: Use double buffering for ChaosKey + + This improves the USB performance of ChaosKey so that it doesn't NAK + during data transfers at all. + + Signed-off-by: Keith Packard + +commit db7f7c6c7f956058250b8057c6c27284f6f22e53 +Author: Keith Packard +Date: Sun Jan 7 21:43:22 2018 -0800 + + ao-chaosread: add --raw and --cooked flags + + Allow reading from the cooked endpoint as well as the raw one. + + Signed-off-by: Keith Packard + +commit 8545ed42bd29152f4937fb6457aba5fbd57e7691 +Author: Keith Packard +Date: Sun Jan 7 17:43:42 2018 -0800 + + altos/stmf0: use double buffering for USB rx data + + This also allows us to stop shadowing USB rx buffers in system ram + + Signed-off-by: Keith Packard + +commit 42072f591690b8258d957ab7a9b2f5d911676b39 +Author: Keith Packard +Date: Sun Jan 7 12:43:13 2018 -0800 + + altos/stmf0: Use double buffering for USB tx data + + This shouldn't have much of an effect, but shows how double buffering + works. + + Signed-off-by: Keith Packard + +commit eead259673c6594d41cfab796c8674c8bf1863cc +Author: Keith Packard +Date: Sun Jan 7 11:51:07 2018 -0800 + + altos/stmf0: Stop shadowing USB tx buffers in system RAM + + Use the 16-bit USB memory directly, avoiding the buffer space and the copy + + Signed-off-by: Keith Packard + +commit ee62272bec67b5784a4ee4e12d8a59677bf9d112 +Author: Keith Packard +Date: Sun Jan 7 11:49:09 2018 -0800 + + altos/stmf0: Remove packet counters from non-debug build + + These counters are only useful for helping debug the USB driver. + + Signed-off-by: Keith Packard + +commit 043c5b56ffc2d8171769f6e988eaad6e457bad89 +Author: Keith Packard +Date: Sun Jan 7 11:47:57 2018 -0800 + + altos/kernel: Use ao_put_string for syntax error message + + Avoid using puts, which can be a large library function. + + Signed-off-by: Keith Packard + +commit b446d9657cad0ff45f6f65c774d82cb9f2f65088 +Author: Keith Packard +Date: Sat Jan 6 18:11:19 2018 -0800 + + 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 + +commit 16061947d4376b41e596d87f97ec53ec29d17644 +Author: Keith Packard +Date: Sat Jan 6 17:29:10 2018 -0800 + + altos/scheme: Add ports. Split scheme code up. + + And lots of other changes, including freeing unreferenced atoms. + + Signed-off-by: Keith Packard + +commit 39df849f0717d92a7d5bdf8aa5904bd4db1b467f +Author: Keith Packard +Date: Sat Jan 6 17:21:45 2018 -0800 + + altos/scheme: add 'install' target to install both test and tiny test + + Signed-off-by: Keith Packard + +commit 0d9a3e0378f84ffc8447747150066eae33cd3229 +Author: Keith Packard +Date: Thu Jan 4 02:28:13 2018 -0800 + + altos/scheme: Add vector and string funcs. Test everybody. + + Add a bunch of string and vector functions from r7rs. I think most + everything is here now. + + Signed-off-by: Keith Packard + +commit d34f01110d8770ac99556901143a54c3d492cde0 +Author: Keith Packard +Date: Thu Jan 4 02:27:11 2018 -0800 + + altos/scheme: Accept more escaped character constants + + Allow all those specified in r7rs + + Signed-off-by: Keith Packard + +commit 243baa14a62e3efe5ae792c73db75f9c2cb86abb +Author: Keith Packard +Date: Thu Jan 4 02:26:21 2018 -0800 + + altos/scheme: Allow make-vector value param to be optional + + It can default to #f + + Signed-off-by: Keith Packard + +commit a6e01e7aafb1d1fdb15d633ec23d8fe51afd15df +Author: Keith Packard +Date: Thu Jan 4 02:25:45 2018 -0800 + + altos/scheme: Add builtin list-tail + + This is used enough to warrant a builtin, rather than lisp implementation + + Signed-off-by: Keith Packard + +commit e030fba5ab556c88af918d08e1b62e63d6605638 +Author: Keith Packard +Date: Thu Jan 4 02:24:15 2018 -0800 + + altos/scheme: Fix macro-detection debugging + + Just update to use ao_scheme_printf + + Signed-off-by: Keith Packard + +commit 036a5311cbc86dbc5a8f859778d52d588915e4e2 +Author: Keith Packard +Date: Thu Jan 4 02:23:40 2018 -0800 + + altos/scheme: add make-string builtin + + Allocate a blank string. + + Signed-off-by: Keith Packard + +commit 0a0327330dcbf5531cd0f8ca8b912fa51ef44f13 +Author: Keith Packard +Date: Thu Jan 4 02:22:02 2018 -0800 + + altos/scheme: Make constant built pool as large as possible + + This allows building with as much constant data as will fit. + + Signed-off-by: Keith Packard + +commit 637795fcf8ca52af431acec183cc961dae121e57 +Author: Keith Packard +Date: Wed Jan 3 14:58:57 2018 -0800 + + altos/scheme: Make for-each tail recursive + + Provides a native version of for-each that is tail recursive, rather + than having it just use map and discard the return value. + + Signed-off-by: Keith Packard + +commit 7bfc1eda398e8767e352cd6396ac61c7ea021079 +Author: Keith Packard +Date: Wed Jan 3 14:57:39 2018 -0800 + + altos/scheme: Add start/end args to vector->list + + This is an r7rs extension which allows you to extract a subset of the + vector. + + Signed-off-by: Keith Packard + +commit 2bcc178f3cbfd346b134bb3fe700b0512f340fea +Author: Keith Packard +Date: Wed Jan 3 14:56:15 2018 -0800 + + 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 + +commit b7c34a2e5ecff19d61d337b8c84976cc46005ec4 +Author: Keith Packard +Date: Wed Jan 3 14:55:24 2018 -0800 + + altos/scheme: support %x format for scheme printf + + read debugging uses this format. + + Signed-off-by: Keith Packard + +commit fccb5105b79d5b9e2ed052ce5459028015c01741 +Author: Keith Packard +Date: Wed Jan 3 14:53:48 2018 -0800 + + altos/scheme: Add support for hex, octal and binary constants + + Signed-off-by: Keith Packard + +commit 365eee3ebfe73204033089b363687228f97e5d98 +Author: Bdale Garbee +Date: Wed Jan 3 14:43:29 2018 -0600 + + need to push telegps-v2.0 loader .bin file to corporate repo, too + +commit fc63968f90e3fab12e63d973a4ee7f16d80d765f +Author: Keith Packard +Date: Sun Dec 24 14:29:09 2017 -0800 + + altos/scheme: Pull out per-frame vals while printing list of frames + + Was using the same vals for all frames, which just doesn't work well. + + Signed-off-by: Keith Packard + +commit 7b5892f75a75363a656ede8befb419245aa218b5 +Author: Keith Packard +Date: Sun Dec 24 14:28:29 2017 -0800 + + altos/scheme: Add separate floor-quotient builtin + + Does what 'quotient' did before, now quotient rounds towards zero + while floor-quotient rounds down. + + Signed-off-by: Keith Packard + +commit d95486be96fe989f6984b3452c5c5d92897c5606 +Author: Bdale Garbee +Date: Thu Dec 21 20:40:28 2017 -0700 + + update Releasing with wisdom from 1.8.4 release process + +commit 16a9d8617b2d2092d166a85ada4349601afb0dce +Author: Bdale Garbee +Date: Thu Dec 21 19:06:22 2017 -0700 + + releasing 1.8.4 + commit dbb78c8222c45f4430601deee0194b0c9dc2e79a Merge: fe38c225 87aab995 Author: Bdale Garbee diff --git a/pdclib b/pdclib index 3e68419a..20f71c3a 160000 --- a/pdclib +++ b/pdclib @@ -1 +1 @@ -Subproject commit 3e68419ad3ca3237ca16de4cf2a967f04129fe33 +Subproject commit 20f71c3a97eb4c7ecfa9754a0ca42855db935999 -- cgit v1.2.3