shithub: femtolisp

--- a/femtolisp/cvalues.c

+++ b/femtolisp/cvalues.c

@@ -18,6 +18,7 @@

 value_t unionsym;

 static htable_t TypeTable;

+static htable_t reverse_dlsym_lookup_table;

 static fltype_t *int8type, *uint8type;

 static fltype_t *int16type, *uint16type;

 static fltype_t *int32type, *uint32type;

@@ -802,8 +803,24 @@

     return args[2];

-value_t cbuiltin(builtin_t f)

+value_t fl_builtin(value_t *args, u_int32_t nargs)

+    argcount("builtin", nargs, 1);

+    symbol_t *name = tosymbol(args[0], "builtin");

+    builtin_t f = (builtin_t)name->dlcache;

+    if (f == NULL) {

+        lerror(ArgError, "builtin: function not found");

+    }

+    return tagptr(f, TAG_BUILTIN);

+}

+value_t cbuiltin(char *name, builtin_t f)

+{

+    value_t sym = symbol(name);

+    ((symbol_t*)ptr(sym))->dlcache = f;

+    ptrhash_put(&reverse_dlsym_lookup_table, f, (void*)sym);

+    return tagptr(f, TAG_BUILTIN);

+    /*

     value_t gf = cvalue(builtintype, sizeof(void*));

     ((cvalue_t*)ptr(gf))->data = f;

     size_t nw = cv_nwords((cvalue_t*)ptr(gf));

@@ -813,10 +830,12 @@

     cvalue_t *buf = malloc_aligned(nw * sizeof(value_t), 8);

     memcpy(buf, ptr(gf), nw*sizeof(value_t));

     return tagptr(buf, TAG_BUILTIN);

+    */

 #define cv_intern(tok) tok##sym = symbol(#tok)

-#define ctor_cv_intern(tok) cv_intern(tok);set(tok##sym, cbuiltin(cvalue_##tok))

+#define ctor_cv_intern(tok) \

+    cv_intern(tok);set(tok##sym, cbuiltin(#tok, cvalue_##tok))

 void types_init();

@@ -823,6 +842,7 @@

 void cvalues_init()

     htable_new(&TypeTable, 256);

+    htable_new(&reverse_dlsym_lookup_table, 256);

     // compute struct field alignment required for primitives

     ALIGN2   = sizeof(struct { char a; int16_t i; }) - 2;

@@ -857,11 +877,12 @@

     cv_intern(union);

     cv_intern(void);

-    set(symbol("c-value"), cbuiltin(cvalue_new));

-    set(symbol("get-int8"), cbuiltin(cvalue_get_int8));

-    set(symbol("set-int8"), cbuiltin(cvalue_set_int8));

-    set(symbol("typeof"), cbuiltin(cvalue_typeof));

-    set(symbol("sizeof"), cbuiltin(cvalue_sizeof));

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

     // todo: autorelease

     stringtypesym = symbol("*string-type*");

--- a/femtolisp/flisp.c

+++ b/femtolisp/flisp.c

@@ -69,7 +69,7 @@

 value_t NIL, T, LAMBDA, QUOTE, IF, TRYCATCH;

 value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;

 value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;

-value_t DivideError, BoundsError, Error;

+value_t DivideError, BoundsError, Error, KeyError;

 value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;

 value_t defunsym, defmacrosym, forsym, labelsym, printprettysym;

 value_t printwidthsym;

@@ -335,6 +335,11 @@

     return v;

+// cvalues --------------------------------------------------------------------

+#include "cvalues.c"

+#include "types.c"

 // print ----------------------------------------------------------------------

 static int isnumtok(char *tok, value_t *pval);

@@ -342,11 +347,6 @@

 #include "print.c"

-// cvalues --------------------------------------------------------------------

-#include "cvalues.c"

-#include "types.c"

 // collector ------------------------------------------------------------------

 static value_t relocate(value_t v)

@@ -1193,9 +1193,8 @@

             noeval = 1;

             goto apply_lambda;

         default:

-            // a guest function is a cvalue tagged as a builtin

-            cv = (cvalue_t*)ptr(f);

-            v = ((builtin_t)cv->data)(&Stack[saveSP+1], nargs);

+            // function pointer tagged as a builtin

+            v = ((builtin_t)ptr(f))(&Stack[saveSP+1], nargs);

         SP = saveSP;

         return v;

@@ -1317,7 +1316,7 @@

 void assign_global_builtins(builtinspec_t *b)

     while (b->name != NULL) {

-        set(symbol(b->name), cbuiltin(b->fptr));

+        set(symbol(b->name), cbuiltin(b->name, b->fptr));

         b++;

@@ -1350,6 +1349,7 @@

     TypeError = symbol("type-error");

     ArgError = symbol("arg-error");

     UnboundError = symbol("unbound-error");

+    KeyError = symbol("key-error");

     MemoryError = symbol("memory-error");

     BoundsError = symbol("bounds-error");

     DivideError = symbol("divide-error");

@@ -1389,8 +1389,8 @@

 #endif

     cvalues_init();

-    set(symbol("gensym"), cbuiltin(gensym));

-    set(symbol("hash"), cbuiltin(fl_hash));

+    set(symbol("gensym"), cbuiltin("gensym", gensym));

+    set(symbol("hash"), cbuiltin("hash", fl_hash));

     char buf[1024];

     char *exename = get_exename(buf, sizeof(buf));

--- a/femtolisp/flisp.h

+++ b/femtolisp/flisp.h

@@ -148,7 +148,7 @@

 void raise(value_t e) __attribute__ ((__noreturn__));

 void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__));

 void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__));

