ref: 6041c7b40e721d5a2327b9b5743d883990e4eadb
parent: 07dfa697df14e4f7656de65168ea1b6a89b34335
author: Jeff Bezanson <[email protected]>
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 = "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, 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;
-}