making all builtins print readably; (builtin 'sym) function
hash table functions: adding get,put,has,del,table.foldl,table.pairs,table.keys,table.values
This commit is contained in:
JeffBezanson
parent
b5dda68eab
commit
dfacb4d897
|
|
@ -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*");
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) \
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue