From d8c9024f3829dc3f241b16869f165f3ee01764f3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 15:25:51 -0800 Subject: 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/ao_scheme_read.c | 68 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 52 insertions(+), 16 deletions(-) (limited to 'src/scheme/ao_scheme_read.c') diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 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) { -- cgit v1.2.3 From 32f6877288ea6b7eb1cae9a42fbe8e2c5dbb2f08 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 14 Dec 2017 23:04:39 -0800 Subject: altos/scheme: swap BIGINT and STRING types This lets BIGINT be a primitive type, allowing it to use all 32 bits for storage. This does make strings another byte longer, and also slightly harder to deal with. It's a trade off. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 82 +++++++++++++----------------- src/scheme/ao_scheme_atom.c | 40 ++++++++++++--- src/scheme/ao_scheme_builtin.c | 55 +++++++++++---------- src/scheme/ao_scheme_float.c | 4 +- src/scheme/ao_scheme_int.c | 17 ++++--- src/scheme/ao_scheme_mem.c | 25 +++++++--- src/scheme/ao_scheme_poly.c | 16 +++--- src/scheme/ao_scheme_read.c | 4 +- src/scheme/ao_scheme_string.c | 110 +++++++++++++++++++++++++++++------------ src/scheme/ao_scheme_vector.c | 11 +++-- 10 files changed, 220 insertions(+), 144 deletions(-) (limited to 'src/scheme/ao_scheme_read.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index ad80db2f..521ec105 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -23,6 +23,7 @@ #include #include +#include #define AO_SCHEME_BUILTIN_FEATURES #include "ao_scheme_builtin.h" #undef AO_SCHEME_BUILTIN_FEATURES @@ -93,7 +94,7 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut /* Primitive types */ #define AO_SCHEME_CONS 0 #define AO_SCHEME_INT 1 -#define AO_SCHEME_STRING 2 +#define AO_SCHEME_BIGINT 2 #define AO_SCHEME_OTHER 3 #define AO_SCHEME_TYPE_MASK 0x0003 @@ -109,17 +110,12 @@ 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_BIGINT AO_SCHEME_BIGINT -#else -#define _AO_SCHEME_BIGINT AO_SCHEME_BOOL -#endif +#define AO_SCHEME_STRING 11 #ifdef AO_SCHEME_FEATURE_FLOAT -#define AO_SCHEME_FLOAT (_AO_SCHEME_BIGINT + 1) +#define AO_SCHEME_FLOAT 12 #define _AO_SCHEME_FLOAT AO_SCHEME_FLOAT #else -#define _AO_SCHEME_FLOAT _AO_SCHEME_BIGINT +#define _AO_SCHEME_FLOAT 12 #endif #ifdef AO_SCHEME_FEATURE_VECTOR #define AO_SCHEME_VECTOR 13 @@ -180,6 +176,11 @@ struct ao_scheme_atom { char name[]; }; +struct ao_scheme_string { + uint8_t type; + char val[]; +}; + struct ao_scheme_val { ao_poly atom; ao_poly val; @@ -227,38 +228,16 @@ struct ao_scheme_vector { #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 +#define AO_SCHEME_MIN_BIGINT INT32_MIN +#define AO_SCHEME_MAX_BIGINT INT32_MAX -static inline uint32_t -ao_scheme_int_bigint(int32_t i) { - return AO_SCHEME_BIGINT | (i << 8); -} -static inline int32_t -ao_scheme_bigint_int(uint32_t bi) { - return (int32_t) bi >> 8; -} -#else -static inline uint32_t -ao_scheme_int_bigint(int32_t i) { - return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); -} -static inlint int32_t -ao_scheme_bigint_int(uint32_t bi) { - return (int32_t) (bi << 8) >> 8; -} - -#endif /* __BYTE_ORDER */ #endif /* AO_SCHEME_FEATURE_BIGINT */ -#define AO_SCHEME_NOT_INTEGER 0x7fffffff - /* Set on type when the frame escapes the lambda */ #define AO_SCHEME_FRAME_MARK 0x80 #define AO_SCHEME_FRAME_PRINT 0x40 @@ -475,20 +454,20 @@ ao_scheme_poly_bigint(ao_poly poly) static inline ao_poly ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) { - return ao_scheme_poly(bi, AO_SCHEME_OTHER); + return ao_scheme_poly(bi, AO_SCHEME_BIGINT); } #endif /* AO_SCHEME_FEATURE_BIGINT */ -static inline char * +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(char *s) +ao_scheme_string_poly(struct ao_scheme_string *s) { - return ao_scheme_poly(s, AO_SCHEME_STRING); + return ao_scheme_poly(s, AO_SCHEME_OTHER); } static inline struct ao_scheme_atom * @@ -599,9 +578,9 @@ ao_poly ao_scheme_poly_fetch(int id); void -ao_scheme_string_stash(int id, char *string); +ao_scheme_string_stash(int id, struct ao_scheme_string *string); -char * +struct ao_scheme_string * ao_scheme_string_fetch(int id); static inline void @@ -667,17 +646,23 @@ ao_scheme_cons_copy(struct ao_scheme_cons *cons); /* string */ extern const struct ao_scheme_type ao_scheme_string_type; -char * -ao_scheme_string_copy(char *a); +struct ao_scheme_string * +ao_scheme_string_copy(struct ao_scheme_string *a); -char * -ao_scheme_string_cat(char *a, char *b); +struct ao_scheme_string * +ao_scheme_string_make(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); ao_poly ao_scheme_string_pack(struct ao_scheme_cons *cons); ao_poly -ao_scheme_string_unpack(char *a); +ao_scheme_string_unpack(struct ao_scheme_string *a); void ao_scheme_string_write(ao_poly s); @@ -695,6 +680,9 @@ extern struct ao_scheme_frame *ao_scheme_frame_current; void ao_scheme_atom_write(ao_poly a); +struct ao_scheme_atom * +ao_scheme_string_to_atom(struct ao_scheme_string *string); + struct ao_scheme_atom * ao_scheme_atom_intern(char *name); @@ -716,7 +704,7 @@ ao_scheme_int_write(ao_poly i); #ifdef AO_SCHEME_FEATURE_BIGINT int32_t -ao_scheme_poly_integer(ao_poly p); +ao_scheme_poly_integer(ao_poly p, bool *fail); ao_poly ao_scheme_integer_poly(int32_t i); @@ -734,7 +722,7 @@ extern const struct ao_scheme_type ao_scheme_bigint_type; #else -#define ao_scheme_poly_integer ao_scheme_poly_int +#define ao_scheme_poly_integer(a,b) ao_scheme_poly_int(a) #define ao_scheme_integer_poly ao_scheme_int_poly static inline int diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c index cb32b7fe..745c32fe 100644 --- a/src/scheme/ao_scheme_atom.c +++ b/src/scheme/ao_scheme_atom.c @@ -71,8 +71,8 @@ const struct ao_scheme_type ao_scheme_atom_type = { struct ao_scheme_atom *ao_scheme_atoms; -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name) +static struct ao_scheme_atom * +ao_scheme_atom_find(char *name) { struct ao_scheme_atom *atom; @@ -86,15 +86,43 @@ ao_scheme_atom_intern(char *name) return atom; } #endif - ao_scheme_string_stash(0, name); - atom = ao_scheme_alloc(name_size(name)); - name = ao_scheme_string_fetch(0); + return NULL; +} + +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; - strcpy(atom->name, name); } +} + +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(0, string); + atom = ao_scheme_alloc(name_size(string->val)); + string = ao_scheme_string_fetch(0); + 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; } diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index b6788993..9a823f6a 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -130,10 +130,11 @@ ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int ty 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); - int32_t i = ao_scheme_poly_integer(p); + ao_poly p = ao_scheme_arg(cons, argc); + bool fail = false; + int32_t i = ao_scheme_poly_integer(p, &fail); - if (i == AO_SCHEME_NOT_INTEGER) + if (fail) (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p); return i; } @@ -324,14 +325,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)); + ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret, NULL)); #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) { + if (ao_scheme_poly_integer(ret, NULL) == 1) { } else { #ifdef AO_SCHEME_FEATURE_FLOAT if (ao_scheme_number_typep(ct)) { @@ -349,8 +350,8 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) } cons = ao_scheme_cons_fetch(0); } 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); + int32_t r = ao_scheme_poly_integer(ret, NULL); + int32_t c = ao_scheme_poly_integer(car, NULL); #ifdef AO_SCHEME_FEATURE_FLOAT int64_t t; #endif @@ -519,8 +520,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); - int32_t r = ao_scheme_poly_integer(right); + int32_t l = ao_scheme_poly_integer(left, NULL); + int32_t r = ao_scheme_poly_integer(right, NULL); switch (op) { case builtin_less: @@ -577,8 +578,8 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) } #endif /* AO_SCHEME_FEATURE_FLOAT */ } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { - int c = strcmp(ao_scheme_poly_string(left), - ao_scheme_poly_string(right)); + int c = strcmp(ao_scheme_poly_string(left)->val, + ao_scheme_poly_string(right)->val); switch (op) { case builtin_less: if (!(c < 0)) @@ -664,16 +665,16 @@ ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_string_ref(struct ao_scheme_cons *cons) { - char *string; + 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 (ref == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val; while (*string && ref) { ++string; --ref; @@ -689,20 +690,20 @@ ao_scheme_do_string_ref(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_string_length(struct ao_scheme_cons *cons) { - char *string; + 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)); + return ao_scheme_integer_poly(strlen(string->val)); } ao_poly ao_scheme_do_string_copy(struct ao_scheme_cons *cons) { - char *string; + struct ao_scheme_string *string; if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1)) return AO_SCHEME_NIL; @@ -715,7 +716,7 @@ ao_scheme_do_string_copy(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_string_set(struct ao_scheme_cons *cons) { - char *string; + char *string; int32_t ref; int32_t val; @@ -723,12 +724,12 @@ ao_scheme_do_string_set(struct ao_scheme_cons *cons) 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)); + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val; ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1); - if (ref == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2); - if (val == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; while (*string && ref) { ++string; @@ -759,7 +760,7 @@ ao_scheme_do_led(struct ao_scheme_cons *cons) 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 (led == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; led = ao_scheme_arg(cons, 0); ao_scheme_os_led(ao_scheme_poly_int(led)); @@ -774,7 +775,7 @@ ao_scheme_do_delay(struct ao_scheme_cons *cons) 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 (delay == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; ao_scheme_os_delay(delay); return delay; @@ -978,7 +979,7 @@ ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) return AO_SCHEME_NIL; - return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); + return ao_scheme_string_poly(ao_scheme_atom_to_string(ao_scheme_poly_atom(ao_scheme_arg(cons, 0)))); } ao_poly @@ -989,7 +990,7 @@ ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) return AO_SCHEME_NIL; - return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); + return ao_scheme_atom_poly(ao_scheme_string_to_atom(ao_scheme_poly_string(ao_scheme_arg(cons, 0))));; } ao_poly @@ -1009,7 +1010,7 @@ ao_scheme_do_write_char(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) return AO_SCHEME_NIL; - putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); + putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0), NULL)); return _ao_scheme_bool_true; } @@ -1068,7 +1069,7 @@ ao_scheme_do_make_vector(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2)) return AO_SCHEME_NIL; k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0); - if (k == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1))); } diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index c026c6fb..b75289d7 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -69,10 +69,10 @@ 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_BIGINT: - return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); case AO_SCHEME_FLOAT: return ao_scheme_poly_float(p)->value; } diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c index 43d6b8e1..4fcf4931 100644 --- a/src/scheme/ao_scheme_int.c +++ b/src/scheme/ao_scheme_int.c @@ -24,16 +24,19 @@ ao_scheme_int_write(ao_poly p) #ifdef AO_SCHEME_FEATURE_BIGINT int32_t -ao_scheme_poly_integer(ao_poly p) +ao_scheme_poly_integer(ao_poly p, bool *fail) { + if (fail) + *fail = false; switch (ao_scheme_poly_base_type(p)) { case AO_SCHEME_INT: return ao_scheme_poly_int(p); - case AO_SCHEME_OTHER: - if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) - return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + case AO_SCHEME_BIGINT: + return ao_scheme_poly_bigint(p)->value; } - return AO_SCHEME_NOT_INTEGER; + if (fail) + *fail = true; + return 0; } ao_poly @@ -44,7 +47,7 @@ ao_scheme_integer_poly(int32_t p) if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) return ao_scheme_int_poly(p); bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); - bi->value = ao_scheme_int_bigint(p); + bi->value = p; return ao_scheme_bigint_poly(bi); } @@ -77,6 +80,6 @@ ao_scheme_bigint_write(ao_poly p) { struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); - printf("%d", ao_scheme_bigint_int(bi->value)); + printf("%d", bi->value); } #endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index afa06d54..e7e89b89 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -178,7 +178,7 @@ struct ao_scheme_root { }; static struct ao_scheme_cons *save_cons[2]; -static char *save_string[2]; +static struct ao_scheme_string *save_string[2]; static struct ao_scheme_frame *save_frame[1]; static ao_poly save_poly[3]; @@ -488,7 +488,9 @@ dump_busy(void) static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { [AO_SCHEME_CONS] = &ao_scheme_cons_type, [AO_SCHEME_INT] = NULL, - [AO_SCHEME_STRING] = &ao_scheme_string_type, +#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, @@ -497,9 +499,7 @@ 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 + [AO_SCHEME_STRING] = &ao_scheme_string_type, #ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = &ao_scheme_float_type, #endif @@ -533,6 +533,7 @@ uint64_t ao_scheme_loops[2]; #endif int ao_scheme_last_top; +int ao_scheme_collect_counts; int ao_scheme_collect(uint8_t style) @@ -556,6 +557,14 @@ ao_scheme_collect(uint8_t style) 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; @@ -984,16 +993,16 @@ ao_scheme_poly_fetch(int id) } void -ao_scheme_string_stash(int id, char *string) +ao_scheme_string_stash(int id, struct ao_scheme_string *string) { assert(save_string[id] == NULL); save_string[id] = string; } -char * +struct ao_scheme_string * ao_scheme_string_fetch(int id) { - char *string = save_string[id]; + struct ao_scheme_string *string = save_string[id]; save_string[id] = NULL; return string; } diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 0bb427b9..2ea221ec 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -24,10 +24,12 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_cons_write, .display = ao_scheme_cons_display, }, - [AO_SCHEME_STRING] = { - .write = ao_scheme_string_write, - .display = ao_scheme_string_display, +#ifdef AO_SCHEME_FEATURE_BIGINT + [AO_SCHEME_BIGINT] = { + .write = ao_scheme_bigint_write, + .display = ao_scheme_bigint_write, }, +#endif [AO_SCHEME_INT] = { .write = ao_scheme_int_write, .display = ao_scheme_int_write, @@ -60,12 +62,10 @@ 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, + [AO_SCHEME_STRING] = { + .write = ao_scheme_string_write, + .display = ao_scheme_string_display, }, -#endif #ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = { .write = ao_scheme_float_write, diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index dce480ab..721211bc 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -555,7 +555,7 @@ ao_poly ao_scheme_read(void) { struct ao_scheme_atom *atom; - char *string; + struct ao_scheme_string *string; int read_state; ao_poly v = AO_SCHEME_NIL; @@ -605,7 +605,7 @@ ao_scheme_read(void) v = _ao_scheme_bool_false; break; case STRING: - string = ao_scheme_string_copy(token_string); + string = ao_scheme_string_make(token_string); if (string) v = ao_scheme_string_poly(string); else diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index ada626c3..e18a8e85 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -24,9 +24,10 @@ static void string_mark(void *addr) static int string_size(void *addr) { + struct ao_scheme_string *string = addr; if (!addr) return 0; - return strlen(addr) + 1; + return strlen(string->val) + 2; } static void string_move(void *addr) @@ -41,71 +42,114 @@ const struct ao_scheme_type ao_scheme_string_type = { .name = "string", }; -char * -ao_scheme_string_copy(char *a) +static struct ao_scheme_string * +ao_scheme_string_alloc(int len) { - int alen = strlen(a); - char *r; + struct ao_scheme_string *s; + + s = ao_scheme_alloc(len + 2); + if (!s) + return NULL; + s->type = AO_SCHEME_STRING; + 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(0, a); - r = ao_scheme_alloc(alen + 1); + r = ao_scheme_string_alloc(alen); a = ao_scheme_string_fetch(0); if (!r) return NULL; - strcpy(r, a); + strcpy(r->val, a->val); + return r; +} + +struct ao_scheme_string * +ao_scheme_string_make(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_poly_stash(0, ao_scheme_atom_poly(a)); + r = ao_scheme_string_alloc(alen); + a = ao_scheme_poly_atom(ao_scheme_poly_fetch(0)); + if (!r) + return NULL; + strcpy(r->val, a->name); return r; } -char * -ao_scheme_string_cat(char *a, char *b) +struct ao_scheme_string * +ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) { - int alen = strlen(a); - int blen = strlen(b); - char *r; + int alen = strlen(a->val); + int blen = strlen(b->val); + struct ao_scheme_string *r; ao_scheme_string_stash(0, a); ao_scheme_string_stash(1, b); - r = ao_scheme_alloc(alen + blen + 1); + r = ao_scheme_string_alloc(alen + blen); a = ao_scheme_string_fetch(0); b = ao_scheme_string_fetch(1); if (!r) return NULL; - strcpy(r, a); - strcpy(r+alen, b); + strcpy(r->val, a->val); + strcpy(r->val+alen, b->val); return r; } ao_poly ao_scheme_string_pack(struct ao_scheme_cons *cons) { - char *r; - char *s; - int len; + struct ao_scheme_string *r; + char *rval; + int len; len = ao_scheme_cons_length(cons); ao_scheme_cons_stash(0, cons); - r = ao_scheme_alloc(len + 1); + r = ao_scheme_string_alloc(len); cons = ao_scheme_cons_fetch(0); - s = r; + if (!r) + return AO_SCHEME_NIL; + rval = r->val; while (cons) { - if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) + 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"); - *s++ = ao_scheme_poly_integer(cons->car); - cons = ao_scheme_poly_cons(cons->cdr); + cons = ao_scheme_cons_cdr(cons); } - *s++ = 0; + *rval++ = 0; return ao_scheme_string_poly(r); } ao_poly -ao_scheme_string_unpack(char *a) +ao_scheme_string_unpack(struct ao_scheme_string *a) { struct ao_scheme_cons *cons = NULL, *tail = NULL; int c; int i; - for (i = 0; (c = a[i]); i++) { + for (i = 0; (c = a->val[i]); i++) { struct ao_scheme_cons *n; ao_scheme_cons_stash(0, cons); ao_scheme_cons_stash(1, tail); @@ -131,11 +175,12 @@ ao_scheme_string_unpack(char *a) void ao_scheme_string_write(ao_poly p) { - char *s = ao_scheme_poly_string(p); - char c; + struct ao_scheme_string *s = ao_scheme_poly_string(p); + char *sval = s->val; + char c; putchar('"'); - while ((c = *s++)) { + while ((c = *sval++)) { switch (c) { case '\n': printf ("\\n"); @@ -160,9 +205,10 @@ ao_scheme_string_write(ao_poly p) void ao_scheme_string_display(ao_poly p) { - char *s = ao_scheme_poly_string(p); - char c; + struct ao_scheme_string *s = ao_scheme_poly_string(p); + char *sval = s->val; + char c; - while ((c = *s++)) + while ((c = *sval++)) putchar(c); } diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index 0114c5a9..a4127f64 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -107,14 +107,15 @@ ao_scheme_vector_display(ao_poly v) static int32_t ao_scheme_vector_offset(struct ao_scheme_vector *vector, ao_poly i) { - int32_t offset = ao_scheme_poly_integer(i); + bool fail; + int32_t offset = ao_scheme_poly_integer(i, &fail); - if (offset == AO_SCHEME_NOT_INTEGER) + 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 = AO_SCHEME_NOT_INTEGER; + offset = -1; } return offset; } @@ -125,7 +126,7 @@ 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 == AO_SCHEME_NOT_INTEGER) + if (offset < 0) return AO_SCHEME_NIL; return vector->vals[offset]; } @@ -136,7 +137,7 @@ 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 == AO_SCHEME_NOT_INTEGER) + if (offset < 0) return AO_SCHEME_NIL; return vector->vals[offset] = p; } -- cgit v1.2.3 From fa6f4b331db9d37da6767005fd375b696485b46b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 11:43:23 -0800 Subject: altos/scheme: ao_scheme__cons -> ao_scheme_cons Fix the double underscore in this name. Ick. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 2 +- src/scheme/ao_scheme_builtin.c | 10 +++++----- src/scheme/ao_scheme_cons.c | 2 +- src/scheme/ao_scheme_eval.c | 2 +- src/scheme/ao_scheme_read.c | 2 +- 5 files changed, 9 insertions(+), 9 deletions(-) (limited to 'src/scheme/ao_scheme_read.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index b37e9098..5b31c623 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -646,7 +646,7 @@ struct ao_scheme_cons * ao_scheme_cons_cdr(struct ao_scheme_cons *cons); ao_poly -ao_scheme__cons(ao_poly car, ao_poly cdr); +ao_scheme_cons(ao_poly car, ao_poly cdr); extern struct ao_scheme_cons *ao_scheme_cons_free_list; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 221570c7..f4dff5bf 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -168,7 +168,7 @@ ao_scheme_do_cons(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; car = ao_scheme_arg(cons, 0); cdr = ao_scheme_arg(cons, 1); - return ao_scheme__cons(car, cdr); + return ao_scheme_cons(car, cdr); } ao_poly @@ -253,10 +253,10 @@ ao_scheme_do_setq(struct ao_scheme_cons *cons) 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 ao_scheme_cons(_ao_scheme_atom_set, + ao_scheme_cons(ao_scheme_cons(_ao_scheme_atom_quote, + ao_scheme_cons(name, AO_SCHEME_NIL)), + cons->cdr)); } ao_poly diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 7976250b..d40c2826 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -119,7 +119,7 @@ ao_scheme_cons_cdr(struct ao_scheme_cons *cons) } ao_poly -ao_scheme__cons(ao_poly car, ao_poly cdr) +ao_scheme_cons(ao_poly car, ao_poly cdr) { return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); } diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c index 9204ce1a..edc16a73 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -206,7 +206,7 @@ ao_scheme_eval_formal(void) } /* Append formal to list of values */ - formal = ao_scheme__cons(ao_scheme_v, AO_SCHEME_NIL); + formal = ao_scheme_cons(ao_scheme_v, AO_SCHEME_NIL); if (!formal) return 0; diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 721211bc..e93466fc 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -510,7 +510,7 @@ push_read_stack(int 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(ao_scheme_int_poly(read_state), ao_scheme_cons_poly(ao_scheme_read_stack))); if (!ao_scheme_read_stack) return 0; -- cgit v1.2.3