shithub: femtolisp

--- a/femtolisp/Makefile

+++ b/femtolisp/Makefile

@@ -8,7 +8,7 @@

 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)

--- a/femtolisp/cvalues.c

+++ b/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 @@

     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 int isarray(value_t v)

-    if (!iscvalue(v)) return 0;

-    return cv_class((cvalue_t*)ptr(v))->eltype != NULL;

+    return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != NULL;

 static size_t predict_arraylen(value_t arg)

@@ -756,46 +759,53 @@

     return fixnum(diff);

-static void check_addr_args(char *fname, size_t typesize, value_t *args,

-                            void **data, ulong_t *index)

+static void check_addr_args(char *fname, value_t arr, value_t ind,

+                            char **data, ulong_t *index)

-    size_t sz;

-    if (!iscvalue(args[0]))

-        type_error(fname, "cvalue", args[0]);

-    *data = cv_data((cvalue_t*)ptr(args[0]));

-    sz = cv_len((cvalue_t*)ptr(args[0]));

-    cvalue_t *cv = (cvalue_t*)ptr(args[1]);

-    if (isfixnum(args[1]))

-        *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]);

+    size_t numel;

+    cvalue_t *cv = (cvalue_t*)ptr(arr);

+    *data = cv_data(cv);

+    numel = cv_len(cv)/(cv_class(cv)->elsz);

+    *index = toulong(ind, fname);

+    if (*index >= numel)

+        bounds_error(fname, arr, ind);

-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;

-    argcount("get-int8", nargs, 2);

-    check_addr_args("get-int8", sizeof(int8_t), args, &data, &index);

-    return fixnum(((int8_t*)data)[index]);

+    if (t->eltype != NULL)

+        return alloc_array(t, t->size);

+    return cvalue(t, t->size);

-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;

-    argcount("set-int8", nargs, 3);

-    check_addr_args("set-int8", sizeof(int8_t), args, &data, &index);

-    cvalue_t *cv = (cvalue_t*)ptr(args[2]);

-    if (isfixnum(args[2]))

-        val = numval(args[2]);

-    else if (!iscvalue(args[2]) || !valid_numtype(cv_numtype(cv)))

-        type_error("set-int8", "number", args[2]);

+    char *data; ulong_t index;

+    fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;

+    value_t el = make_uninitialized_instance(eltype);

+    check_addr_args("aref", args[0], args[1], &data, &index);

+    char *dest = cv_data((cvalue_t*)ptr(el));

+    size_t sz = eltype->size;

+    if (sz == 1)

+        *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));

-    ((int8_t*)data)[index] = val;

+        memcpy(dest, data + index*sz, sz);

+    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 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 @@

     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));

--- a/femtolisp/flisp.c

+++ b/femtolisp/flisp.c

@@ -924,12 +924,15 @@

         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,11 +941,14 @@

         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);

--- a/femtolisp/flisp.h

+++ b/femtolisp/flisp.h

@@ -201,6 +201,7 @@

 } 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 @@

 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);

--- a/femtolisp/read.c

+++ b/femtolisp/read.c

@@ -538,8 +538,8 @@

     value_t v;

     readstate_t state;

     state.prev = readstate;

-    htable_new(&state.backrefs, 16);

-    htable_new(&state.gensyms, 16);

+    htable_new(&state.backrefs, 8);

+    htable_new(&state.gensyms, 8);

     readstate = &state;

     v = do_read_sexpr(f, UNBOUND);

--- a/femtolisp/string.c

+++ b/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 @@

                 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);

--- a/femtolisp/todo

+++ b/femtolisp/todo

@@ -130,7 +130,7 @@

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

 - 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

--- a/llt/ios.c

+++ b/llt/ios.c

@@ -154,9 +154,6 @@

     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 @@

         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 @@

         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 @@

     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)