From 6f934a817b7347109eb189f29c01cb48246c0b02 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Sat, 6 Sep 2008 22:19:51 +0000 Subject: [PATCH] I decided it was rather random that set was the only function that could access the current environment dynamically. It also differed unnecessarily from common lisp set in this respect. So now setq is a builtin special form that sets lexical or global variables, and set is a function that sets global variables. Rather than eliminate the power of the dynamic set, I extended it by adding eval*, which evaluates its argument in the current environment. The justification for this is that the interpreter is already dynamic enough to allow it with no overhead, so the ability might as well be exposed. cleanup; removing some magic numbers beginning hash tables --- femtolisp/cvalues.c | 21 ++++----- femtolisp/equal.c | 2 + femtolisp/flisp.c | 66 +++++++++++++++------------- femtolisp/flisp.h | 25 ++++++++--- femtolisp/system.lsp | 19 ++++---- femtolisp/table.c | 100 +++++++++++++++++++++++++++++++++++++++++++ femtolisp/test.lsp | 27 +++++++++++- femtolisp/wt.lsp | 2 +- 8 files changed, 205 insertions(+), 57 deletions(-) create mode 100644 femtolisp/table.c 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)))