-extern value_t ArgError, IOError;

+extern value_t ArgError, IOError, KeyError;

 static inline void argcount(char *fname, int nargs, int c)

     if (nargs != c)

@@ -245,7 +245,7 @@

 value_t cvalue_copy(value_t v);

 value_t cvalue_from_data(fltype_t *type, void *data, size_t sz);

 value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent);

-value_t cbuiltin(builtin_t f);

+value_t cbuiltin(char *name, builtin_t f);

 size_t cvalue_arraylen(value_t v);

 value_t size_wrap(size_t sz);

 size_t toulong(value_t n, char *fname);

--- a/femtolisp/print.c

+++ b/femtolisp/print.c

@@ -332,7 +332,14 @@

             outs(builtin_names[uintval(v)], f);

             break;

-        cvalue_print(f, v, princ);

+        label = (value_t)ptrhash_get(&reverse_dlsym_lookup_table, ptr(v));

+        if (label == (value_t)HT_NOTFOUND) {

+            HPOS += ios_printf(f, "#<builtin @0x%08lx>",

+                               (unsigned long)(builtin_t)ptr(v));

+        }

+        else {

+            HPOS += ios_printf(f, "#builtin(%s)", symbol_name(label));

+        }

         break;

     case TAG_CVALUE:

     case TAG_VECTOR:

--- a/femtolisp/system.lsp

+++ b/femtolisp/system.lsp

@@ -87,8 +87,8 @@

 (define (cadr x) (car (cdr x)))

-(setq *special-forms* '(quote cond if and or while lambda label trycatch

-                        %top progn))

+;(setq *special-forms* '(quote cond if and or while lambda label trycatch

+;                        %top progn))

 (defun macroexpand (e)

   ((label mexpand

@@ -420,14 +420,6 @@

            (setq l (cons (aref v (- n i)) l))))

l))

