From d8c9024f3829dc3f241b16869f165f3ee01764f3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 15:25:51 -0800 Subject: [PATCH] altos/scheme: Support scheme subsetting via feature settings This provides for the creation of smaller versions of the interpreter, leaving out options like floating point numbers and vectors. Signed-off-by: Keith Packard --- src/scheme/Makefile | 15 +- src/scheme/ao_scheme.h | 86 +++- src/scheme/ao_scheme_builtin.c | 47 ++- src/scheme/ao_scheme_builtin.txt | 165 ++++---- src/scheme/ao_scheme_const.scheme | 6 - src/scheme/ao_scheme_float.c | 3 + src/scheme/ao_scheme_int.c | 3 + src/scheme/ao_scheme_make_builtin | 116 +++++- src/scheme/ao_scheme_make_const.c | 145 ++++++- src/scheme/ao_scheme_mem.c | 6 + src/scheme/ao_scheme_poly.c | 33 +- src/scheme/ao_scheme_read.c | 68 ++- src/scheme/ao_scheme_read.h | 15 + src/scheme/test/.gitignore | 2 +- src/scheme/test/Makefile | 14 +- src/scheme/test/ao_scheme_os.h | 1 - src/scheme/test/ao_scheme_test.c | 2 + src/scheme/tiny-test/.gitignore | 1 + src/scheme/tiny-test/Makefile | 28 ++ src/scheme/tiny-test/ao_scheme_os.h | 72 ++++ src/scheme/tiny-test/ao_scheme_test.c | 141 +++++++ .../tiny-test/ao_scheme_tiny_const.scheme | 389 ++++++++++++++++++ 22 files changed, 1178 insertions(+), 180 deletions(-) create mode 100644 src/scheme/tiny-test/.gitignore create mode 100644 src/scheme/tiny-test/Makefile create mode 100644 src/scheme/tiny-test/ao_scheme_os.h create mode 100644 src/scheme/tiny-test/ao_scheme_test.c create mode 100644 src/scheme/tiny-test/ao_scheme_tiny_const.scheme diff --git a/src/scheme/Makefile b/src/scheme/Makefile index dc36dde1..e600d5f7 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -1,12 +1,10 @@ -all: ao_scheme_builtin.h ao_scheme_const.h test/ao_scheme_test +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 - rm -f ao_scheme_const.h ao_scheme_builtin.h - -ao_scheme_const.h: ao_scheme_const.scheme make-const/ao_scheme_make_const - make-const/ao_scheme_make_const -o $@ ao_scheme_const.scheme + +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 > $@ @@ -14,7 +12,10 @@ ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt make-const/ao_scheme_make_const: FRC ao_scheme_builtin.h +cd make-const && make ao_scheme_make_const -test/ao_scheme_test: FRC ao_scheme_const.h ao_scheme_builtin.h - +cd test && make ao_scheme_test +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 FRC: diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 2fa1ed60..db4417e5 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -23,6 +23,9 @@ #include #include +#define AO_SCHEME_BUILTIN_FEATURES +#include "ao_scheme_builtin.h" +#undef AO_SCHEME_BUILTIN_FEATURES #include #ifndef __BYTE_ORDER #include @@ -102,10 +105,25 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #define AO_SCHEME_LAMBDA 8 #define AO_SCHEME_STACK 9 #define AO_SCHEME_BOOL 10 +#ifdef AO_SCHEME_FEATURE_BIGINT #define AO_SCHEME_BIGINT 11 -#define AO_SCHEME_FLOAT 12 +#define _AO_SCHEME_BIGINT AO_SCHEME_BIGINT +#else +#define _AO_SCHEME_BIGINT AO_SCHEME_BOOL +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT +#define AO_SCHEME_FLOAT (_AO_SCHEME_BIGINT + 1) +#define _AO_SCHEME_FLOAT AO_SCHEME_FLOAT +#else +#define _AO_SCHEME_FLOAT _AO_SCHEME_BIGINT +#endif +#ifdef AO_SCHEME_FEATURE_VECTOR #define AO_SCHEME_VECTOR 13 -#define AO_SCHEME_NUM_TYPE 14 +#define _AO_SCHEME_VECTOR AO_SCHEME_VECTOR +#else +#define _AO_SCHEME_VECTOR _AO_SCHEME_FLOAT +#endif +#define AO_SCHEME_NUM_TYPE (_AO_SCHEME_VECTOR+1) /* Leave two bits for types to use as they please */ #define AO_SCHEME_OTHER_TYPE_MASK 0x3f @@ -182,25 +200,38 @@ struct ao_scheme_bool { uint16_t pad; }; -struct ao_scheme_bigint { - uint32_t value; -}; +#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 + +#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 (-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) #if __BYTE_ORDER == __LITTLE_ENDIAN + static inline uint32_t ao_scheme_int_bigint(int32_t i) { return AO_SCHEME_BIGINT | (i << 8); @@ -218,12 +249,9 @@ static inlint int32_t ao_scheme_bigint_int(uint32_t bi) { return (int32_t) (bi << 8) >> 8; } -#endif -#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) -#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) -#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) -#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) +#endif /* __BYTE_ORDER */ +#endif /* AO_SCHEME_FEATURE_BIGINT */ #define AO_SCHEME_NOT_INTEGER 0x7fffffff @@ -433,6 +461,7 @@ 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) { @@ -444,6 +473,7 @@ ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) { return ao_scheme_poly(bi, AO_SCHEME_OTHER); } +#endif /* AO_SCHEME_FEATURE_BIGINT */ static inline char * ao_scheme_poly_string(ao_poly poly) @@ -493,6 +523,7 @@ 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) { @@ -507,7 +538,9 @@ ao_scheme_poly_float(ao_poly 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) { @@ -519,6 +552,7 @@ ao_scheme_poly_vector(ao_poly poly) { return ao_scheme_ref(poly); } +#endif /* memory functions */ @@ -687,6 +721,7 @@ ao_scheme_atom_def(ao_poly atom, ao_poly val); void ao_scheme_int_write(ao_poly i); +#ifdef AO_SCHEME_FEATURE_BIGINT int32_t ao_scheme_poly_integer(ao_poly p); @@ -704,6 +739,19 @@ ao_scheme_bigint_write(ao_poly i); extern const struct ao_scheme_type ao_scheme_bigint_type; +#else + +#define ao_scheme_poly_integer ao_scheme_poly_int +#define ao_scheme_integer_poly ao_scheme_int_poly + +static inline int +ao_scheme_integer_typep(uint8_t t) +{ + return (t == AO_SCHEME_INT); +} + +#endif /* AO_SCHEME_FEATURE_BIGINT */ + /* vector */ void @@ -730,11 +778,14 @@ ao_scheme_vector_to_list(struct ao_scheme_vector *vector); extern const struct ao_scheme_type ao_scheme_vector_type; /* prim */ -void -ao_scheme_poly_write(ao_poly p); +void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p); +void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p); -void -ao_scheme_poly_display(ao_poly p); +static inline void +ao_scheme_poly_write(ao_poly p) { (*ao_scheme_poly_write_func(p))(p); } + +static inline void +ao_scheme_poly_display(ao_poly p) { (*ao_scheme_poly_display_func(p))(p); } int ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); @@ -758,6 +809,7 @@ 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 @@ -765,7 +817,9 @@ ao_scheme_float_write(ao_poly p); ao_poly ao_scheme_float_get(float value); +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT static inline uint8_t ao_scheme_number_typep(uint8_t t) { @@ -774,6 +828,10 @@ ao_scheme_number_typep(uint8_t t) float ao_scheme_poly_number(ao_poly p); +#else +#define ao_scheme_number_typep ao_scheme_integer_typep +#define ao_scheme_poly_number ao_scheme_poly_integer +#endif /* builtin */ void diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 1754e677..c0f636fa 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -325,15 +325,22 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id 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_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) - ; - else if (ao_scheme_number_typep(ct)) { - float v = ao_scheme_poly_number(ret); - ret = ao_scheme_float_get(1/v); + if (ao_scheme_integer_typep(ct) && 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: @@ -344,30 +351,42 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) } 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) @@ -395,6 +414,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) ao_scheme_cons_stash(0, cons); ret = ao_scheme_integer_poly(r); cons = ao_scheme_cons_fetch(0); +#ifdef AO_SCHEME_FEATURE_FLOAT } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { float r, c; inexact: @@ -423,6 +443,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) ao_scheme_cons_stash(0, cons); ret = ao_scheme_float_get(r); cons = ao_scheme_cons_fetch(0); +#endif } else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { ao_scheme_cons_stash(0, cons); @@ -839,6 +860,7 @@ ao_scheme_do_pairp(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_integerp(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))) { @@ -848,21 +870,32 @@ ao_scheme_do_integerp(struct ao_scheme_cons *cons) default: return _ao_scheme_bool_false; } +#else + return ao_scheme_do_typep(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) 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: +#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 } ao_poly @@ -1017,6 +1050,8 @@ ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); } +#ifdef AO_SCHEME_FEATURE_VECTOR + ao_poly ao_scheme_do_vector(struct ao_scheme_cons *cons) { @@ -1092,5 +1127,7 @@ ao_scheme_do_vectorp(struct ao_scheme_cons *cons) return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons); } +#endif /* AO_SCHEME_FEATURE_VECTOR */ + #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 17f5ea0c..14f279a4 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -1,81 +1,84 @@ -f_lambda eval -f_lambda read -nlambda lambda -nlambda nlambda -nlambda macro -f_lambda car -f_lambda cdr -f_lambda cons -f_lambda last -f_lambda length -f_lambda list_copy list-copy -nlambda quote -atom quasiquote -atom unquote -atom unquote_splicing unquote-splicing -f_lambda set -macro setq set! -f_lambda def -nlambda cond -nlambda begin -nlambda while -f_lambda write -f_lambda display -f_lambda plus + string-append -f_lambda minus - -f_lambda times * -f_lambda divide / -f_lambda modulo modulo % -f_lambda remainder -f_lambda quotient -f_lambda equal = eq? eqv? -f_lambda less < string string>? -f_lambda less_equal <= string<=? -f_lambda greater_equal >= string>=? -f_lambda flush_output flush-output -f_lambda delay -f_lambda led -f_lambda save -f_lambda restore -f_lambda call_cc call-with-current-continuation call/cc -f_lambda collect -f_lambda nullp null? -f_lambda not -f_lambda listp list? -f_lambda pairp pair? -f_lambda integerp integer? exact? exact-integer? -f_lambda numberp number? real? -f_lambda booleanp boolean? -f_lambda set_car set-car! -f_lambda set_cdr set-cdr! -f_lambda symbolp symbol? -f_lambda list_to_string list->string -f_lambda string_to_list string->list -f_lambda symbol_to_string symbol->string -f_lambda string_to_symbol string->symbol -f_lambda stringp string? -f_lambda string_ref string-ref -f_lambda string_set string-set! -f_lambda string_copy string-copy -f_lambda string_length string-length -f_lambda procedurep procedure? -lambda apply -f_lambda read_char read-char -f_lambda write_char write-char -f_lambda exit -f_lambda current_jiffy current-jiffy -f_lambda current_second current-second -f_lambda jiffies_per_second jiffies-per-second -f_lambda finitep finite? -f_lambda infinitep infinite? -f_lambda inexactp inexact? -f_lambda sqrt -f_lambda vector_ref vector-ref -f_lambda vector_set vector-set! -f_lambda vector -f_lambda make_vector make-vector -f_lambda list_to_vector list->vector -f_lambda vector_to_list vector->list -f_lambda vector_length vector-length -f_lambda vectorp vector? +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 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 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 +all f_lambda save +all 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? +FLOAT f_lambda integerp integer? exact? exact-integer? +all f_lambda numberp number? real? +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_copy string-copy +all f_lambda string_length string-length +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 current_second current-second +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? diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme index ab6a309a..060fd955 100644 --- a/src/scheme/ao_scheme_const.scheme +++ b/src/scheme/ao_scheme_const.scheme @@ -805,9 +805,3 @@ ) (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) - -;(define number->string (lambda (arg . opt) -; (let ((base (if (null? opt) 10 (car opt))) - ; -; - diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index 99249030..c026c6fb 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -15,6 +15,8 @@ #include "ao_scheme.h" #include +#ifdef AO_SCHEME_FEATURE_FLOAT + static void float_mark(void *addr) { (void) addr; @@ -150,3 +152,4 @@ ao_scheme_do_sqrt(struct ao_scheme_cons *cons) 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))); } +#endif diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c index 350a5d35..43d6b8e1 100644 --- a/src/scheme/ao_scheme_int.c +++ b/src/scheme/ao_scheme_int.c @@ -21,6 +21,8 @@ ao_scheme_int_write(ao_poly p) printf("%d", i); } +#ifdef AO_SCHEME_FEATURE_BIGINT + int32_t ao_scheme_poly_integer(ao_poly p) { @@ -77,3 +79,4 @@ ao_scheme_bigint_write(ao_poly p) printf("%d", ao_scheme_bigint_int(bi->value)); } +#endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin index 8e9c2c0b..78f97789 100644 --- a/src/scheme/ao_scheme_make_builtin +++ b/src/scheme/ao_scheme_make_builtin @@ -1,6 +1,7 @@ #!/usr/bin/nickle typedef struct { + string feature; string type; string c_name; string[*] lisp_names; @@ -12,6 +13,7 @@ string[string] type_map = { "macro" => "MACRO", "f_lambda" => "F_LAMBDA", "atom" => "atom", + "feature" => "feature", }; string[*] @@ -19,9 +21,9 @@ make_lisp(string[*] tokens) { string[...] lisp = {}; - if (dim(tokens) < 3) + if (dim(tokens) < 4) return (string[1]) { tokens[dim(tokens) - 1] }; - return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; + return (string[dim(tokens)-3]) { [i] = tokens[i+3] }; } builtin_t @@ -30,8 +32,9 @@ read_builtin(file f) { string[*] tokens = String::wordsplit(line, " \t"); return (builtin_t) { - .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", - .c_name = dim(tokens) > 1 ? tokens[1] : "#", + .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), }; } @@ -49,16 +52,37 @@ read_builtins(file f) { 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_atom(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"); @@ -71,9 +95,12 @@ dump_casename(builtin_t[*] builtins) { printf("static char *ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {\n"); printf("\tswitch(b) {\n"); for (int i = 0; i < dim(builtins); i++) - if (!is_atom(builtins[i])) + 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]); + dump_endif(builtins[i]); + } printf("\tdefault: return \"???\";\n"); printf("\t}\n"); printf("}\n"); @@ -97,11 +124,13 @@ dump_arrayname(builtin_t[*] builtins) { printf("#undef AO_SCHEME_BUILTIN_ARRAYNAME\n"); printf("static const ao_poly builtin_names[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { + 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]); printf(",\n"); + dump_endif(builtins[i]); } } printf("};\n"); @@ -114,10 +143,13 @@ dump_funcs(builtin_t[*] builtins) { printf("#undef AO_SCHEME_BUILTIN_FUNCS\n"); printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) + 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"); @@ -128,10 +160,12 @@ dump_decls(builtin_t[*] builtins) { printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); printf("#undef AO_SCHEME_BUILTIN_DECLS\n"); for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { + 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"); @@ -143,13 +177,16 @@ dump_consts(builtin_t[*] builtins) { printf("#undef AO_SCHEME_BUILTIN_CONSTS\n"); printf("struct builtin_func funcs[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { + if (is_func(builtins[i])) { + dump_ifdef(builtins[i]); for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", + printf ("\t{ .feature = \"%s\", .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", + builtins[i].feature, builtins[i].lisp_names[j], builtins[i].type, builtins[i].c_name); } + dump_endif(builtins[i]); } } printf("};\n"); @@ -161,15 +198,60 @@ dump_atoms(builtin_t[*] builtins) { printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); printf("#undef AO_SCHEME_BUILTIN_ATOMS\n"); for (int i = 0; i < dim(builtins); i++) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf("#define _ao_scheme_atom_"); - cify_lisp(builtins[i].lisp_names[j]); - printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); + 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]); + } } } 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++) { + printf("\t{ .feature = \"%s\", .name = \"%s\" },\n", + builtins[i].feature, + builtins[i].lisp_names[j]); + } + } + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ATOM_NAMES */\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("#define AO_SCHEME_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]); @@ -177,6 +259,8 @@ void main() { } 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); @@ -184,6 +268,8 @@ void main() { dump_decls(builtins); dump_consts(builtins); dump_atoms(builtins); + dump_atom_names(builtins); + dump_features(builtins); } } diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c index cf42ec52..6bd552f5 100644 --- a/src/scheme/ao_scheme_make_const.c +++ b/src/scheme/ao_scheme_make_const.c @@ -17,6 +17,7 @@ #include #include #include +#include static struct ao_scheme_builtin * ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { @@ -29,15 +30,25 @@ ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { } struct builtin_func { + char *feature; char *name; int args; enum ao_scheme_builtin_id func; }; +struct builtin_atom { + char *feature; + 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_FUNC (sizeof funcs / sizeof funcs[0]) + +#define N_ATOM (sizeof atoms / sizeof atoms[0]) struct ao_scheme_frame *globals; @@ -228,6 +239,36 @@ ao_has_macro(ao_poly 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; +} + int ao_scheme_read_eval_abort(void) { @@ -248,6 +289,47 @@ ao_scheme_read_eval_abort(void) static FILE *in; static FILE *out; +struct feature { + struct feature *next; + char name[]; +}; + +static struct feature *enable; +static struct feature *disable; + +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; +} + +bool +ao_scheme_has_feature(struct feature *list, char *name) +{ + while (list) { + if (!strcmp(list->name, name)) + return true; + list = list->next; + } + return false; +} + +void +ao_scheme_add_features(struct feature **list, char *names) +{ + char *saveptr = NULL; + char *name; + + while ((name = strtok_r(names, ",", &saveptr)) != NULL) { + names = NULL; + if (!ao_scheme_has_feature(*list, name)) + ao_scheme_add_feature(list, name); + } +} + int ao_scheme_getc(void) { @@ -256,19 +338,21 @@ ao_scheme_getc(void) 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=] [input]\n", program); + fprintf(stderr, "usage: %s [--out=] [--disable={feature,...}] [--enable={feature,...} [input]\n", program); exit(1); } int main(int argc, char **argv) { - int f, o; + int f, o, an; ao_poly val; struct ao_scheme_atom *a; struct ao_scheme_builtin *b; @@ -276,15 +360,23 @@ main(int argc, char **argv) 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:", options, NULL)) != -1) { + 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; @@ -298,21 +390,34 @@ main(int argc, char **argv) ao_scheme_bool_get(1); prev_func = _builtin_last; + target_func = 0; for (f = 0; f < (int) N_FUNC; f++) { - if (funcs[f].func != prev_func) - b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); - a = ao_scheme_atom_intern(funcs[f].name); - ao_scheme_atom_def(ao_scheme_atom_poly(a), - ao_scheme_builtin_poly(b)); + 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(funcs[f].name); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_builtin_poly(b)); + } } - /* end of file value */ - a = ao_scheme_atom_intern("eof"); - ao_scheme_atom_def(ao_scheme_atom_poly(a), - ao_scheme_atom_poly(a)); - - /* 'else' */ - a = ao_scheme_atom_intern("else"); + /* 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); + } if (argv[optind]){ in = fopen(argv[optind], "r"); @@ -331,6 +436,7 @@ main(int argc, char **argv) for (f = 0; f < ao_scheme_frame_global->num; f++) { struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); + val = ao_has_macro(vals->vals[f].val); if (val != AO_SCHEME_NIL) { printf("error: function %s contains unresolved macro: ", @@ -339,6 +445,13 @@ main(int argc, char **argv) printf("\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) { diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 45d4de98..292d0f9d 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -465,9 +465,15 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, [AO_SCHEME_STACK] = &ao_scheme_stack_type, [AO_SCHEME_BOOL] = &ao_scheme_bool_type, +#ifdef AO_SCHEME_FEATURE_BIGINT [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, +#endif +#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 }; static int diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 553585db..0bb427b9 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -60,18 +60,33 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_bool_write, .display = ao_scheme_bool_write, }, +#ifdef AO_SCHEME_FEATURE_BIGINT [AO_SCHEME_BIGINT] = { .write = ao_scheme_bigint_write, .display = ao_scheme_bigint_write, }, +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = { .write = ao_scheme_float_write, .display = ao_scheme_float_write, }, +#endif +#ifdef AO_SCHEME_FEATURE_VECTOR [AO_SCHEME_VECTOR] = { .write = ao_scheme_vector_write, .display = ao_scheme_vector_display }, +#endif +}; + +static void ao_scheme_invalid_write(ao_poly p) { + printf("??? 0x%04x ???", p); +} + +static const struct ao_scheme_funcs ao_scheme_invalid_funcs = { + .write = ao_scheme_invalid_write, + .display = ao_scheme_invalid_write, }; static const struct ao_scheme_funcs * @@ -81,25 +96,17 @@ funcs(ao_poly p) if (type < AO_SCHEME_NUM_TYPE) return &ao_scheme_funcs[type]; - return NULL; + return &ao_scheme_invalid_funcs; } -void -ao_scheme_poly_write(ao_poly p) +void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p) { - const struct ao_scheme_funcs *f = funcs(p); - - if (f && f->write) - f->write(p); + return funcs(p)->write; } -void -ao_scheme_poly_display(ao_poly p) +void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p) { - const struct ao_scheme_funcs *f = funcs(p); - - if (f && f->display) - f->display(p); + return funcs(p)->display; } void * diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 9ed54b9f..dce480ab 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -62,7 +62,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SPECIAL, /* ) */ PRINTABLE, /* * */ PRINTABLE|SIGN, /* + */ - PRINTABLE|SPECIAL, /* , */ + PRINTABLE|SPECIAL_QUASI, /* , */ PRINTABLE|SIGN, /* - */ PRINTABLE|DOTC|FLOATC, /* . */ PRINTABLE, /* / */ @@ -114,7 +114,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* ] */ PRINTABLE, /* ^ */ PRINTABLE, /* _ */ - PRINTABLE|SPECIAL, /* ` */ + PRINTABLE|SPECIAL_QUASI, /* ` */ PRINTABLE, /* a */ PRINTABLE, /* b */ PRINTABLE, /* c */ @@ -244,12 +244,13 @@ lex_quoted(void) } } +#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 float token_float; static inline void add_token(int c) { if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) @@ -265,6 +266,9 @@ static inline 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; @@ -278,6 +282,7 @@ static const struct namedfloat namedfloats[] = { }; #define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) +#endif static int _lex(void) @@ -315,6 +320,7 @@ _lex(void) return QUOTE; case '.': return DOT; +#ifdef AO_SCHEME_FEATURE_QUASI case '`': return QUASIQUOTE; case ',': @@ -327,6 +333,7 @@ _lex(void) lex_unget(c); return UNQUOTE; } +#endif } } if (lex_class & POUND) { @@ -340,8 +347,10 @@ _lex(void) add_token(c); end_token(); return BOOL; +#ifdef AO_SCHEME_FEATURE_VECTOR case '(': return OPEN_VECTOR; +#endif case '\\': for (;;) { int alphabetic; @@ -393,23 +402,23 @@ _lex(void) } } if (lex_class & PRINTABLE) { - int isfloat; - int hasdigit; - int isneg; - int isint; - int epos; - - isfloat = 1; - isint = 1; - hasdigit = 0; +#ifdef AO_SCHEME_FEATURE_FLOAT + int isfloat = 1; + int epos = 0; +#endif + int hasdigit = 0; + int isneg = 0; + int isint = 1; + token_int = 0; - isneg = 0; - epos = 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 && @@ -418,8 +427,10 @@ _lex(void) 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') { @@ -428,6 +439,7 @@ _lex(void) else epos = token_len + 1; } +#endif if (lex_class & DIGIT) { hasdigit = 1; if (isint) @@ -436,8 +448,14 @@ _lex(void) } add_token (c); c = lexc (); - if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + if ((lex_class & (NOTNAME)) +#ifdef AO_SCHEME_FEATURE_FLOAT + && (c != '.' || !isfloat) +#endif + ) { +#ifdef AO_SCHEME_FEATURE_FLOAT unsigned int u; +#endif // if (lex_class & ENDOFFILE) // clearerr (f); lex_unget(c); @@ -447,6 +465,7 @@ _lex(void) token_int = -token_int; return NUM; } +#ifdef AO_SCHEME_FEATURE_FLOAT if (isfloat && hasdigit) { token_float = strtof(token_string, NULL); return FLOAT; @@ -456,6 +475,7 @@ _lex(void) token_float = namedfloats[u].value; return FLOAT; } +#endif return NAME; } } @@ -525,6 +545,12 @@ pop_read_stack(void) 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(void) { @@ -538,9 +564,11 @@ ao_scheme_read(void) ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; for (;;) { parse_token = lex(); - while (parse_token == OPEN || parse_token == OPEN_VECTOR) { + 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++; @@ -565,9 +593,11 @@ ao_scheme_read(void) 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 BOOL: if (token_string[0] == 't') v = _ao_scheme_bool_true; @@ -582,9 +612,11 @@ ao_scheme_read(void) 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++; @@ -593,6 +625,7 @@ ao_scheme_read(void) case QUOTE: v = _ao_scheme_atom_quote; break; +#ifdef AO_SCHEME_FEATURE_QUASI case QUASIQUOTE: v = _ao_scheme_atom_quasiquote; break; @@ -602,6 +635,7 @@ ao_scheme_read(void) case UNQUOTE_SPLICING: v = _ao_scheme_atom_unquote2dsplicing; break; +#endif } break; case CLOSE: @@ -612,8 +646,10 @@ ao_scheme_read(void) 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))); +#endif break; case DOT: if (!ao_scheme_read_list) { diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index e10a7d05..1aa11a3a 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -24,15 +24,21 @@ # 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 BOOL 12 +#ifdef AO_SCHEME_FEATURE_VECTOR # define OPEN_VECTOR 13 +#endif /* * character classes @@ -40,11 +46,20 @@ # define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ # define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ +#ifdef AO_SCHEME_FEATURE_QUASI +# define SPECIAL_QUASI SPECIAL +#else +# define SPECIAL_QUASI 0 +#endif # define DOTC 0x0004 /* . */ # 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 - ' ' */ diff --git a/src/scheme/test/.gitignore b/src/scheme/test/.gitignore index 3cdae594..3622bc1d 100644 --- a/src/scheme/test/.gitignore +++ b/src/scheme/test/.gitignore @@ -1 +1 @@ -ao_scheme_test +ao-scheme diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index c48add1f..d1bc4239 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -5,18 +5,22 @@ vpath %.c .. vpath %.h .. SRCS=$(SCHEME_SRCS) ao_scheme_test.c +HDRS=$(SCHEME_HDRS) ao_scheme_const.h OBJS=$(SRCS:.c=.o) CFLAGS=-O2 -g -Wall -Wextra -I. -I.. -ao_scheme_test: $(OBJS) +ao-scheme: $(OBJS) cc $(CFLAGS) -o $@ $(OBJS) -lm -$(OBJS): $(SCHEME_HDRS) +$(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 clean:: - rm -f $(OBJS) ao_scheme_test + rm -f $(OBJS) ao-scheme ao_scheme_const.h -install: ao_scheme_test - cp ao_scheme_test $$HOME/bin/ao-scheme +install: ao-scheme + cp $^ $$HOME/bin diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h index ea363fb3..958f68be 100644 --- a/src/scheme/test/ao_scheme_os.h +++ b/src/scheme/test/ao_scheme_os.h @@ -24,7 +24,6 @@ #define AO_SCHEME_POOL_TOTAL 32768 #define AO_SCHEME_SAVE 1 -#define DBG_MEM_STATS 1 extern int ao_scheme_getc(void); diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 0c77d8d5..45068369 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -107,6 +107,7 @@ main (int argc, char **argv) } ao_scheme_read_eval_print(); +#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]); @@ -136,4 +137,5 @@ main (int argc, char **argv) (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/.gitignore b/src/scheme/tiny-test/.gitignore new file mode 100644 index 00000000..7c4c3956 --- /dev/null +++ b/src/scheme/tiny-test/.gitignore @@ -0,0 +1 @@ +ao-scheme-tiny diff --git a/src/scheme/tiny-test/Makefile b/src/scheme/tiny-test/Makefile new file mode 100644 index 00000000..5082df44 --- /dev/null +++ b/src/scheme/tiny-test/Makefile @@ -0,0 +1,28 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +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.. + +ao-scheme-tiny: $(OBJS) + cc $(CFLAGS) -o $@ $(OBJS) -lm + +$(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 + +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 new file mode 100644 index 00000000..7cfe3981 --- /dev/null +++ b/src/scheme/tiny-test/ao_scheme_os.h @@ -0,0 +1,72 @@ +/* + * 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 + +#undef AO_SCHEME_FEATURE_FLOAT +#undef AO_SCHEME_FEATURE_VECTOR +#undef AO_SCHEME_FEATURE_QUASI +#undef AO_SCHEME_FEATURE_BIGINT + +#define AO_SCHEME_POOL_TOTAL 4096 +#define AO_SCHEME_SAVE 1 + +extern int ao_scheme_getc(void); + +static inline void +ao_scheme_os_flush() { + fflush(stdout); +} + +static inline void +ao_scheme_abort(void) +{ + abort(); +} + +static inline void +ao_scheme_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +#define AO_SCHEME_JIFFIES_PER_SECOND 100 + +static inline void +ao_scheme_os_delay(int jiffies) +{ + struct timespec ts = { + .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) + }; + nanosleep(&ts, NULL); +} + +static inline int +ao_scheme_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); +} + +#endif diff --git a/src/scheme/tiny-test/ao_scheme_test.c b/src/scheme/tiny-test/ao_scheme_test.c new file mode 100644 index 00000000..45068369 --- /dev/null +++ b/src/scheme/tiny-test/ao_scheme_test.c @@ -0,0 +1,141 @@ +/* + * 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 FILE *ao_scheme_file; +static int newline = 1; + +static char save_file[] = "scheme.image"; + +int +ao_scheme_os_save(void) +{ + FILE *save = fopen(save_file, "w"); + + if (!save) { + perror(save_file); + return 0; + } + fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); + fclose(save); + return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + fseek(restore, offset, SEEK_SET); + ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); + fclose(restore); + if (ret != 1) + return 0; + return 1; +} + +int +ao_scheme_os_restore(void) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); + fclose(restore); + if (ret != AO_SCHEME_POOL_TOTAL) + return 0; + return 1; +} + +int +ao_scheme_getc(void) +{ + int c; + + if (ao_scheme_file) + return getc(ao_scheme_file); + + if (newline) { + if (ao_scheme_read_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) { + perror(*argv); + exit(1); + } + ao_scheme_read_eval_print(); + fclose(ao_scheme_file); + ao_scheme_file = NULL; + } + ao_scheme_read_eval_print(); + +#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_const.scheme b/src/scheme/tiny-test/ao_scheme_tiny_const.scheme new file mode 100644 index 00000000..d0c0e578 --- /dev/null +++ b/src/scheme/tiny-test/ao_scheme_tiny_const.scheme @@ -0,0 +1,389 @@ +; +; 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) -- 2.30.2