diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index eb2c0ca..086918d 100644 --- a/femtolisp/cvalues.c +++ b/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("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*"); diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index cdd0213..190c4db 100644 --- a/femtolisp/flisp.c +++ b/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 - 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 @@ 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("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)); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 2680e23..b41318a 100644 --- a/femtolisp/flisp.h +++ b/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); diff --git a/femtolisp/print.c b/femtolisp/print.c index 71a522c..0ca5cfc 100644 --- a/femtolisp/print.c +++ b/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, "#", + (unsigned long)(builtin_t)ptr(v)); + } + else { + HPOS += ios_printf(f, "#builtin(%s)", symbol_name(label)); + } break; case TAG_CVALUE: case TAG_VECTOR: diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 5cc5b41..b653ead 100644 --- 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)) diff --git a/femtolisp/table.c b/femtolisp/table.c index 5a16994..7a9fce1 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -6,27 +6,11 @@ #include #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) -{ - 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 }; +cvtable_t table_vtable = { print_htable, relocate_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 @@ 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); } diff --git a/femtolisp/todo b/femtolisp/todo index 3bdd01a..513a977 100644 --- a/femtolisp/todo +++ b/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 diff --git a/llt/htable.inc b/llt/htable.inc index 13aecac..5c9a44a 100644 --- a/llt/htable.inc +++ b/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) \ diff --git a/llt/htableh.inc b/llt/htableh.inc index b2d12ba..deef1d2 100644 --- a/llt/htableh.inc +++ b/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