-(defun vector.map (f v)

-  (let* ((n (length v))

-         (nv (vector.alloc n)))

-    (for 0 (- n 1)

-         (lambda (i)

-           (aset nv i (f (aref v i)))))

-    nv))

 (defun self-evaluating-p (x)

   (or (eq x nil)

       (eq x T)

@@ -493,3 +485,21 @@

        (prog1

            ,expr

          (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))

+(defun vector.map (f v)

+  (let* ((n (length v))

+         (nv (vector.alloc n)))

+    (for 0 (- n 1)

+         (lambda (i)

+           (aset nv i (f (aref v i)))))

+    nv))

+(defun table.pairs (t)

+  (table.foldl (lambda (k v z) (cons (cons k v) z))

+               () t))

+(defun table.keys (t)

+  (table.foldl (lambda (k v z) (cons k z))

+               () t))

+(defun table.values (t)

+  (table.foldl (lambda (k v z) (cons v z))

+               () t))

--- a/femtolisp/table.c

+++ b/femtolisp/table.c

@@ -6,27 +6,11 @@

 #include <sys/types.h>

 #include "llt.h"

 #include "flisp.h"

+#include "equalhash.h"

 static value_t tablesym;

 static fltype_t *tabletype;

-/*

-  there are 2 kinds of hash tables (eq and equal), each with some

-  optimized special cases. here are the building blocks:

-  hash/compare function: (h1) eq (ptrhash) and (h2) equal (deep hash)

-  relocate: (r1) no relocate, (r2) relocate but no rehash, (r3) rehash

-  eq hash:

-  keys all eq_comparable, no gensyms: h1, r1

-  anything else: h1, r3

-  equal hash:

-  keys all eq_comparable, no gensyms: h1, r1

-  with gensyms: h1, r2

-  anything else: h2, r2

-*/

 typedef struct {

     void *(*get)(void *t, void *key);

     void (*remove)(void *t, void *key);

@@ -58,6 +42,19 @@

     fl_print_chr(')', f);

+void print_traverse_htable(value_t self)

+{

+    fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(self));

+    htable_t *h = &pt->ht;

+    size_t i;

+    for(i=0; i < h->size; i+=2) {

+        if (h->table[i+1] != HT_NOTFOUND) {

+            print_traverse((value_t)h->table[i]);

+            print_traverse((value_t)h->table[i+1]);

+        }

+    }

+}

 void free_htable(value_t self)

     fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(self));

@@ -66,6 +63,7 @@

 void relocate_htable(value_t oldv, value_t newv)

+    (void)oldv;

     fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(newv));

     htable_t *h = &pt->ht;

     size_t i;

@@ -75,82 +73,113 @@

-void print_traverse_htable(value_t self)

-{

-    fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(self));

-    htable_t *h = &pt->ht;

-    size_t i;

-    for(i=0; i < h->size; i++) {

-        if (h->table[i] != HT_NOTFOUND)

-            print_traverse((value_t)h->table[i]);

-    }

-}

+cvtable_t table_vtable = { print_htable, relocate_htable, free_htable,

+                           print_traverse_htable };

-void rehash_htable(value_t oldv, value_t newv)

-{

-}

-cvtable_t h_r1_vtable = { print_htable, NULL, free_htable,

-                          print_traverse_htable };

-cvtable_t h_r2_vtable = { print_htable, relocate_htable, free_htable,

-                          print_traverse_htable };

-cvtable_t h_r3_vtable = { print_htable, rehash_htable, free_htable,

-                          print_traverse_htable };

 int ishashtable(value_t v)

     return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == tabletype;

-value_t fl_hashtablep(value_t *args, u_int32_t nargs)

+value_t fl_hashtablep(value_t *args, uint32_t nargs)

     argcount("hashtablep", nargs, 1);

     return ishashtable(args[0]) ? T : NIL;

-value_t fl_table(value_t *args, u_int32_t nargs)

+static fltable_t *totable(value_t v, char *fname)

+    if (ishashtable(v))

+        return (fltable_t*)cv_data((cvalue_t*)ptr(v));

+    type_error(fname, "table", v);

+    return NULL;

+}

+value_t fl_table(value_t *args, uint32_t nargs)

