making all builtins print readably; (builtin 'sym) function

hash table functions:
adding get,put,has,del,table.foldl,table.pairs,table.keys,table.values

femtolisp/cvalues.c

@@ -18,6 +18,7 @@ value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
 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 @@ value_t cvalue_set_int8(value_t *args, u_int32_t nargs)
     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,16 +830,19 @@ value_t cbuiltin(builtin_t f)
     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();
 
 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 @@ void cvalues_init()
     cv_intern(union);
     cv_intern(void);
 
-    set(symbol("c-value"), cbuiltin(cvalue_new));
+    set(symbol("c-value"), cbuiltin("c-value", cvalue_new));
-    set(symbol("get-int8"), cbuiltin(cvalue_get_int8));
+    set(symbol("get-int8"), cbuiltin("get-int8", cvalue_get_int8));
-    set(symbol("set-int8"), cbuiltin(cvalue_set_int8));
+    set(symbol("set-int8"), cbuiltin("set-int8", cvalue_set_int8));
-    set(symbol("typeof"), cbuiltin(cvalue_typeof));
+    set(symbol("typeof"), cbuiltin("typeof", cvalue_typeof));
-    set(symbol("sizeof"), cbuiltin(cvalue_sizeof));
+    set(symbol("sizeof"), cbuiltin("sizeof", cvalue_sizeof));
+    set(symbol("builtin"), cbuiltin("builtin", fl_builtin));
     // todo: autorelease
 
     stringtypesym = symbol("*string-type*");

femtolisp/flisp.c

@@ -69,7 +69,7 @@ uint32_t SP = 0;
 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 @@ value_t alloc_vector(size_t n, int init)
     return v;
 }
 
+// cvalues --------------------------------------------------------------------
+
+#include "cvalues.c"
+#include "types.c"
+
 // print ----------------------------------------------------------------------
 
 static int isnumtok(char *tok, value_t *pval);
@@ -342,11 +347,6 @@ static int symchar(char c);
 
 #include "print.c"
 
-// cvalues --------------------------------------------------------------------
-
-#include "cvalues.c"
-#include "types.c"
-
 // collector ------------------------------------------------------------------
 
 static value_t relocate(value_t v)
@@ -1193,9 +1193,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
             noeval = 1;
             goto apply_lambda;
         default:
-            // a guest function is a cvalue tagged as a builtin
+            // function pointer tagged as a builtin
-            cv = (cvalue_t*)ptr(f);
+            v = ((builtin_t)ptr(f))(&Stack[saveSP+1], nargs);
-            v = ((builtin_t)cv->data)(&Stack[saveSP+1], nargs);
         }
         SP = saveSP;
         return v;
@@ -1317,7 +1316,7 @@ static char *EXEDIR;
 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 @@ void lisp_init(void)
     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 @@ void lisp_init(void)
 #endif
 
     cvalues_init();
-    set(symbol("gensym"), cbuiltin(gensym));
+    set(symbol("gensym"), cbuiltin("gensym", gensym));
-    set(symbol("hash"), cbuiltin(fl_hash));
+    set(symbol("hash"), cbuiltin("hash", fl_hash));
 
     char buf[1024];
     char *exename = get_exename(buf, sizeof(buf));

femtolisp/flisp.h

@@ -148,7 +148,7 @@ void lerror(value_t e, char *format, ...) __attribute__ ((__noreturn__));
 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 @@ 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);
 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);

femtolisp/print.c

@@ -332,7 +332,14 @@ void fl_print_child(ios_t *f, value_t v, int princ)
             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:

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
+;(setq *special-forms* '(quote cond if and or while lambda label trycatch
-                        %top progn))
+;                        %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))

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 @@ void print_htable(value_t v, ios_t *f, int princ)
     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 free_htable(value_t self)
 
 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 relocate_htable(value_t oldv, value_t newv)
     }
 }
 
-void print_traverse_htable(value_t self)
+cvtable_t table_vtable = { print_htable, relocate_htable, free_htable,
-{
+                           print_traverse_htable };
-    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]);
-    }
-}
-
-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);
+    if (nargs != 3)
-    return NIL;
+        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 @@ void table_init()
 {
     tablesym = symbol("table");
     tabletype = define_opaque_type(tablesym, sizeof(fltable_t),
-                                   &h_r2_vtable, NULL);
+                                   &table_vtable, NULL);
     assign_global_builtins(tablefunc_info);
 }

femtolisp/todo

@@ -926,6 +926,7 @@ consolidated todo list as of 8/30:
 - 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

llt/htable.inc

@@ -126,11 +126,14 @@ int HTNAME##_has(htable_t *h, void *key)                                \
     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)                 \

llt/htableh.inc

@@ -7,7 +7,7 @@ void *HTNAME##_get(htable_t *h, void *key);                     \
 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