generic aref/aset for all arrays

(string v) now works on any value, by printing to a string

some bug fixes in ios

femtolisp/Makefile

@@ -8,7 +8,7 @@ EXENAME = $(NAME)
 LLTDIR = ../llt
 LLT = $(LLTDIR)/libllt.a
 
-FLAGS = -Wall -Wextra -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS)
+FLAGS = -falign-functions -Wall -Wextra -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS)
 LIBS = $(LLT) -lm
 
 DEBUGFLAGS = -g -DDEBUG $(FLAGS)

femtolisp/cvalues.c

@@ -1,4 +1,3 @@
-#define MAX_INL_SIZE 96
 #ifdef BITS64
 #define NWORDS(sz) (((sz)+7)>>3)
 #else
@@ -113,6 +112,11 @@ static void autorelease(cvalue_t *cv)
     add_finalizer(cv);
 }
 
+void cv_autorelease(cvalue_t *cv)
+{
+    autorelease(cv);
+}
+
 value_t cvalue(fltype_t *type, size_t sz)
 {
     cvalue_t *pcv;
@@ -369,8 +373,7 @@ static void array_init_fromargs(char *dest, value_t *vals, size_t cnt,
 
 static int isarray(value_t v)
 {
-    if (!iscvalue(v)) return 0;
+    return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != NULL;
-    return cv_class((cvalue_t*)ptr(v))->eltype != NULL;
 }
 
 static size_t predict_arraylen(value_t arg)
@@ -756,46 +759,53 @@ value_t cvalue_compare(value_t a, value_t b)
     return fixnum(diff);
 }
 
-static void check_addr_args(char *fname, size_t typesize, value_t *args,
+static void check_addr_args(char *fname, value_t arr, value_t ind,
-                            void **data, ulong_t *index)
+                            char **data, ulong_t *index)
 {
-    size_t sz;
+    size_t numel;
-    if (!iscvalue(args[0]))
+    cvalue_t *cv = (cvalue_t*)ptr(arr);
-        type_error(fname, "cvalue", args[0]);
+    *data = cv_data(cv);
-    *data = cv_data((cvalue_t*)ptr(args[0]));
+    numel = cv_len(cv)/(cv_class(cv)->elsz);
-    sz = cv_len((cvalue_t*)ptr(args[0]));
+    *index = toulong(ind, fname);
-    cvalue_t *cv = (cvalue_t*)ptr(args[1]);
+    if (*index >= numel)
-    if (isfixnum(args[1]))
+        bounds_error(fname, arr, ind);
-        *index = numval(args[1]);
-    else if (!iscvalue(args[1]) || !valid_numtype(cv_numtype(cv)))
-        type_error(fname, "number", args[1]);
-    else
-        *index = conv_to_ulong(cv_data(cv), cv_numtype(cv));
-    if (*index > sz - typesize)
-        bounds_error(fname, args[0], args[1]);
 }
 
-value_t cvalue_get_int8(value_t *args, u_int32_t nargs)
+static value_t make_uninitialized_instance(fltype_t *t)
 {
-    void *data; ulong_t index;
+    if (t->eltype != NULL)
-    argcount("get-int8", nargs, 2);
+        return alloc_array(t, t->size);
-    check_addr_args("get-int8", sizeof(int8_t), args, &data, &index);
+    return cvalue(t, t->size);
-    return fixnum(((int8_t*)data)[index]);
 }
 
-value_t cvalue_set_int8(value_t *args, u_int32_t nargs)
+static value_t cvalue_array_aref(value_t *args)
 {
-    void *data; ulong_t index; int32_t val=0;
+    char *data; ulong_t index;
-    argcount("set-int8", nargs, 3);
+    fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
-    check_addr_args("set-int8", sizeof(int8_t), args, &data, &index);
+    value_t el = make_uninitialized_instance(eltype);
-    cvalue_t *cv = (cvalue_t*)ptr(args[2]);
+    check_addr_args("aref", args[0], args[1], &data, &index);
-    if (isfixnum(args[2]))
+    char *dest = cv_data((cvalue_t*)ptr(el));
-        val = numval(args[2]);
+    size_t sz = eltype->size;
-    else if (!iscvalue(args[2]) || !valid_numtype(cv_numtype(cv)))
+    if (sz == 1)
-        type_error("set-int8", "number", args[2]);
+        *dest = data[index];
+    else if (sz == 2)
+        *(int16_t*)dest = ((int16_t*)data)[index];
+    else if (sz == 4)
+        *(int32_t*)dest = ((int32_t*)data)[index];
+    else if (sz == 8)
+        *(int64_t*)dest = ((int64_t*)data)[index];
     else
-        val = conv_to_int32(cv_data(cv), cv_numtype(cv));
+        memcpy(dest, data + index*sz, sz);
-    ((int8_t*)data)[index] = val;
+    return el;
+}
+
+static value_t cvalue_array_aset(value_t *args)
+{
+    char *data; ulong_t index;
+    fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
+    check_addr_args("aset", args[0], args[1], &data, &index);
+    char *dest = data + index*eltype->size;
+    cvalue_init(eltype, args[2], dest);
     return args[2];
 }
 
@@ -812,6 +822,7 @@ value_t fl_builtin(value_t *args, u_int32_t nargs)
 
 value_t cbuiltin(char *name, builtin_t f)
 {
+    assert(((uptrint_t)f & 0x7) == 0);
     value_t sym = symbol(name);
     ((symbol_t*)ptr(sym))->dlcache = f;
     ptrhash_put(&reverse_dlsym_lookup_table, f, (void*)sym);
@@ -874,8 +885,6 @@ void cvalues_init()
     cv_intern(void);
 
     set(symbol("c-value"), cbuiltin("c-value", cvalue_new));
-    set(symbol("get-int8"), cbuiltin("get-int8", cvalue_get_int8));
-    set(symbol("set-int8"), cbuiltin("set-int8", cvalue_set_int8));
     set(symbol("typeof"), cbuiltin("typeof", cvalue_typeof));
     set(symbol("sizeof"), cbuiltin("sizeof", cvalue_sizeof));
     set(symbol("builtin"), cbuiltin("builtin", fl_builtin));

femtolisp/flisp.c

@@ -924,12 +924,15 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
         case F_AREF:
             argcount("aref", nargs, 2);
             v = Stack[SP-2];
-            i = tofixnum(Stack[SP-1], "aref");
             if (isvector(v)) {
+                i = tofixnum(Stack[SP-1], "aref");
                 if ((unsigned)i >= vector_size(v))
                     bounds_error("aref", v, Stack[SP-1]);
                 v = vector_elt(v, i);
             }
+            else if (isarray(v)) {
+                v = cvalue_array_aref(&Stack[SP-2]);
+            }
             else {
                 // TODO other sequence types?
                 type_error("aref", "sequence", v);
@@ -938,12 +941,15 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
         case F_ASET:
             argcount("aset", nargs, 3);
             e = Stack[SP-3];
-            i = tofixnum(Stack[SP-2], "aset");
             if (isvector(e)) {
+                i = tofixnum(Stack[SP-2], "aset");
                 if ((unsigned)i >= vector_size(e))
                     bounds_error("aref", v, Stack[SP-1]);
                 vector_elt(e, i) = (v=Stack[SP-1]);
             }
+            else if (isarray(e)) {
+                v = cvalue_array_aset(&Stack[SP-3]);
+            }
             else {
                 type_error("aset", "sequence", e);
             }

femtolisp/flisp.h

@@ -201,6 +201,7 @@ typedef struct {
 } cprim_t;
 
 #define CPRIM_NWORDS 2
+#define MAX_INL_SIZE 96
 
 #define CV_OWNED_BIT  0x1
 #define CV_PARENT_BIT 0x2
@@ -242,6 +243,7 @@ extern fltype_t *builtintype;
 
 value_t cvalue(fltype_t *type, size_t sz);
 void add_finalizer(cvalue_t *cv);
+void cv_autorelease(cvalue_t *cv);
 size_t ctype_sizeof(value_t type, int *palign);
 value_t cvalue_copy(value_t v);
 value_t cvalue_from_data(fltype_t *type, void *data, size_t sz);

femtolisp/read.c

@@ -538,8 +538,8 @@ value_t read_sexpr(ios_t *f)
     value_t v;
     readstate_t state;
     state.prev = readstate;
-    htable_new(&state.backrefs, 16);
+    htable_new(&state.backrefs, 8);
-    htable_new(&state.gensyms, 16);
+    htable_new(&state.gensyms, 8);
     readstate = &state;
 
     v = do_read_sexpr(f, UNBOUND);

femtolisp/string.c

@@ -14,6 +14,27 @@
 #include "llt.h"
 #include "flisp.h"
 
+static value_t print_to_string(value_t v, int princ)
+{
+    ios_t str;
+    ios_mem(&str, 0);
+    print(&str, v, princ);
+    value_t outp;
+    if (str.size < MAX_INL_SIZE) {
+        outp = cvalue_string(str.size);
+        memcpy(cv_data((cvalue_t*)ptr(outp)), str.buf, str.size);
+    }
+    else {
+        size_t sz;
+        char *buf = ios_takebuf(&str, &sz);
+        buf[sz] = '\0';
+        outp = cvalue_from_ref(stringtype, buf, sz-1, NIL);
+        cv_autorelease((cvalue_t*)ptr(outp));
+    }
+    ios_close(&str);
+    return outp;
+}
+
 value_t fl_intern(value_t *args, u_int32_t nargs)
 {
     argcount("intern", nargs, 1);
@@ -123,7 +144,11 @@ value_t fl_string(value_t *args, u_int32_t nargs)
                 continue;
             }
         }
-        lerror(ArgError, "string: expected string, symbol or character");
+        args[i] = print_to_string(args[i], 0);
+        if (nargs == 1)  // convert single value to string
+            return args[i];
+        sz += cv_len((cvalue_t*)ptr(args[i]));
+        //lerror(ArgError, "string: expected string, symbol or character");
     }
     cv = cvalue_string(sz);
     char *ptr = cvalue_data(cv);

femtolisp/todo

@@ -130,7 +130,7 @@ for internal use:
  . disadvantage is looking through the lambda list on every lookup. maybe
    improve by making lambda lists vectors somehow?
 * fast builtin bounded iteration construct (for lo hi (lambda (x) ...))
-- represent guest function as a tagged function pointer; allocate nothing
+* represent guest function as a tagged function pointer; allocate nothing
 
 bugs:
 * with the fully recursive (simpler) relocate(), the size of cons chains
@@ -927,7 +927,9 @@ consolidated todo list as of 8/30:
 - use the unused tag for TAG_PRIM, add smaller prim representation
 * finalizers in gc
 * hashtable
+* generic aref/aset
 - expose io stream object
+- new toplevel
 
 - enable print-shared for cvalues' types
 - remaining c types

llt/ios.c

@@ -154,9 +154,6 @@ static char *_buf_realloc(ios_t *s, size_t sz)
 {
     char *temp;
 
-    if (sz <= s->maxsize)
-        return s->buf;
-
     if ((s->buf==NULL || s->buf==&s->local[0]) && (sz <= IOS_INLSIZE)) {
         /* TODO: if we want to allow shrinking, see if the buffer shrank
            down to this size, in which case we need to copy. */
@@ -165,7 +162,10 @@ static char *_buf_realloc(ios_t *s, size_t sz)
         s->ownbuf = 1;
         return s->buf;
     }
-    else if (s->ownbuf && s->buf != &s->local[0]) {
+
+    if (sz <= s->maxsize) return s->buf;
+
+    if (s->ownbuf && s->buf != &s->local[0]) {
         // if we own the buffer we're free to resize it
         // always allocate 1 bigger in case user wants to add a NUL
         // terminator after taking over the buffer
@@ -201,7 +201,7 @@ static size_t _write_grow(ios_t *s, char *data, size_t n)
         if (s->bpos + n > s->maxsize) {
             /* TODO: here you might want to add a mechanism for limiting
                the growth of the stream. */
-            newsize = s->maxsize * 2;
+            newsize = s->maxsize ? s->maxsize * 2 : 8;
             while (s->bpos + n > newsize)
                 newsize *= 2;
             if (_buf_realloc(s, newsize) == NULL) {
@@ -514,6 +514,8 @@ void ios_close(ios_t *s)
     if (s->fd != -1 && s->ownfd)
         close(s->fd);
     s->fd = -1;
+    if (s->buf!=NULL && s->ownbuf && s->buf!=&s->local[0])
+        free(s->buf);
 }
 
 static void _buf_init(ios_t *s, bufmode_t bm)