From 83340390909d7f4572e33b3442535bc47b12eb30 Mon Sep 17 00:00:00 2001 From: Jeff Bezanson Date: Tue, 11 Jun 2013 17:31:51 -0400 Subject: [PATCH] remove and clean up some old files --- FLOSSING | 13 - attic/flutils.c | 59 -- attic/plists.lsp | 28 - {tiny => attic}/scrap.c | 0 attic/system-old.lsp | 25 - attic/trash.c | 303 ------- {attic => examples}/dict.lsp | 0 tiny/lisp2.c.bak | 1448 ---------------------------------- 8 files changed, 1876 deletions(-) delete mode 100644 FLOSSING delete mode 100644 attic/flutils.c delete mode 100644 attic/plists.lsp rename {tiny => attic}/scrap.c (100%) delete mode 100644 attic/system-old.lsp delete mode 100644 attic/trash.c rename {attic => examples}/dict.lsp (100%) delete mode 100644 tiny/lisp2.c.bak diff --git a/FLOSSING b/FLOSSING deleted file mode 100644 index fa208ac..0000000 --- a/FLOSSING +++ /dev/null @@ -1,13 +0,0 @@ -Flossing is important to overall oral health. - -Even by itself, flossing does a good job of cleaning teeth and gums, -and is the only way to clean below the gumline. - -However it has an important secondary purpose as well. Most people assume -the point of brushing teeth is to scrub the teeth with bristles. This -is not fully true; the more significant purpose of brushing is to apply -fluoride to teeth. If you don't floss, food particles are left between -the teeth and gums, blocking fluoride from reaching tooth surfaces. It -is then as if you were not brushing at all. Even if no material is -visible between teeth, there is probably some there. Flossing can pull -a surprising amount of gunk from a mouth that appears totally clean. diff --git a/attic/flutils.c b/attic/flutils.c deleted file mode 100644 index 2b31a9f..0000000 --- a/attic/flutils.c +++ /dev/null @@ -1,59 +0,0 @@ -typedef struct { - size_t n, maxsize; - unsigned long *items; -} ltable_t; - -void ltable_init(ltable_t *t, size_t n) -{ - t->n = 0; - t->maxsize = n; - t->items = (unsigned long*)malloc(n * sizeof(unsigned long)); -} - -void ltable_clear(ltable_t *t) -{ - t->n = 0; -} - -void ltable_insert(ltable_t *t, unsigned long item) -{ - unsigned long *p; - - if (t->n == t->maxsize) { - p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long)); - if (p == NULL) return; - t->items = p; - t->maxsize *= 2; - } - t->items[t->n++] = item; -} - -#define LT_NOTFOUND ((int)-1) - -int ltable_lookup(ltable_t *t, unsigned long item) -{ - int i; - for(i=0; i < (int)t->n; i++) - if (t->items[i] == item) - return i; - return LT_NOTFOUND; -} - -void ltable_adjoin(ltable_t *t, unsigned long item) -{ - if (ltable_lookup(t, item) == LT_NOTFOUND) - ltable_insert(t, item); -} - -char *snprintf_gensym_id(char *nbuf, size_t n, u_int32_t g) -{ - size_t i=n-1; - - nbuf[i--] = '\0'; - do { - nbuf[i--] = '0' + g%10; - g/=10; - } while (g && i); - nbuf[i] = 'g'; - return &nbuf[i]; -} diff --git a/attic/plists.lsp b/attic/plists.lsp deleted file mode 100644 index 20cb77d..0000000 --- a/attic/plists.lsp +++ /dev/null @@ -1,28 +0,0 @@ -; property lists. they really suck. -(setq *plists* nil) - -(defun symbol-plist (sym) - (cdr (or (assoc sym *plists*) '(())))) - -(defun set-symbol-plist (sym lst) - (let ((p (assoc sym *plists*))) - (if (null p) ; sym has no plist yet - (setq *plists* (cons (cons sym lst) *plists*)) - (rplacd p lst)))) - -(defun get (sym prop) - (let ((pl (symbol-plist sym))) - (if pl - (let ((pr (member prop pl))) - (if pr (cadr pr) nil)) - nil))) - -(defun put (sym prop val) - (let ((p (assoc sym *plists*))) - (if (null p) ; sym has no plist yet - (setq *plists* (cons (list sym prop val) *plists*)) - (let ((pr (member prop p))) - (if (null pr) ; sym doesn't have this property yet - (rplacd p (cons prop (cons val (cdr p)))) - (rplaca (cdr pr) val))))) - val) diff --git a/tiny/scrap.c b/attic/scrap.c similarity index 100% rename from tiny/scrap.c rename to attic/scrap.c diff --git a/attic/system-old.lsp b/attic/system-old.lsp deleted file mode 100644 index 30ca679..0000000 --- a/attic/system-old.lsp +++ /dev/null @@ -1,25 +0,0 @@ -(define (equal a b) - (if (and (consp a) (consp b)) - (and (equal (car a) (car b)) - (equal (cdr a) (cdr b))) - (eq a b))) - -; compare imposes an ordering on all values. yields -1 for ab. lists are compared up to the first -; point of difference. -(defun compare (a b) - (cond ((eq a b) 0) - ((or (atom a) (atom b)) (if (< a b) -1 1)) - (T (let ((c (compare (car a) (car b)))) - (if (not (eq c 0)) - c - (compare (cdr a) (cdr b))))))) - -(defun length (l) - (if (null l) 0 - (+ 1 (length (cdr l))))) - -(define (assoc item lst) - (cond ((atom lst) ()) - ((eq (caar lst) item) (car lst)) - (T (assoc item (cdr lst))))) diff --git a/attic/trash.c b/attic/trash.c deleted file mode 100644 index 7d0e8c2..0000000 --- a/attic/trash.c +++ /dev/null @@ -1,303 +0,0 @@ -value_t prim_types[32]; -value_t *prim_sym_addrs[] = { - &int8sym, &uint8sym, &int16sym, &uint16sym, &int32sym, &uint32sym, - &int64sym, &uint64sym, &charsym, &ucharsym, &shortsym, &ushortsym, - &intsym, &uintsym, &longsym, &ulongsym, - &lispvaluesym }; -#define N_PRIMSYMS (sizeof(prim_sym_addrs) / sizeof(value_t*)) - -static value_t cv_type(cvalue_t *cv) -{ - if (cv->flags.prim) { - return prim_types[cv->flags.primtype]; - } - return cv->type; -} - - - double t0,t1; - int i; - int32_t i32; - char s8; - ulong_t c8=3; - t0 = clock(); //0.058125017 - set_secret_symtag(ulongsym,TAG_UINT32); - set_secret_symtag(int8sym,TAG_INT8); - for(i=0; i < 8000000; i++) { - cnvt_to_int32(&i32, &s8, int8sym); - c8+=c8; - s8+=s8; - } - t1 = clock(); - printf("%d. that took %.16f\n", i32, t1-t0); - - -#define int_converter(type) \ -static int cnvt_to_##type(type##_t *i, void *data, value_t type) \ -{ \ - if (type==int32sym) *i = *(int32_t*)data; \ - else if (type==charsym) *i = *(char*)data; \ - else if (type==ulongsym) *i = *(ulong*)data; \ - else if (type==uint32sym) *i = *(uint32_t*)data; \ - else if (type==int8sym) *i = *(int8_t*)data; \ - else if (type==uint8sym) *i = *(uint8_t*)data; \ - else if (type==int64sym) *i = *(int64_t*)data; \ - else if (type==uint64sym) *i = *(uint64_t*)data; \ - else if (type==wcharsym) *i = *(wchar_t*)data; \ - else if (type==longsym) *i = *(long*)data; \ - else if (type==int16sym) *i = *(int16_t*)data; \ - else if (type==uint16sym) *i = *(uint16_t*)data; \ - else \ - return 1; \ - return 0; \ -} -int_converter(int32) -int_converter(uint32) -int_converter(int64) -int_converter(uint64) - -#ifdef BITS64 -#define cnvt_to_ulong(i,d,t) cnvt_to_uint64(i,d,t) -#else -#define cnvt_to_ulong(i,d,t) cnvt_to_uint32(i,d,t) -#endif - -long intabs(long n) -{ - long s = n>>(NBITS-1); // either -1 or 0 - return (n^s) - s; -} - -value_t fl_inv(value_t b) -{ - int_t bi; - int tb; - void *bptr=NULL; - cvalue_t *cv; - - if (isfixnum(b)) { - bi = numval(b); - if (bi == 0) - goto inv_error; - else if (bi == 1) - return fixnum(1); - else if (bi == -1) - return fixnum(-1); - return fixnum(0); - } - else if (iscvalue(b)) { - cv = (cvalue_t*)ptr(b); - tb = cv_numtype(cv); - if (tb <= T_DOUBLE) - bptr = cv_data(cv); - } - if (bptr == NULL) - type_error("/", "number", b); - - if (tb == T_FLOAT) - return mk_double(1.0/(double)*(float*)bptr); - if (tb == T_DOUBLE) - return mk_double(1.0 / *(double*)bptr); - - if (tb == T_UINT64) { - if (*(uint64_t*)bptr > 1) - return fixnum(0); - else if (*(uint64_t*)bptr == 1) - return fixnum(1); - goto inv_error; - } - int64_t b64 = conv_to_int64(bptr, tb); - if (b64 == 0) goto inv_error; - else if (b64 == 1) return fixnum(1); - else if (b64 == -1) return fixnum(-1); - - return fixnum(0); - inv_error: - lerror(DivideError, "/: division by zero"); -} - -static void printstack(value_t *penv, uint32_t envsz) -{ - int i; - printf("env=%d, size=%d\n", penv - &Stack[0], envsz); - for(i=0; i < SP; i++) { - printf("%d: ", i); - print(stdout, Stack[i], 0); - printf("\n"); - } - printf("\n"); -} - -// unordered comparison -// not any faster than ordered comparison - -// a is a fixnum, b is a cvalue -static value_t equal_num_cvalue(value_t a, value_t b) -{ - cvalue_t *bcv = (cvalue_t*)ptr(b); - numerictype_t bt; - if (valid_numtype(bt=cv_numtype(bcv))) { - fixnum_t ia = numval(a); - void *bptr = cv_data(bcv); - if (cmp_eq(&ia, T_FIXNUM, bptr, bt)) - return fixnum(0); - } - return fixnum(1); -} - -static value_t bounded_equal(value_t a, value_t b, int bound); -static value_t cyc_equal(value_t a, value_t b, ptrhash_t *table); - -static value_t bounded_vector_equal(value_t a, value_t b, int bound) -{ - size_t la = vector_size(a); - size_t lb = vector_size(b); - if (la != lb) return fixnum(1); - size_t i; - for (i = 0; i < la; i++) { - value_t d = bounded_equal(vector_elt(a,i), vector_elt(b,i), bound-1); - if (d==NIL || numval(d)!=0) return d; - } - return fixnum(0); -} - -static value_t bounded_equal(value_t a, value_t b, int bound) -{ - value_t d; - - compare_top: - if (a == b) return fixnum(0); - if (bound <= 0) - return NIL; - int taga = tag(a); - int tagb = cmptag(b); - switch (taga) { - case TAG_NUM : - case TAG_NUM1: - if (isfixnum(b)) { - return fixnum(1); - } - if (iscvalue(b)) { - return equal_num_cvalue(a, b); - } - return fixnum(1); - case TAG_SYM: - return fixnum(1); - case TAG_VECTOR: - if (isvector(b)) - return bounded_vector_equal(a, b, bound); - break; - case TAG_CVALUE: - if (iscvalue(b)) { - cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b); - numerictype_t at, bt; - if (valid_numtype(at=cv_numtype(acv)) && - valid_numtype(bt=cv_numtype(bcv))) { - void *aptr = cv_data(acv); - void *bptr = cv_data(bcv); - if (cmp_eq(aptr, at, bptr, bt)) - return fixnum(0); - return fixnum(1); - } - return cvalue_compare(a, b); - } - else if (isfixnum(b)) { - return equal_num_cvalue(b, a); - } - break; - case TAG_BUILTIN: - return fixnum(1); - case TAG_CONS: - if (tagb != TAG_CONS) return fixnum(1); - d = bounded_equal(car_(a), car_(b), bound-1); - if (d==NIL || numval(d) != 0) return d; - a = cdr_(a); b = cdr_(b); - bound--; - goto compare_top; - } - return fixnum(1); -} - -static value_t cyc_vector_equal(value_t a, value_t b, ptrhash_t *table) -{ - size_t la = vector_size(a); - size_t lb = vector_size(b); - size_t i; - value_t d, xa, xb, ca, cb; - if (la != lb) return fixnum(1); - - // first try to prove them different with no recursion - for (i = 0; i < la; i++) { - xa = vector_elt(a,i); - xb = vector_elt(b,i); - if (leafp(xa) || leafp(xb)) { - d = bounded_equal(xa, xb, 1); - if (numval(d)!=0) return d; - } - else if (cmptag(xa) != cmptag(xb)) { - return fixnum(1); - } - } - - ca = eq_class(table, a); - cb = eq_class(table, b); - if (ca!=NIL && ca==cb) - return fixnum(0); - - eq_union(table, a, b, ca, cb); - - for (i = 0; i < la; i++) { - xa = vector_elt(a,i); - xb = vector_elt(b,i); - if (!leafp(xa) && !leafp(xb)) { - d = cyc_equal(xa, xb, table); - if (numval(d)!=0) return d; - } - } - - return fixnum(0); -} - -static value_t cyc_equal(value_t a, value_t b, ptrhash_t *table) -{ - if (a==b) - return fixnum(0); - if (iscons(a)) { - if (iscons(b)) { - value_t aa = car_(a); value_t da = cdr_(a); - value_t ab = car_(b); value_t db = cdr_(b); - int tagaa = cmptag(aa); int tagda = cmptag(da); - int tagab = cmptag(ab); int tagdb = cmptag(db); - value_t d, ca, cb; - if (leafp(aa) || leafp(ab)) { - d = bounded_equal(aa, ab, 1); - if (numval(d)!=0) return d; - } - else if (tagaa != tagab) - return fixnum(1); - if (leafp(da) || leafp(db)) { - d = bounded_equal(da, db, 1); - if (numval(d)!=0) return d; - } - else if (tagda != tagdb) - return fixnum(1); - - ca = eq_class(table, a); - cb = eq_class(table, b); - if (ca!=NIL && ca==cb) - return fixnum(0); - - eq_union(table, a, b, ca, cb); - d = cyc_equal(aa, ab, table); - if (numval(d)!=0) return d; - return cyc_equal(da, db, table); - } - else { - return fixnum(1); - } - } - else if (isvector(a) && isvector(b)) { - return cyc_vector_equal(a, b, table); - } - return bounded_equal(a, b, 1); -} diff --git a/attic/dict.lsp b/examples/dict.lsp similarity index 100% rename from attic/dict.lsp rename to examples/dict.lsp diff --git a/tiny/lisp2.c.bak b/tiny/lisp2.c.bak deleted file mode 100644 index 5342d2e..0000000 --- a/tiny/lisp2.c.bak +++ /dev/null @@ -1,1448 +0,0 @@ -/* - femtoLisp - - a minimal interpreter for a minimal lisp dialect - - this lisp dialect uses lexical scope and self-evaluating lambda. - it supports 30-bit integers, symbols, conses, and full macros. - it is case-sensitive. - it features a simple compacting copying garbage collector. - it uses a Scheme-style evaluation rule where any expression may appear in - head position as long as it evaluates to a function. - it uses Scheme-style varargs (dotted formal argument lists) - lambdas can have only 1 body expression; use (progn ...) for multiple - expressions. this is due to the closure representation - (lambda args body . env) - - This is a fork of femtoLisp with advanced reading and printing facilities: - * circular structure can be printed and read - * #. read macro for eval-when-read and correctly printing builtins - * read macros for backquote - * symbol character-escaping printer - - * new print algorithm - 1. traverse & tag all conses to be printed. when you encounter a cons - that is already tagged, add it to a table to give it a #n# index - 2. untag a cons when printing it. if cons is in the table, print - "#n=" before it in the car, " . #n=" in the cdr. if cons is in the - table but already untagged, print #n# in car or " . #n#" in the cdr. - * read macros for #n# and #n= using the same kind of table - * also need a table of read labels to translate from input indexes to - normalized indexes (0 for first label, 1 for next, etc.) - * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq" - - The value of this extra complexity, and what makes this fork worthy of - the femtoLisp brand, is that the interpreter is fully "closed" in the - sense that all representable values can be read and printed. - - by Jeff Bezanson - Public Domain -*/ - -#include -#include -#include -#include -#include -#include -#include - -typedef u_int32_t value_t; -typedef int32_t number_t; - -typedef struct { - value_t car; - value_t cdr; -} cons_t; - -typedef struct _symbol_t { - value_t binding; // global value binding - value_t constant; // constant binding (used only for builtins) - struct _symbol_t *left; - struct _symbol_t *right; - char name[1]; -} symbol_t; - -#define TAG_NUM 0x0 -#define TAG_BUILTIN 0x1 -#define TAG_SYM 0x2 -#define TAG_CONS 0x3 -#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer -#define tag(x) ((x)&0x3) -#define ptr(x) ((void*)((x)&(~(value_t)0x3))) -#define tagptr(p,t) (((value_t)(p)) | (t)) -#define number(x) ((value_t)((x)<<2)) -#define numval(x) (((number_t)(x))>>2) -#define intval(x) (((int)(x))>>2) -#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN) -#define iscons(x) (tag(x) == TAG_CONS) -#define issymbol(x) (tag(x) == TAG_SYM) -#define isnumber(x) (tag(x) == TAG_NUM) -#define isbuiltin(x) (tag(x) == TAG_BUILTIN) -// functions ending in _ are unsafe, faster versions -#define car_(v) (((cons_t*)ptr(v))->car) -#define cdr_(v) (((cons_t*)ptr(v))->cdr) -#define car(v) (tocons((v),"car")->car) -#define cdr(v) (tocons((v),"cdr")->cdr) -#define set(s, v) (((symbol_t*)ptr(s))->binding = (v)) -#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v)) - -enum { - // special forms - F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL, - F_PROGN, - // functions - F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT, - F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1, - F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP, - F_ASSOC, N_BUILTINS -}; -#define isspecial(v) (intval(v) <= (number_t)F_PROGN) - -static char *builtin_names[] = - { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label", - "progn", - "eq", "atom", "cons", "car", "cdr", "read", "eval", "print", - "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<", - "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ", - "consp", "assoc" }; - -static char *stack_bottom; -#define PROCESS_STACK_SIZE (2*1024*1024) -#define N_STACK 98304 -static value_t Stack[N_STACK]; -static u_int32_t SP = 0; -#define PUSH(v) (Stack[SP++] = (v)) -#define POP() (Stack[--SP]) -#define POPN(n) (SP-=(n)) - -value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; -value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; - -value_t read_sexpr(FILE *f); -void print(FILE *f, value_t v, int princ); -value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend); -value_t load_file(char *fname); -value_t toplevel_eval(value_t expr); - -#include "flutils.c" - -typedef struct _readstate_t { - ltable_t labels; - ltable_t exprs; - struct _readstate_t *prev; -} readstate_t; -static readstate_t *readstate = NULL; - -// error utilities ------------------------------------------------------------ - -jmp_buf toplevel; - -void lerror(char *format, ...) -{ - va_list args; - va_start(args, format); - - while (readstate) { - free(readstate->labels.items); - free(readstate->exprs.items); - readstate = readstate->prev; - } - - vfprintf(stderr, format, args); - va_end(args); - longjmp(toplevel, 1); -} - -void type_error(char *fname, char *expected, value_t got) -{ - fprintf(stderr, "%s: error: expected %s, got ", fname, expected); - print(stderr, got, 0); lerror("\n"); -} - -// safe cast operators -------------------------------------------------------- - -#define SAFECAST_OP(type,ctype,cnvt) \ -ctype to##type(value_t v, char *fname) \ -{ \ - if (is##type(v)) \ - return (ctype)cnvt(v); \ - type_error(fname, #type, v); \ - return (ctype)0; \ -} -SAFECAST_OP(cons, cons_t*, ptr) -SAFECAST_OP(symbol,symbol_t*,ptr) -SAFECAST_OP(number,number_t, numval) - -// symbol table --------------------------------------------------------------- - -static symbol_t *symtab = NULL; - -static symbol_t *mk_symbol(char *str) -{ - symbol_t *sym; - - sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str)); - sym->left = sym->right = NULL; - sym->constant = sym->binding = UNBOUND; - strcpy(&sym->name[0], str); - return sym; -} - -static symbol_t **symtab_lookup(symbol_t **ptree, char *str) -{ - int x; - - while(*ptree != NULL) { - x = strcmp(str, (*ptree)->name); - if (x == 0) - return ptree; - if (x < 0) - ptree = &(*ptree)->left; - else - ptree = &(*ptree)->right; - } - return ptree; -} - -value_t symbol(char *str) -{ - symbol_t **pnode; - - pnode = symtab_lookup(&symtab, str); - if (*pnode == NULL) - *pnode = mk_symbol(str); - return tagptr(*pnode, TAG_SYM); -} - -// initialization ------------------------------------------------------------- - -static unsigned char *fromspace; -static unsigned char *tospace; -static unsigned char *curheap; -static unsigned char *lim; -static u_int32_t heapsize = 128*1024;//bytes -static u_int32_t *consflags; -static ltable_t printconses; - -void lisp_init(void) -{ - int i; - - fromspace = malloc(heapsize); - tospace = malloc(heapsize); - curheap = fromspace; - lim = curheap+heapsize-sizeof(cons_t); - consflags = mk_bitvector(heapsize/sizeof(cons_t)); - - ltable_init(&printconses, 32); - - NIL = symbol("nil"); setc(NIL, NIL); - T = symbol("t"); setc(T, T); - LAMBDA = symbol("lambda"); - MACRO = symbol("macro"); - LABEL = symbol("label"); - QUOTE = symbol("quote"); - BACKQUOTE = symbol("backquote"); - COMMA = symbol("*comma*"); - COMMAAT = symbol("*comma-at*"); - COMMADOT = symbol("*comma-dot*"); - for (i=0; i < (int)N_BUILTINS; i++) - setc(symbol(builtin_names[i]), builtin(i)); -} - -// conses --------------------------------------------------------------------- - -void gc(int mustgrow); - -static value_t mk_cons(void) -{ - cons_t *c; - - if (curheap > lim) - gc(0); - c = (cons_t*)curheap; - curheap += sizeof(cons_t); - return tagptr(c, TAG_CONS); -} - -// allocate and link n consecutive conses -// warning: only cdrs are initialized -static value_t cons_reserve(int n) -{ - cons_t *c, *first; - - n--; - if ((cons_t*)curheap > ((cons_t*)lim)-n) { - gc(0); - while ((cons_t*)curheap > ((cons_t*)lim)-n) { - gc(1); - } - } - c = first = (cons_t*)curheap; - for(; n > 0; n--) { - c->cdr = tagptr(c+1, TAG_CONS); - c++; - } - c->cdr = NIL; - curheap = (unsigned char*)(c+1); - return tagptr(first, TAG_CONS); -} - -value_t *cons(value_t *pcar, value_t *pcdr) -{ - value_t c = mk_cons(); - car_(c) = *pcar; cdr_(c) = *pcdr; - PUSH(c); - return &Stack[SP-1]; -} - -#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace)) -#define ismarked(c) bitvector_get(consflags, cons_index(c)) -#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1) -#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0) - -// collector ------------------------------------------------------------------ - -static value_t relocate(value_t v) -{ - value_t a, d, nc, first, *pcdr; - - if (!iscons(v)) - return v; - // iterative implementation allows arbitrarily long cons chains - pcdr = &first; - do { - if ((a=car_(v)) == UNBOUND) { - *pcdr = cdr_(v); - return first; - } - *pcdr = nc = mk_cons(); - d = cdr_(v); - car_(v) = UNBOUND; cdr_(v) = nc; - car_(nc) = relocate(a); - pcdr = &cdr_(nc); - v = d; - } while (iscons(v)); - *pcdr = d; - - return first; -} - -static void trace_globals(symbol_t *root) -{ - while (root != NULL) { - root->binding = relocate(root->binding); - trace_globals(root->left); - root = root->right; - } -} - -void gc(int mustgrow) -{ - static int grew = 0; - unsigned char *temp; - u_int32_t i; - readstate_t *rs; - - curheap = tospace; - lim = curheap+heapsize-sizeof(cons_t); - - for (i=0; i < SP; i++) - Stack[i] = relocate(Stack[i]); - trace_globals(symtab); - rs = readstate; - while (rs) { - for(i=0; i < rs->exprs.n; i++) - rs->exprs.items[i] = relocate(rs->exprs.items[i]); - rs = rs->prev; - } -#ifdef VERBOSEGC - printf("gc found %d/%d live conses\n", - (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t)); -#endif - temp = tospace; - tospace = fromspace; - fromspace = temp; - - // if we're using > 80% of the space, resize tospace so we have - // more space to fill next time. if we grew tospace last time, - // grow the other half of the heap this time to catch up. - if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) { - temp = realloc(tospace, grew ? heapsize : heapsize*2); - if (temp == NULL) - lerror("out of memory\n"); - tospace = temp; - if (!grew) { - heapsize*=2; - } - else { - temp = (char*)bitvector_resize(consflags, heapsize/sizeof(cons_t)); - if (temp == NULL) - lerror("out of memory\n"); - consflags = (u_int32_t*)temp; - } - grew = !grew; - } - if (curheap > lim) // all data was live - gc(0); -} - -// read ----------------------------------------------------------------------- - -enum { - TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM, - TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT, - TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE -}; - -static int symchar(char c) -{ - static char *special = "()';`,\\|"; - return (!isspace(c) && !strchr(special, c)); -} - -static u_int32_t toktype = TOK_NONE; -static value_t tokval; -static char buf[256]; - -static char nextchar(FILE *f) -{ - char c; - int ch; - - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - c = (char)ch; - if (c == ';') { - // single-line comment - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - } while ((char)ch != '\n'); - c = (char)ch; - } - } while (isspace(c)); - return c; -} - -static void take(void) -{ - toktype = TOK_NONE; -} - -static void accumchar(char c, int *pi) -{ - buf[(*pi)++] = c; - if (*pi >= (int)(sizeof(buf)-1)) - lerror("read: error: token too long\n"); -} - -// return: 1 for dot token, 0 for symbol -static int read_token(FILE *f, char c, int digits) -{ - int i=0, ch, escaped=0, dot=(c=='.'), totread=0; - - ungetc(c, f); - while (1) { - ch = fgetc(f); totread++; - if (ch == EOF) - goto terminate; - c = (char)ch; - if (c == '|') { - escaped = !escaped; - } - else if (c == '\\') { - ch = fgetc(f); - if (ch == EOF) - goto terminate; - accumchar((char)ch, &i); - } - else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) { - break; - } - else { - accumchar(c, &i); - } - } - ungetc(c, f); - terminate: - buf[i++] = '\0'; - return (dot && (totread==2)); -} - -static u_int32_t peek(FILE *f) -{ - char c, *end; - number_t x; - int ch; - - if (toktype != TOK_NONE) - return toktype; - c = nextchar(f); - if (feof(f)) return TOK_NONE; - if (c == '(') { - toktype = TOK_OPEN; - } - else if (c == ')') { - toktype = TOK_CLOSE; - } - else if (c == '\'') { - toktype = TOK_QUOTE; - } - else if (c == '`') { - toktype = TOK_BQ; - } - else if (c == '#') { - ch = fgetc(f); - if (ch == EOF) - lerror("read: error: invalid read macro\n"); - if ((char)ch == '.') { - toktype = TOK_SHARPDOT; - } - else if ((char)ch == '\'') { - toktype = TOK_SHARPQUOTE; - } - else if (isdigit((char)ch)) { - read_token(f, (char)ch, 1); - c = fgetc(f); - if (c == '#') - toktype = TOK_BACKREF; - else if (c == '=') - toktype = TOK_LABEL; - else - lerror("read: error: invalid label\n"); - x = strtol(buf, &end, 10); - tokval = number(x); - } - else { - lerror("read: error: unknown read macro\n"); - } - } - else if (c == ',') { - toktype = TOK_COMMA; - ch = fgetc(f); - if (ch == EOF) - return toktype; - if ((char)ch == '@') - toktype = TOK_COMMAAT; - else if ((char)ch == '.') - toktype = TOK_COMMADOT; - else - ungetc((char)ch, f); - } - else if (isdigit(c) || c=='-') { - read_token(f, c, 0); - if (buf[0] == '-' && !isdigit(buf[1])) { - toktype = TOK_SYM; - tokval = symbol(buf); - } - else { - x = strtol(buf, &end, 10); - if (*end != '\0') - lerror("read: error: invalid integer constant\n"); - toktype = TOK_NUM; - tokval = number(x); - } - } - else { - if (read_token(f, c, 0)) { - toktype = TOK_DOT; - } - else { - toktype = TOK_SYM; - tokval = symbol(buf); - } - } - return toktype; -} - -static value_t do_read_sexpr(FILE *f, int fixup); - -// build a list of conses. this is complicated by the fact that all conses -// can move whenever a new cons is allocated. we have to refer to every cons -// through a handle to a relocatable pointer (i.e. a pointer on the stack). -static void read_list(FILE *f, value_t *pval, int fixup) -{ - value_t c, *pc; - u_int32_t t; - - PUSH(NIL); - pc = &Stack[SP-1]; // to keep track of current cons cell - t = peek(f); - while (t != TOK_CLOSE) { - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - c = mk_cons(); car_(c) = cdr_(c) = NIL; - if (iscons(*pc)) { - cdr_(*pc) = c; - } - else { - *pval = c; - if (fixup != -1) - readstate->exprs.items[fixup] = c; - } - *pc = c; - c = do_read_sexpr(f,-1); // must be on separate lines due to undefined - car_(*pc) = c; // evaluation order - - t = peek(f); - if (t == TOK_DOT) { - take(); - c = do_read_sexpr(f,-1); - cdr_(*pc) = c; - t = peek(f); - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - if (t != TOK_CLOSE) - lerror("read: error: expected ')'\n"); - } - } - take(); - POP(); -} - -// fixup is the index of the label we'd like to fix up with this read -static value_t do_read_sexpr(FILE *f, int fixup) -{ - value_t v, *head; - u_int32_t t, l; - int i; - - t = peek(f); - take(); - switch (t) { - case TOK_CLOSE: - lerror("read: error: unexpected ')'\n"); - case TOK_DOT: - lerror("read: error: unexpected '.'\n"); - case TOK_SYM: - case TOK_NUM: - return tokval; - case TOK_COMMA: - head = &COMMA; goto listwith; - case TOK_COMMAAT: - head = &COMMAAT; goto listwith; - case TOK_COMMADOT: - head = &COMMADOT; goto listwith; - case TOK_BQ: - head = &BACKQUOTE; goto listwith; - case TOK_QUOTE: - head = "E; - listwith: - cons(head, cons(&NIL, &NIL)); - if (fixup != -1) - readstate->exprs.items[fixup] = Stack[SP-1]; - v = do_read_sexpr(f,-1); - car_(Stack[SP-2]) = v; - v = Stack[SP-1]; - POPN(2); - return v; - case TOK_SHARPQUOTE: - // femtoLisp doesn't need symbol-function, so #' does nothing - return do_read_sexpr(f, fixup); - case TOK_OPEN: - PUSH(NIL); - read_list(f, &Stack[SP-1], fixup); - return POP(); - case TOK_SHARPDOT: - // eval-when-read - // evaluated expressions can refer to existing backreferences, but they - // cannot see pending labels. in other words: - // (... #2=#.#0# ... ) OK - // (... #2=#.(#2#) ... ) DO NOT WANT - v = do_read_sexpr(f,-1); - return toplevel_eval(v); - case TOK_LABEL: - // create backreference label - l = numval(tokval); - if (ltable_lookup(&readstate->labels, l) != NOTFOUND) - lerror("read: error: label %d redefined\n", l); - ltable_insert(&readstate->labels, l); - i = readstate->exprs.n; - ltable_insert(&readstate->exprs, UNBOUND); - v = do_read_sexpr(f,i); - readstate->exprs.items[i] = v; - return v; - case TOK_BACKREF: - // look up backreference - l = numval(tokval); - i = ltable_lookup(&readstate->labels, l); - if (i == NOTFOUND || i >= (int)readstate->exprs.n || - readstate->exprs.items[i] == UNBOUND) - lerror("read: error: undefined label %d\n", l); - return readstate->exprs.items[i]; - } - return NIL; -} - -value_t read_sexpr(FILE *f) -{ - value_t v; - readstate_t state; - state.prev = readstate; - ltable_init(&state.labels, 16); - ltable_init(&state.exprs, 16); - readstate = &state; - - v = do_read_sexpr(f, -1); - - readstate = state.prev; - free(state.labels.items); - free(state.exprs.items); - return v; -} - -// print ---------------------------------------------------------------------- - -static void print_traverse(value_t v) -{ - while (iscons(v)) { - if (ismarked(v)) { - ltable_adjoin(&printconses, v); - return; - } - mark_cons(v); - print_traverse(car_(v)); - v = cdr_(v); - } -} - -static void print_symbol(FILE *f, char *name) -{ - int i, escape=0, charescape=0; - - if (name[0] == '\0') { - fprintf(f, "||"); - return; - } - if (name[0] == '.' && name[1] == '\0') { - fprintf(f, "|.|"); - return; - } - if (name[0] == '#') - escape = 1; - i=0; - while (name[i]) { - if (!symchar(name[i])) { - escape = 1; - if (name[i]=='|' || name[i]=='\\') { - charescape = 1; - break; - } - } - i++; - } - if (escape) { - if (charescape) { - fprintf(f, "|"); - i=0; - while (name[i]) { - if (name[i]=='|' || name[i]=='\\') - fprintf(f, "\\%c", name[i]); - else - fprintf(f, "%c", name[i]); - i++; - } - fprintf(f, "|"); - } - else { - fprintf(f, "|%s|", name); - } - } - else { - fprintf(f, "%s", name); - } -} - -static void do_print(FILE *f, value_t v, int princ) -{ - value_t cd; - int label; - char *name; - - switch (tag(v)) { - case TAG_NUM: fprintf(f, "%d", numval(v)); break; - case TAG_SYM: - name = ((symbol_t*)ptr(v))->name; - if (princ) - fprintf(f, "%s", name); - else - print_symbol(f, name); - break; - case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break; - case TAG_CONS: - if ((label=ltable_lookup(&printconses,v)) != NOTFOUND) { - if (!ismarked(v)) { - fprintf(f, "#%d#", label); - return; - } - fprintf(f, "#%d=", label); - } - fprintf(f, "("); - while (1) { - unmark_cons(v); - do_print(f, car_(v), princ); - cd = cdr_(v); - if (!iscons(cd)) { - if (cd != NIL) { - fprintf(f, " . "); - do_print(f, cd, princ); - } - fprintf(f, ")"); - break; - } - else { - if ((label=ltable_lookup(&printconses,cd)) != NOTFOUND) { - fprintf(f, " . "); - do_print(f, cd, princ); - fprintf(f, ")"); - break; - } - } - fprintf(f, " "); - v = cd; - } - break; - } -} - -void print(FILE *f, value_t v, int princ) -{ - ltable_clear(&printconses); - print_traverse(v); - do_print(f, v, princ); -} - -// eval ----------------------------------------------------------------------- - -static inline void argcount(char *fname, int nargs, int c) -{ - if (nargs != c) - lerror("%s: error: too %s arguments\n", fname, nargsconstant != UNBOUND) return sym->constant; - while (issymbol(*penv)) { // 1. try lookup in argument env - if (*penv == NIL) - goto get_global; - if (*penv == e) - return penv[1]; - penv+=2; - } - if ((v=assoc(e,*penv)) != NIL) // 2. closure env - return cdr_(v); - get_global: - if ((v = sym->binding) == UNBOUND) // 3. global env - lerror("eval: error: variable %s has no value\n", sym->name); - return v; - } - if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) - lerror("eval: error: stack overflow\n"); - saveSP = SP; - PUSH(e); - v = car_(e); - if (tag(v)<0x2) f = v; - else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ; - else f = eval_sexpr(v, penv, 0, envend); - if (isbuiltin(f)) { - // handle builtin function - if (!isspecial(f)) { - // evaluate argument list, placing arguments on stack - v = Stack[saveSP] = cdr_(Stack[saveSP]); - while (iscons(v)) { - v = eval(car_(v)); - PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - } - apply_builtin: - nargs = SP - saveSP - 1; - switch (intval(f)) { - // special forms - case F_QUOTE: - v = cdr_(Stack[saveSP]); - if (!iscons(v)) lerror("quote: error: expected argument\n"); - v = car_(v); - break; - case F_MACRO: - case F_LAMBDA: - if (*penv != NIL) { - // build a closure (lambda args body . env) - if (issymbol(*penv)) { - // cons up and save temporary environment - PUSH(Stack[envend-1]); // passed-in CLOENV - // find out how many new conses we need - nargs = ((int)(&Stack[envend] - penv - 1))>>1; - if (nargs) { - lenv = penv; - v = Stack[SP-1] = cons_reserve(nargs*2); - while (1) { - e = cdr_(cdr_(v)); - car_(v) = cdr_(v); - car_(cdr_(v)) = penv[0]; - cdr_(cdr_(v)) = penv[1]; - nargs--; - if (nargs==0) break; - penv+=2; - cdr_(v) = e; - v = e; - } - // final cdr points to existing cloenv - cdr_(v) = Stack[envend-1]; - // environment representation changed; install - // the new representation so everybody can see it - *lenv = Stack[SP-1]; - } - } - else { - PUSH(*penv); // env has already been captured; recapture - } - v = cdr_(Stack[saveSP]); - PUSH(car(v)); - PUSH(car(cdr_(v))); - v = cons_reserve(3); - car_(v) = (intval(f)==F_LAMBDA ? LAMBDA : MACRO); f = cdr_(v); - car_(f) = Stack[SP-2]; f = cdr_(f); //argsyms - car_(f) = Stack[SP-1]; //body - cdr_(f) = Stack[SP-3]; //env - } - else { - v = Stack[saveSP]; - } - break; - case F_LABEL: - v = Stack[saveSP]; - if (*penv != NIL) { - v = cdr_(v); - PUSH(car(v)); - PUSH(car(cdr_(v))); - body = &Stack[SP-1]; - *body = eval(*body); // evaluate lambda - v = f = cons_reserve(3); - car_(f) = LABEL; f = cdr_(f); - car_(f) = Stack[SP-2]; f = cdr_(f); // name - car_(f) = *body; // lambda expr - } - break; - case F_IF: - v = car(cdr_(Stack[saveSP])); - if (eval(v) != NIL) - v = car(cdr_(cdr_(Stack[saveSP]))); - else - v = car(cdr(cdr_(cdr_(Stack[saveSP])))); - tail_eval(v); - break; - case F_COND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - while (iscons(*pv)) { - c = tocons(car_(*pv), "cond"); - v = eval(c->car); - if (v != NIL) { - *pv = cdr_(car_(*pv)); - // evaluate body forms - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv)); - *pv = cdr_(*pv); - } - tail_eval(car_(*pv)); - } - break; - } - *pv = cdr_(*pv); - } - break; - case F_AND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = T; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v=eval(car_(*pv))) == NIL) { - SP = saveSP; return NIL; - } - *pv = cdr_(*pv); - } - tail_eval(car_(*pv)); - } - break; - case F_OR: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v=eval(car_(*pv))) != NIL) { - SP = saveSP; return v; - } - *pv = cdr_(*pv); - } - tail_eval(car_(*pv)); - } - break; - case F_WHILE: - PUSH(cdr(cdr_(Stack[saveSP]))); - body = &Stack[SP-1]; - PUSH(*body); - Stack[saveSP] = car_(cdr_(Stack[saveSP])); - value_t *cond = &Stack[saveSP]; - PUSH(NIL); - pv = &Stack[SP-1]; - while (eval(*cond) != NIL) { - *body = Stack[SP-2]; - while (iscons(*body)) { - *pv = eval(car_(*body)); - *body = cdr_(*body); - } - } - v = *pv; - break; - case F_PROGN: - // return last arg - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv)); - *pv = cdr_(*pv); - } - tail_eval(car_(*pv)); - } - break; - - // ordinary functions - case F_SET: - argcount("set", nargs, 2); - e = Stack[SP-2]; - while (issymbol(*penv)) { - if (*penv == NIL) - goto set_global; - if (*penv == e) { - penv[1] = Stack[SP-1]; - SP=saveSP; return penv[1]; - } - penv+=2; - } - if ((v=assoc(e,*penv)) != NIL) { - cdr_(v) = (e=Stack[SP-1]); - SP=saveSP; return e; - } - set_global: - tosymbol(e, "set")->binding = (v=Stack[SP-1]); - break; - case F_BOUNDP: - argcount("boundp", nargs, 1); - sym = tosymbol(Stack[SP-1], "boundp"); - if (sym->binding == UNBOUND && sym->constant == UNBOUND) - v = NIL; - else - v = T; - break; - case F_EQ: - argcount("eq", nargs, 2); - v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); - break; - case F_CONS: - argcount("cons", nargs, 2); - v = mk_cons(); - car_(v) = Stack[SP-2]; - cdr_(v) = Stack[SP-1]; - break; - case F_CAR: - argcount("car", nargs, 1); - v = car(Stack[SP-1]); - break; - case F_CDR: - argcount("cdr", nargs, 1); - v = cdr(Stack[SP-1]); - break; - case F_RPLACA: - argcount("rplaca", nargs, 2); - car(v=Stack[SP-2]) = Stack[SP-1]; - break; - case F_RPLACD: - argcount("rplacd", nargs, 2); - cdr(v=Stack[SP-2]) = Stack[SP-1]; - break; - case F_ATOM: - argcount("atom", nargs, 1); - v = ((!iscons(Stack[SP-1])) ? T : NIL); - break; - case F_CONSP: - argcount("consp", nargs, 1); - v = (iscons(Stack[SP-1]) ? T : NIL); - break; - case F_SYMBOLP: - argcount("symbolp", nargs, 1); - v = ((issymbol(Stack[SP-1])) ? T : NIL); - break; - case F_NUMBERP: - argcount("numberp", nargs, 1); - v = ((isnumber(Stack[SP-1])) ? T : NIL); - break; - case F_ADD: - s = 0; - for (i=saveSP+1; i < (int)SP; i++) { - n = tonumber(Stack[i], "+"); - s += n; - } - v = number(s); - break; - case F_SUB: - if (nargs < 1) lerror("-: error: too few arguments\n"); - i = saveSP+1; - s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "-"); - s -= n; - } - v = number(s); - break; - case F_MUL: - s = 1; - for (i=saveSP+1; i < (int)SP; i++) { - n = tonumber(Stack[i], "*"); - s *= n; - } - v = number(s); - break; - case F_DIV: - if (nargs < 1) lerror("/: error: too few arguments\n"); - i = saveSP+1; - s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "/"); - if (n == 0) lerror("/: error: division by zero\n"); - s /= n; - } - v = number(s); - break; - case F_LT: - argcount("<", nargs, 2); - // this implements generic comparison for all atoms - // strange comparisons (for example with builtins) are resolved - // arbitrarily but consistently. - // ordering: number < builtin < symbol < cons - if (tag(Stack[SP-2]) != tag(Stack[SP-1])) { - v = (tag(Stack[SP-2]) < tag(Stack[SP-1]) ? T : NIL); - } - else { - switch (tag(Stack[SP-2])) { - case TAG_NUM: - v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL; - break; - case TAG_SYM: - v = (strcmp(((symbol_t*)ptr(Stack[SP-2]))->name, - ((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ? - T : NIL; - break; - case TAG_BUILTIN: - v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL; - break; - case TAG_CONS: - lerror("<: error: expected atom\n"); - } - } - break; - case F_NOT: - argcount("not", nargs, 1); - v = ((Stack[SP-1] == NIL) ? T : NIL); - break; - case F_EVAL: - argcount("eval", nargs, 1); - v = Stack[SP-1]; - if (tag(v)<0x2) { SP=saveSP; return v; } - if (tail) { - *penv = NIL; - envend = SP = (u_int32_t)(penv-&Stack[0]) + 1; - e=v; goto eval_top; - } - else { - PUSH(NIL); - v = eval_sexpr(v, &Stack[SP-1], 1, SP); - } - break; - case F_PRINT: - for (i=saveSP+1; i < (int)SP; i++) - print(stdout, v=Stack[i], 0); - fprintf(stdout, "\n"); - break; - case F_PRINC: - for (i=saveSP+1; i < (int)SP; i++) - print(stdout, v=Stack[i], 1); - break; - case F_READ: - argcount("read", nargs, 0); - v = read_sexpr(stdin); - break; - case F_LOAD: - argcount("load", nargs, 1); - v = load_file(tosymbol(Stack[SP-1], "load")->name); - break; - case F_EXIT: - exit(0); - break; - case F_ERROR: - for (i=saveSP+1; i < (int)SP; i++) - print(stderr, Stack[i], 1); - lerror("\n"); - break; - case F_PROG1: - // return first arg - if (nargs < 1) lerror("prog1: error: too few arguments\n"); - v = Stack[saveSP+1]; - break; - case F_ASSOC: - argcount("assoc", nargs, 2); - v = assoc(Stack[SP-2], Stack[SP-1]); - break; - case F_APPLY: - argcount("apply", nargs, 2); - v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist - f = Stack[SP-2]; // first arg is new function - POPN(2); // pop apply's args - if (isbuiltin(f)) { - if (isspecial(f)) - lerror("apply: error: cannot apply special operator " - "%s\n", builtin_names[intval(f)]); - // unpack arglist onto the stack - while (iscons(v)) { - PUSH(car_(v)); - v = cdr_(v); - } - goto apply_builtin; - } - noeval = 1; - goto apply_lambda; - } - SP = saveSP; - return v; - } - else { - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - apply_lambda: - if (iscons(f)) { - headsym = car_(f); - if (headsym == LABEL) { - // (label name (lambda ...)) behaves the same as the lambda - // alone, except with name bound to the whole label expression - labl = f; - f = car(cdr(cdr_(labl))); - headsym = car(f); - } else labl=0; - // apply lambda or macro expression - PUSH(cdr(cdr_(f))); - PUSH(car_(cdr_(f))); - argsyms = &Stack[SP-1]; - argenv = &Stack[SP]; // argument environment starts now - if (labl) { - // add label binding to environment - PUSH(car_(cdr_(labl))); - PUSH(labl); - } - if (headsym == MACRO) - noeval = 1; - //else if (headsym != LAMBDA) - // lerror("apply: error: head must be lambda, macro, or label\n"); - // build a calling environment for the lambda - // the environment is the argument binds on top of the captured - // environment - while (iscons(v)) { - // bind args - if (!iscons(*argsyms)) { - if (*argsyms == NIL) - lerror("apply: error: too many arguments\n"); - break; - } - asym = car_(*argsyms); - if (asym==NIL || iscons(asym)) - lerror("apply: error: invalid formal argument\n"); - v = car_(v); - if (!noeval) { - v = eval(v); - } - PUSH(asym); - PUSH(v); - *argsyms = cdr_(*argsyms); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - if (*argsyms != NIL) { - if (issymbol(*argsyms)) { - PUSH(*argsyms); - if (noeval) { - PUSH(Stack[saveSP]); - } - else { - // this version uses collective allocation. about 7-10% - // faster for lists with > 2 elements, but uses more - // stack space - PUSH(NIL); - i = SP; - while (iscons(Stack[saveSP])) { - PUSH(eval(car_(Stack[saveSP]))); - Stack[saveSP] = cdr_(Stack[saveSP]); - } - nargs = SP-i; - if (nargs) { - Stack[i-1] = v = cons_reserve(nargs); - for(; i < (int)SP; i++) { - car_(v) = Stack[i]; - v = cdr_(v); - } - POPN(nargs); - } - } - } - else if (iscons(*argsyms)) { - lerror("apply: error: too few arguments\n"); - } - } - noeval = 0; - lenv = &Stack[saveSP+1]; - PUSH(cdr(*lenv)); // add cloenv to new environment - e = car_(Stack[saveSP+1]); - // macro: evaluate expansion in the calling environment - if (headsym == MACRO) { - if (tag(e)<0x2) ; - else e = eval_sexpr(e, argenv, 1, SP); - SP = saveSP; - if (tag(e)<0x2) return(e); - goto eval_top; - } - else { - if (tag(e)<0x2) { SP=saveSP; return(e); } - if (tail) { - // ok to overwrite environment - nargs = (int)(&Stack[SP] - argenv); - for(i=0; i < nargs; i++) - penv[i] = argenv[i]; - envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]); - goto eval_top; - } - else { - v = eval_sexpr(e, argenv, 1, SP); - SP = saveSP; - return v; - } - } - // not reached - } - type_error("apply", "function", f); - return NIL; -} - -// repl ----------------------------------------------------------------------- - -static char *infile = NULL; - -value_t toplevel_eval(value_t expr) -{ - value_t v; - PUSH(NIL); - v = topeval(expr, &Stack[SP-1]); - POP(); - return v; -} - -value_t load_file(char *fname) -{ - value_t e, v=NIL; - char *lastfile = infile; - FILE *f = fopen(fname, "r"); - infile = fname; - if (f == NULL) lerror("file not found\n"); - while (1) { - e = read_sexpr(f); - if (feof(f)) break; - v = toplevel_eval(e); - } - infile = lastfile; - fclose(f); - return v; -} - -int main(int argc, char* argv[]) -{ - value_t v; - - stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE; - lisp_init(); - if (setjmp(toplevel)) { - SP = 0; - fprintf(stderr, "\n"); - if (infile) { - fprintf(stderr, "error loading file \"%s\"\n", infile); - infile = NULL; - } - goto repl; - } - load_file("system.lsp"); - if (argc > 1) { load_file(argv[1]); return 0; } - printf("; _ \n"); - printf("; |_ _ _ |_ _ | . _ _ 2\n"); - printf("; | (-||||_(_)|__|_)|_)\n"); - printf(";-------------------|----------------------------------------------------------\n\n"); - repl: - while (1) { - printf("> "); - v = read_sexpr(stdin); - if (feof(stdin)) break; - print(stdout, v=toplevel_eval(v), 0); - set(symbol("that"), v); - printf("\n\n"); - } - return 0; -}