shithub: femtolisp

Download patch

ref: 6041c7b40e721d5a2327b9b5743d883990e4eadb
parent: 07dfa697df14e4f7656de65168ea1b6a89b34335
author: Jeff Bezanson <jeff.bezanson@gmail.com>
date: Tue Jun 11 13:31:51 EDT 2013

remove and clean up some old files

--- a/FLOSSING
+++ /dev/null
@@ -1,13 +1,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.
--- a/attic/dict.lsp
+++ /dev/null
@@ -1,51 +1,0 @@
-; dictionary as binary tree
-
-(defun dict () ())
-
-; node representation ((k . v) L R)
-(defun dict-peek (d key nf)
-  (if (null d) nf
-    (let ((c (compare key (caar d))))
-      (cond ((= c 0) (cdar d))
-            ((< c 0) (dict-peek (cadr  d) key nf))
-            (T       (dict-peek (caddr d) key nf))))))
-
-(defun dict-get (d key) (dict-peek d key nil))
-
-(defun dict-put (d key v)
-  (if (null d) (list (cons key v) (dict) (dict))
-    (let ((c (compare key (caar d))))
-      (cond ((= c 0) (list (cons key v) (cadr d) (caddr d)))
-            ((< c 0) (list (car d)
-                           (dict-put (cadr d) key v)
-                           (caddr d)))
-            (T       (list (car d)
-                           (cadr d)
-                           (dict-put (caddr d) key v)))))))
-
-; mutable dictionary
-(defun dict-nput (d key v)
-  (if (null d) (list (cons key v) (dict) (dict))
-    (let ((c (compare key (caar d))))
-      (cond ((= c 0) (rplacd (car d) v))
-            ((< c 0) (setf (cadr  d) (dict-nput (cadr  d) key v)))
-            (T       (setf (caddr d) (dict-nput (caddr d) key v))))
-      d)))
-
-(defun dict-collect (f d)
-  (if (null d) ()
-    (cons (f (caar d) (cdar d)) (nconc (dict-collect f (cadr  d))
-                                       (dict-collect f (caddr d))))))
-
-(defun dict-keys  (d) (dict-collect K    d))
-(defun dict-pairs (d) (dict-collect cons d))
-
-(defun dict-each (f d)
-  (if (null d) ()
-    (progn (f (caar d) (cdar d))
-           (dict-each f (cadr  d))
-           (dict-each f (caddr d)))))
-
-(defun alist-to-dict (a)
-  (foldl (lambda (p d) (dict-put d (car p) (cdr p)))
-         (dict) a))
--- a/attic/flutils.c
+++ /dev/null
@@ -1,59 +1,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];
-}
--- a/attic/plists.lsp
+++ /dev/null
@@ -1,28 +1,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)
--- /dev/null
+++ b/attic/scrap.c
@@ -1,0 +1,107 @@
+// code to relocate cons chains iteratively
+    pcdr = &cdr_(nc);
+    while (iscons(d)) {
+        if (car_(d) == FWD) {
+            *pcdr = cdr_(d);
+            return first;
+        }
+        *pcdr = nc = mk_cons();
+        a = car_(d);   v = cdr_(d);
+        car_(d) = FWD; cdr_(d) = nc;
+        car_(nc) = relocate(a);
+        pcdr = &cdr_(nc);
+        d = v;
+    }
+    *pcdr = d;
+
+/*
+  f = *rest;
+  *rest = NIL;
+  while (iscons(f)) {   // nreverse!
+      v = cdr_(f);
+      cdr_(f) = *rest;
+      *rest = f;
+      f = v;
+  }*/
+
+int favailable(FILE *f)
+{
+    fd_set set;
+    struct timeval tv = {0, 0};
+    int fd = fileno(f);
+
+    FD_ZERO(&set);
+    FD_SET(fd, &set);
+    return (select(fd+1, &set, NULL, NULL, &tv)!=0);
+}
+
+static void print_env(value_t *penv)
+{
+    printf("<[ ");
+    while (issymbol(*penv) && *penv!=NIL) {
+        print(stdout, *penv, 0);
+        printf(" ");
+        penv++;
+        print(stdout, *penv, 0);
+        printf(" ");
+        penv++;
+    }
+    printf("] ");
+    print(stdout, *penv, 0);
+    printf(">\n");
+}
+
+#else
+                    PUSH(NIL);
+                    PUSH(NIL);
+                    value_t *rest = &Stack[SP-1];
+                    // build list of rest arguments
+                    // we have to build it forwards, which is tricky
+                    while (iscons(v)) {
+                        v = eval(car_(v));
+                        PUSH(v);
+                        v = cons_(&Stack[SP-1], &NIL);
+                        POP();
+                        if (iscons(*rest))
+                            cdr_(*rest) = v;
+                        else
+                            Stack[SP-2] = v;
+                        *rest = v;
+                        v = Stack[saveSP] = cdr_(Stack[saveSP]);
+                    }
+                    POP();
+#endif
+                    // this version uses collective allocation. about 7-10%
+                    // faster for lists with > 2 elements, but uses more
+                    // stack space
+                    i = SP;
+                    while (iscons(v)) {
+                        v = eval(car_(v));
+                        PUSH(v);
+                        v = Stack[saveSP] = cdr_(Stack[saveSP]);
+                    }
+                    if ((int)SP==i) {
+                        PUSH(NIL);
+                    }
+                    else {
+                        e = v = cons_reserve(nargs=(SP-i));
+                        for(; i < (int)SP; i++) {
+                            car_(v) = Stack[i];
+                            v = cdr_(v);
+                        }
+                        POPN(nargs);
+                        PUSH(e);
+                    }
+
+value_t list_to_vector(value_t l)
+{
+    value_t v;
+    size_t n = llength(l), i=0;
+    v = alloc_vector(n, 0);
+    while (iscons(l)) {
+        vector_elt(v,i) = car_(l);
+        i++;
+        l = cdr_(l);
+    }
+    return v;
+}
--- a/attic/system-old.lsp
+++ /dev/null
@@ -1,25 +1,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 a<b,
-; 0 for a==b, and 1 for a>b. 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)))))
--- a/attic/trash.c
+++ /dev/null
@@ -1,303 +1,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);
-}
--- /dev/null
+++ b/examples/dict.lsp
@@ -1,0 +1,51 @@
+; dictionary as binary tree
+
+(defun dict () ())
+
+; node representation ((k . v) L R)
+(defun dict-peek (d key nf)
+  (if (null d) nf
+    (let ((c (compare key (caar d))))
+      (cond ((= c 0) (cdar d))
+            ((< c 0) (dict-peek (cadr  d) key nf))
+            (T       (dict-peek (caddr d) key nf))))))
+
+(defun dict-get (d key) (dict-peek d key nil))
+
+(defun dict-put (d key v)
+  (if (null d) (list (cons key v) (dict) (dict))
+    (let ((c (compare key (caar d))))
+      (cond ((= c 0) (list (cons key v) (cadr d) (caddr d)))
+            ((< c 0) (list (car d)
+                           (dict-put (cadr d) key v)
+                           (caddr d)))
+            (T       (list (car d)
+                           (cadr d)
+                           (dict-put (caddr d) key v)))))))
+
+; mutable dictionary
+(defun dict-nput (d key v)
+  (if (null d) (list (cons key v) (dict) (dict))
+    (let ((c (compare key (caar d))))
+      (cond ((= c 0) (rplacd (car d) v))
+            ((< c 0) (setf (cadr  d) (dict-nput (cadr  d) key v)))
+            (T       (setf (caddr d) (dict-nput (caddr d) key v))))
+      d)))
+
+(defun dict-collect (f d)
+  (if (null d) ()
+    (cons (f (caar d) (cdar d)) (nconc (dict-collect f (cadr  d))
+                                       (dict-collect f (caddr d))))))
+
+(defun dict-keys  (d) (dict-collect K    d))
+(defun dict-pairs (d) (dict-collect cons d))
+
+(defun dict-each (f d)
+  (if (null d) ()
+    (progn (f (caar d) (cdar d))
+           (dict-each f (cadr  d))
+           (dict-each f (caddr d)))))
+
+(defun alist-to-dict (a)
+  (foldl (lambda (p d) (dict-put d (car p) (cdr p)))
+         (dict) a))
--- a/tiny/lisp2.c.bak
+++ /dev/null
@@ -1,1448 +1,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 <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <ctype.h>
-#include <sys/types.h>
-
-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 = &QUOTE;
-    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, nargs<c ? "few":"many");
-}
-
-// return a cons element of v whose car is item
-static value_t assoc(value_t item, value_t v)
-{
-    value_t bind;
-
-    while (iscons(v)) {
-        bind = car_(v);
-        if (iscons(bind) && car_(bind) == item)
-            return bind;
-        v = cdr_(v);
-    }
-    return NIL;
-}
-
-#define eval(e)         ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend))
-#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP))
-#define tail_eval(xpr) do { SP = saveSP;  \
-    if (tag(xpr)<0x2) { return (xpr); } \
-    else { e=(xpr); goto eval_top; } } while (0)
-
-/* stack setup on entry:
-  n     n+1   ...
- +-----+-----+-----+-----+-----+-----+-----+-----+
- | SYM | VAL | SYM | VAL | CLO |     |     |     |
- +-----+-----+-----+-----+-----+-----+-----+-----+
-  ^                             ^                      ^
-  |                             |                      |
-  penv                          envend                 SP (who knows where)
-
- sym is an argument name and val is its binding. CLO is a closed-up
- environment list (which can be empty, i.e. NIL).
- CLO is always there, but there might be zero SYM/VAL pairs.
-
- if tail==1, you are allowed (indeed encouraged) to overwrite this
- environment, otherwise you have to put any new environment on the top
- of the stack.
-*/
-value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
-{
-    value_t f, v, headsym, asym, labl, *pv, *argsyms, *body, *lenv, *argenv;
-    cons_t *c;
-    symbol_t *sym;
-    u_int32_t saveSP;
-    int i, nargs, noeval=0;
-    number_t s, n;
-
- eval_top:
-    if (issymbol(e)) {
-        sym = (symbol_t*)ptr(e);
-        if (sym->constant != 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;
-}
--- a/tiny/scrap.c
+++ /dev/null
@@ -1,107 +1,0 @@
-// code to relocate cons chains iteratively
-    pcdr = &cdr_(nc);
-    while (iscons(d)) {
-        if (car_(d) == FWD) {
-            *pcdr = cdr_(d);
-            return first;
-        }
-        *pcdr = nc = mk_cons();
-        a = car_(d);   v = cdr_(d);
-        car_(d) = FWD; cdr_(d) = nc;
-        car_(nc) = relocate(a);
-        pcdr = &cdr_(nc);
-        d = v;
-    }
-    *pcdr = d;
-
-/*
-  f = *rest;
-  *rest = NIL;
-  while (iscons(f)) {   // nreverse!
-      v = cdr_(f);
-      cdr_(f) = *rest;
-      *rest = f;
-      f = v;
-  }*/
-
-int favailable(FILE *f)
-{
-    fd_set set;
-    struct timeval tv = {0, 0};
-    int fd = fileno(f);
-
-    FD_ZERO(&set);
-    FD_SET(fd, &set);
-    return (select(fd+1, &set, NULL, NULL, &tv)!=0);
-}
-
-static void print_env(value_t *penv)
-{
-    printf("<[ ");
-    while (issymbol(*penv) && *penv!=NIL) {
-        print(stdout, *penv, 0);
-        printf(" ");
-        penv++;
-        print(stdout, *penv, 0);
-        printf(" ");
-        penv++;
-    }
-    printf("] ");
-    print(stdout, *penv, 0);
-    printf(">\n");
-}
-
-#else
-                    PUSH(NIL);
-                    PUSH(NIL);
-                    value_t *rest = &Stack[SP-1];
-                    // build list of rest arguments
-                    // we have to build it forwards, which is tricky
-                    while (iscons(v)) {
-                        v = eval(car_(v));
-                        PUSH(v);
-                        v = cons_(&Stack[SP-1], &NIL);
-                        POP();
-                        if (iscons(*rest))
-                            cdr_(*rest) = v;
-                        else
-                            Stack[SP-2] = v;
-                        *rest = v;
-                        v = Stack[saveSP] = cdr_(Stack[saveSP]);
-                    }
-                    POP();
-#endif
-                    // this version uses collective allocation. about 7-10%
-                    // faster for lists with > 2 elements, but uses more
-                    // stack space
-                    i = SP;
-                    while (iscons(v)) {
-                        v = eval(car_(v));
-                        PUSH(v);
-                        v = Stack[saveSP] = cdr_(Stack[saveSP]);
-                    }
-                    if ((int)SP==i) {
-                        PUSH(NIL);
-                    }
-                    else {
-                        e = v = cons_reserve(nargs=(SP-i));
-                        for(; i < (int)SP; i++) {
-                            car_(v) = Stack[i];
-                            v = cdr_(v);
-                        }
-                        POPN(nargs);
-                        PUSH(e);
-                    }
-
-value_t list_to_vector(value_t l)
-{
-    value_t v;
-    size_t n = llength(l), i=0;
-    v = alloc_vector(n, 0);
-    while (iscons(l)) {
-        vector_elt(v,i) = car_(l);
-        i++;
-        l = cdr_(l);
-    }
-    return v;
-}