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 <keithp@keithp.com>

diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h
index ad80db2f03cb433835d2e84c8da43b024ec7c8c5..521ec10505296a70b3782679b821237e1fc0cff3 100644 (file)
--- a/src/scheme/ao_scheme.h
+++ b/src/scheme/ao_scheme.h
@@ -23,6 +23,7 @@
 
 #include <stdint.h>
 #include <string.h>
+#include <stdbool.h>
 #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 cb32b7fe3d0940224db99907a4c62b0d2a9d3787..745c32fee48ddf6ae615034629b2296852445b7a 100644 (file)
--- 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 b67889930a33fbc47833435fd032c962a04c4edb..9a823f6ab917812c80d27143b73c7c2f19bcfb62 100644 (file)
--- 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 c026c6fb1fd477f9f612e79016beecbb4d287213..b75289d7f131d69af265ab5f02e5de10312903f0 100644 (file)
--- 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 43d6b8e1064b46df2f51a069643cc030f9b874f6..4fcf4931234050acbc9f5517cf394afbfe3aac9f 100644 (file)
--- 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 afa06d546d8b78a2c601a161a408a55f252cce6f..e7e89b89490ea902b81f23e92bebb987beefd305 100644 (file)
--- 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 0bb427b96b6bca570afbd1be41a81839c0ea638b..2ea221ec996e4404f726396fd096b7c4f0d8b507 100644 (file)
--- 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 dce480ab1745197f0b858be9ef25b1bd57b6b846..721211bc7a9b3ad1e57e23d6803bf516f215de8b 100644 (file)
--- 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 ada626c3091c1a7a3b68943e90e94f8c8236b271..e18a8e854df8ded0dfeef1ede11f757a61dd5a28 100644 (file)
--- 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 0114c5a925fa056228337138672551a16313bca2..a4127f64d8b43635c86b423d5291cc1429e128c1 100644 (file)
--- 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;
 }