diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 4b18502..97ab4b1 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -43,14 +43,15 @@ static size_t cv_nwords(cvalue_t *cv) { if (cv->flags.prim) { if (cv->flags.inlined) - return 2 + NWORDS(cv->flags.inllen); - return 3; + return CPRIM_NWORDS_INL + NWORDS(cv->flags.inllen); + return CPRIM_NWORDS; } if (cv->flags.inlined) { - size_t s = 3 + NWORDS(cv->flags.inllen + cv->flags.cstring); - return (s < 5) ? 5 : s; + size_t s = CVALUE_NWORDS_INL + + NWORDS(cv->flags.inllen + cv->flags.cstring); + return (s < CVALUE_NWORDS) ? CVALUE_NWORDS : s; } - return 5; + return CVALUE_NWORDS; } void *cv_data(cvalue_t *cv) @@ -84,7 +85,7 @@ value_t cvalue(value_t type, size_t sz) if (issymbol(type)) { cprim_t *pcp; - pcp = (cprim_t*)alloc_words(2 + NWORDS(sz)); + pcp = (cprim_t*)alloc_words(CPRIM_NWORDS_INL + NWORDS(sz)); pcp->flagbits = INITIAL_FLAGS; pcp->flags.inllen = sz; pcp->flags.inlined = 1; @@ -94,14 +95,14 @@ value_t cvalue(value_t type, size_t sz) } PUSH(type); if (sz <= MAX_INL_SIZE) { - size_t nw = 3 + NWORDS(sz); - pcv = (cvalue_t*)alloc_words((nw < 5) ? 5 : nw); + size_t nw = CVALUE_NWORDS_INL + NWORDS(sz); + pcv = (cvalue_t*)alloc_words((nw < CVALUE_NWORDS) ? CVALUE_NWORDS : nw); pcv->flagbits = INITIAL_FLAGS; pcv->flags.inllen = sz; pcv->flags.inlined = 1; } else { - pcv = (cvalue_t*)alloc_words(5); + pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS); pcv->flagbits = INITIAL_FLAGS; pcv->flags.inlined = 0; pcv->data = malloc(sz); @@ -138,7 +139,7 @@ value_t cvalue_from_ref(value_t type, void *ptr, size_t sz, value_t parent) PUSH(parent); PUSH(type); - pcv = (cvalue_t*)alloc_words(5); + pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS); pcv->flagbits = INITIAL_FLAGS; pcv->flags.inlined = 0; pcv->data = ptr; diff --git a/femtolisp/equal.c b/femtolisp/equal.c index a31c722..a2f64f2 100644 --- a/femtolisp/equal.c +++ b/femtolisp/equal.c @@ -247,6 +247,8 @@ value_t compare(value_t a, value_t b) value_t equal(value_t a, value_t b) { + if (eq_comparable(a, b)) + return (a == b) ? T : NIL; return (numval(compare(a,b))==0 ? T : NIL); } diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 769eb72..13834e1 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -58,12 +58,12 @@ static char *builtin_names[] = { "quote", "cond", "if", "and", "or", "while", "lambda", - "trycatch", "%apply", "progn", + "trycatch", "%apply", "setq", "progn", "eq", "atom", "not", "symbolp", "numberp", "boundp", "consp", "builtinp", "vectorp", "fixnump", "equal", "cons", "car", "cdr", "rplaca", "rplacd", - "eval", "apply", "set", "prog1", "raise", + "eval", "eval*", "apply", "prog1", "raise", "+", "-", "*", "/", "<", "~", "&", "!", "$", "vector", "aref", "aset", "length", "assoc", "compare", "for" }; @@ -700,6 +700,33 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) lerror(ArgError, "quote: expected argument"); v = car_(Stack[saveSP]); break; + case F_SETQ: + e = car(Stack[saveSP]); + v = eval(car(cdr_(Stack[saveSP]))); + pv = &Stack[penv]; + while (1) { + f = *pv++; + while (iscons(f)) { + if (car_(f)==e) { + *pv = v; + SP = saveSP; + return v; + } + f = cdr_(f); pv++; + } + if (f == e) { + *pv = v; + SP = saveSP; + return v; + } + if (f != NIL) pv++; + if (*pv == NIL) break; + pv = &vector_elt(*pv, 0); + } + sym = tosymbol(e, "setq"); + if (sym->syntax != TAG_CONST) + sym->binding = v; + break; case F_LAMBDA: // build a closure (lambda args body . env) if (Stack[penv] != NIL) { @@ -813,34 +840,6 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; // ordinary functions - case F_SET: - argcount("set", nargs, 2); - e = Stack[SP-2]; - pv = &Stack[penv]; - while (1) { - v = *pv++; - while (iscons(v)) { - if (car_(v)==e) { - *pv = Stack[SP-1]; - SP=saveSP; - return *pv; - } - v = cdr_(v); pv++; - } - if (v == e) { - *pv = Stack[SP-1]; - SP=saveSP; - return *pv; - } - if (v != NIL) pv++; - if (*pv == NIL) break; - pv = &vector_elt(*pv, 0); - } - sym = tosymbol(e, "set"); - v = Stack[SP-1]; - if (sym->syntax != TAG_CONST) - sym->binding = v; - break; case F_BOUNDP: argcount("boundp", nargs, 1); sym = tosymbol(Stack[SP-1], "boundp"); @@ -1119,6 +1118,13 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) v = eval_sexpr(v, SP-2, 1); } break; + case F_EVALSTAR: + argcount("eval*", nargs, 1); + e = Stack[SP-1]; + if (selfevaluating(e)) { SP=saveSP; return e; } + SP = penv+2; + goto eval_top; + break; case F_RAISE: argcount("raise", nargs, 1); raise(Stack[SP-1]); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 8b3fe8c..866afb7 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -58,9 +58,10 @@ typedef struct _symbol_t { #define isbuiltinish(x) (tag(x) == TAG_BUILTIN) #define isvector(x) (tag(x) == TAG_VECTOR) #define iscvalue(x) (tag(x) == TAG_CVALUE) -#define selfevaluating(x) (tag(x)<0x6) +#define selfevaluating(x) (tag(x)<6) // comparable with == -#define eq_comparable(a,b) (!(((a)|(b))&0x1)) +#define eq_comparable(a,b) (!(((a)|(b))&1)) +#define eq_comparablep(a) (!((a)&1)) // doesn't lead to other values #define leafp(a) (((a)&3) != 3) @@ -80,6 +81,7 @@ typedef struct _symbol_t { #define symbol_value(s) (((symbol_t*)ptr(s))->binding) #define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \ (((unsigned char*)ptr(v)) < fromspace+heapsize)) +#define isgensym(x) (issymbol(x) && ismanaged(x)) extern value_t Stack[]; extern u_int32_t SP; @@ -90,12 +92,12 @@ extern u_int32_t SP; enum { // special forms F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, - F_TRYCATCH, F_SPECIAL_APPLY, F_PROGN, + F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROGN, // functions F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP, F_BUILTINP, F_VECTORP, F_FIXNUMP, F_EQUAL, F_CONS, F_CAR, F_CDR, F_RPLACA, F_RPLACD, - F_EVAL, F_APPLY, F_SET, F_PROG1, F_RAISE, + F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSOC, F_COMPARE, F_FOR, N_BUILTINS @@ -175,6 +177,13 @@ typedef struct { # endif #endif +typedef struct { + void (*print)(ios_t *f, value_t v, int princ); + void (*relocate)(value_t old, value_t new); + void (*finalize)(value_t self); + void (*print_traverse)(value_t self); +} cvtable_t; + typedef struct { union { cvflags_t flags; @@ -182,12 +191,15 @@ typedef struct { }; value_t type; value_t deps; + //cvtable_t *vtable; // fields below are absent in inline-allocated values void *data; size_t len; // length of *data in bytes - //cvtable_t *vtable; } cvalue_t; +#define CVALUE_NWORDS 5 +#define CVALUE_NWORDS_INL 3 + typedef struct { union { cvflags_t flags; @@ -197,6 +209,9 @@ typedef struct { void *data; } cprim_t; +#define CPRIM_NWORDS 3 +#define CPRIM_NWORDS_INL 2 + #define cv_len(c) ((c)->flags.inlined ? (c)->flags.inllen : (c)->len) #define cv_type(c) ((c)->type) #define cv_numtype(c) ((c)->flags.numtype) diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index b97d53c..fd6537d 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -2,10 +2,7 @@ ; by Jeff Bezanson (C) 2008 ; Distributed under the BSD License -(set 'list (lambda args args)) - -(set-syntax 'setq (lambda (name val) - (list set (list 'quote name) val))) +(setq list (lambda args args)) ; convert a sequence of body statements to a single expression. ; this allows define, defun, defmacro, let, etc. to contain multiple @@ -32,6 +29,8 @@ (list 'setq name (car body)) (cons 'defun (cons (car name) (cons (cdr name) body))))) +(defun set (s v) (eval (list 'setq s (list 'quote v)))) + (defun identity (x) x) (setq null not) @@ -50,7 +49,7 @@ ((null (cdr lsts)) (car lsts)) (T ((lambda (l d) (if (null l) d (prog1 l - (while (consp (cdr l)) (set 'l (cdr l))) + (while (consp (cdr l)) (setq l (cdr l))) (rplacd l d)))) (car lsts) (apply nconc (cdr lsts)))))) @@ -98,8 +97,8 @@ (progn (while (and (consp e) (not (member (car e) env)) - (set 'f (macrocallp e))) - (set 'e (apply f (cdr e)))) + (setq f (macrocallp e))) + (setq e (apply f (cdr e)))) (cond ((and (consp e) (not (eq (car e) 'quote))) (let ((newenv @@ -199,7 +198,7 @@ (prog1 lst (while (consp lst) (rplaca lst (f (car lst))) - (set 'lst (cdr lst))))) + (setq lst (cdr lst))))) (defun mapcar (f . lsts) ((label mapcar- @@ -243,9 +242,9 @@ (define (nreverse l) (let ((prev nil)) (while (consp l) - (set 'l (prog1 (cdr l) + (setq l (prog1 (cdr l) (rplacd l (prog1 prev - (set 'prev l)))))) + (setq prev l)))))) prev)) (defmacro let* (binds . body) diff --git a/femtolisp/table.c b/femtolisp/table.c new file mode 100644 index 0000000..457ffcb --- /dev/null +++ b/femtolisp/table.c @@ -0,0 +1,100 @@ +#include +#include +#include +#include +#include +#include +#include "llt.h" +#include "flisp.h" + +/* + 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); + void **(*bp)(void *t, void *key); +} table_interface_t; + +typedef struct { + table_interface_t *ti; + ulong_t nkeys; + ptrhash_t ht; +} fltable_t; + +void print_htable(ios_t *f, value_t h, int princ) +{ +} + +void free_htable(value_t self) +{ + fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(self)); + ptrhash_free(&pt->ht); +} + +void relocate_htable(value_t old, value_t new) +{ + fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(self)); + ptrhash_t *h = &pt->ht; + size_t i; + for(i=0; i < h->size; i++) { + if (h->table[i] != PH_NOTFOUND) + h->table[i] = (void*)relocate((value_t)h->table[i]); + } +} + +void rehash_htable(value_t old, value_t new) +{ +} + +cvtable_t h_r1_vtable = { print_htable, NULL, free_htable }; +cvtable_t h_r2_vtable = { print_htable, relocate_htable, free_htable }; +cvtable_t h_r3_vtable = { print_htable, rehash_htable, free_htable }; + +int ishashtable(value_t v) +{ + return 0; +} + +value_t fl_table(value_t *args, u_int32_t nargs) +{ +} + +value_t fl_hashtablep(value_t *args, u_int32_t nargs) +{ + return NIL; +} + +value_t fl_hash_put(value_t *args, u_int32_t nargs) +{ + return NIL; +} + +value_t fl_hash_get(value_t *args, u_int32_t nargs) +{ + return NIL; +} + +value_t fl_hash_has(value_t *args, u_int32_t nargs) +{ + return NIL; +} + +value_t fl_hash_delete(value_t *args, u_int32_t nargs) +{ + return NIL; +} diff --git a/femtolisp/test.lsp b/femtolisp/test.lsp index d18d753..727723a 100644 --- a/femtolisp/test.lsp +++ b/femtolisp/test.lsp @@ -3,7 +3,7 @@ ; (list list ''labl (list 'quote name) f)) (defmacro labl (name f) - `(let (,name) (set ',name ,f))) + `(let (,name) (setq ,name ,f))) ;(define (reverse lst) ; ((label rev-help (lambda (lst result) @@ -204,3 +204,28 @@ ;(tt) ;(tt) ;(tt) + +(defmacro delay (expr) + (let ((g (gensym))) + `(let ((,g ',g)) + (lambda () (if (eq ,g ',g) (setq ,g ,expr) ,g))))) + +(defmacro accumulate-while (cnd what . body) + (let ((first (gensym)) + (acc (gensym)) + (forms (f-body body))) + `(let ((,first (prog1 (cons ,what nil) ,forms)) + (,acc nil)) + (setq ,acc ,first) + (while ,cnd + (progn (rplacd ,acc (cons ,what nil)) + (setq ,acc (cdr ,acc)) + ,forms)) + ,first))) + +(defun map-indexed (f lst) + (if (atom lst) lst + (let ((i 0)) + (accumulate-while (consp lst) (f (car lst) i) + (setq lst (cdr lst)) + (setq i (1+ i)))))) diff --git a/femtolisp/wt.lsp b/femtolisp/wt.lsp index 7a23867..0f0875a 100644 --- a/femtolisp/wt.lsp +++ b/femtolisp/wt.lsp @@ -5,4 +5,4 @@ (progn ,@forms (-loop-)) nil))))) -(while (< i 10000000) (set 'i (+ i 1))) +(while (< i 10000000) (setq i (+ i 1)))