+{

     if (nargs & 1)

         lerror(ArgError, "table: arguments must come in pairs");

     value_t nt = cvalue(tabletype, sizeof(fltable_t));

     fltable_t *h = (fltable_t*)cv_data((cvalue_t*)ptr(nt));

     htable_new(&h->ht, 8);

-    int i;

+    uint32_t i;

     for(i=0; i < nargs; i+=2)

-        equalhash_put(&h->ht, args[i], args[i+1]);

+        equalhash_put(&h->ht, (void*)args[i], (void*)args[i+1]);

     return nt;

 // (put table key value)

-value_t fl_hash_put(value_t *args, u_int32_t nargs)

+value_t fl_table_put(value_t *args, uint32_t nargs)

     argcount("put", nargs, 3);

-    return NIL;

+    fltable_t *pt = totable(args[0], "put");

+    equalhash_put(&pt->ht, (void*)args[1], (void*)args[2]);

+    return args[0];

 // (get table key [default])

-value_t fl_hash_get(value_t *args, u_int32_t nargs)

+value_t fl_table_get(value_t *args, uint32_t nargs)

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

-    return NIL;

+    if (nargs != 3)

+        argcount("get", nargs, 2);

+    fltable_t *pt = totable(args[0], "get");

+    value_t v = (value_t)equalhash_get(&pt->ht, (void*)args[1]);

+    if (v == (value_t)HT_NOTFOUND) {

+        if (nargs == 3)

+            return args[2];

+        lerror(KeyError, "get: key not found");

+    }

+    return v;

 // (has table key)

-value_t fl_hash_has(value_t *args, u_int32_t nargs)

+value_t fl_table_has(value_t *args, uint32_t nargs)

     argcount("has", nargs, 2);

-    return NIL;

+    fltable_t *pt = totable(args[0], "has");

+    return equalhash_has(&pt->ht, (void*)args[1]) ? T : NIL;

 // (del table key)

-value_t fl_hash_delete(value_t *args, u_int32_t nargs)

+value_t fl_table_del(value_t *args, uint32_t nargs)

     argcount("del", nargs, 2);

-    return NIL;

+    fltable_t *pt = totable(args[0], "del");

+    if (!equalhash_remove(&pt->ht, (void*)args[1]))

+        lerror(KeyError, "del: key not found");

+    return args[0];

+value_t fl_table_foldl(value_t *args, uint32_t nargs)

+{

+    argcount("table.foldl", nargs, 3);

+    PUSH(listn(3, NIL, NIL, NIL));

+    fltable_t *pt = totable(args[2], "table.foldl");

+    size_t i, n = pt->ht.size;

+    void **table = pt->ht.table;

+    value_t c;

+    for(i=0; i < n; i+=2) {

+        if (table[i+1] != HT_NOTFOUND) {

+            c = Stack[SP-1];

+            car_(c) = (value_t)table[i];

+            car_(cdr_(c)) = (value_t)table[i+1];

+            car_(cdr_(cdr_(c))) = args[1];

+            args[1] = apply(args[0], c);

+            // reload pointer

+            table = ((fltable_t*)cv_data((cvalue_t*)ptr(args[2])))->ht.table;

+        }

+    }

+    (void)POP();

+    return args[1];

+}

 static builtinspec_t tablefunc_info[] = {

     { "table", fl_table },

+    { "put", fl_table_put },

+    { "get", fl_table_get },

+    { "has", fl_table_has },

+    { "del", fl_table_del },

+    { "table.foldl", fl_table_foldl },

     { NULL, NULL }

};

@@ -158,6 +187,6 @@

     tablesym = symbol("table");

     tabletype = define_opaque_type(tablesym, sizeof(fltable_t),

-                                   &h_r2_vtable, NULL);

+                                   &table_vtable, NULL);

     assign_global_builtins(tablefunc_info);

--- a/femtolisp/todo

+++ b/femtolisp/todo

@@ -926,6 +926,7 @@

 - use the unused tag for TAG_PRIM, add smaller prim representation

 * finalizers in gc

 - hashtable

+  - special representation for small tables w/o finalizer

 - expose io stream object

 - enable print-shared for cvalues' types

--- a/llt/htable.inc

+++ b/llt/htable.inc

@@ -126,11 +126,14 @@

     return (HTNAME##_get(h,key) != HT_NOTFOUND);                        \

 }                                                                       \

-void HTNAME##_remove(htable_t *h, void *key)                            \

+int HTNAME##_remove(htable_t *h, void *key)                             \

 {                                                                       \

     void **bp = HTNAME##_peek_bp(h, key);                               \

-    if (bp != NULL)                                                     \

+    if (bp != NULL) {                                                   \

         *bp = HT_NOTFOUND;                                              \

+        return 1;                                                       \

+    }                                                                   \

+    return 0;                                                           \

 }                                                                       \

 void HTNAME##_adjoin(htable_t *h, void *key, void *val)                 \

--- a/llt/htableh.inc

+++ b/llt/htableh.inc

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

 void HTNAME##_put(htable_t *h, void *key, void *val);           \

 void HTNAME##_adjoin(htable_t *h, void *key, void *val);        \

 int HTNAME##_has(htable_t *h, void *key);                       \

-void HTNAME##_remove(htable_t *h, void *key);                   \

+int HTNAME##_remove(htable_t *h, void *key);                    \

 void **HTNAME##_bp(htable_t *h, void *key);

 // return value, or HT_NOTFOUND if key not found