ref: 3e8336c0ea2e6f70eb0b277f3d0927b114d0709c
author: aap <[email protected]>
date: Fri Aug 19 06:30:52 EDT 2022
first commit
--- /dev/null
+++ b/LICENSE
@@ -1,0 +1,21 @@
+MIT License
+
+Copyright (c) 2018
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
--- /dev/null
+++ b/Makefile
@@ -1,0 +1,6 @@
+CFLAGS=-g -Wall -Wextra -DLISP$(bits)
+LDFLAGS=-lm
+lisp: lisp.o subr.o mem.o
+lisp.o: lisp.h
+subr.o: lisp.h
+mem.o: lisp.h
--- /dev/null
+++ b/README.md
@@ -1,0 +1,34 @@
+# LISP
+
+This is an implementation of LISP inspired by MacLISP.
+It's still rather incomplete and whether I want to reach
+full MacLISP compatibility is also still uncertain.
+
+
+## Build
+
+On a 64 bit system just type `make` on UNIX, `mk` on Plan 9.
+On a 32 bit system: `bits=32 make/mk`.
+
+## How to use
+
+You're talking to a REPL. e.g.
+
+```
+% ./lisp
+*
+(car '(a b))
+
+A
+```
+
+## To-Do
+
+* Figure out what to do about lexical vs dynamic binding
+* Implement most of actual MacLISP functions
+* Arrays
+* Strings
+* maybe Bignums?
+* Better storage management
+* Assembler (and compiler?)
+* some code examples
--- /dev/null
+++ b/lib.l
@@ -1,0 +1,101 @@
+;;; taken from MACLISP
+(defprop defun
+ (lambda (l)
+ (cond ((and (caddr l)
+ (atom (caddr l)))
+ (list 'defprop (cadr l)
+ (cons 'lambda (cons (cadddr l) (cddddr l)))
+ (caddr l)))
+ (t (list 'defprop (cadr l)
+ (cons 'lambda (cons (caddr l) (cdddr l)))
+ 'expr))))
+ macro)
+
+;; LET
+(defun let-vars (l) (maplist #'(lambda (x) (caar x)) (cadr l)))
+(defun let-vals (l) (maplist #'(lambda (x) (cadar x)) (cadr l)))
+(defun let macro (l)
+ (cons (cons 'lambda (cons (let-vars l) (cddr l)))
+ (let-vals l)))
+
+
+
+
+;;;
+;;; examples
+;;;
+
+
+;;; compute greatest common divisor
+(defun gcd (a b)
+ (cond ((lessp a b) (gcd b a))
+ ((eq b 0) a)
+ (t (gcd b (difference a b)))))
+
+
+;;; differentiate expression exp w.r.t. x
+(defun diff (exp x)
+ (cond ((eq exp x) 1)
+ ((atom exp) 0)
+ ((eq (car exp) 'plus)
+ (cons 'plus (mapcar #'(lambda (j) (diff j x)) (cdr exp))))
+ ((eq (car exp) 'times)
+ (cons 'plus
+ (maplist
+ #'(lambda (J)
+ (cons 'times
+ (maplist
+ #'(lambda (K)
+ (cond ((equal J K) (diff (car K) x))
+ (t (car K))))
+ (cdr exp))))
+ (cdr exp))))
+ (t 'invalid)))
+
+
+
+;;; simplify mathematical expression
+(defun simplify (exp)
+ (cond ((atom exp) exp)
+ ((eq (car exp) 'plus) (simpsum (simplis (cdr exp))))
+ ((eq (car exp) 'times) (simpprod (simplis (cdr exp))))
+ (t exp)))
+
+;;; simplify a list of expressions
+(defun simplis (lst)
+ (mapcar #'(lambda (l) (simplify l)) lst))
+
+;;; simplify the terms of a sum
+(defun simpsum (terms)
+ (prog (sep const var)
+ (setq sep (separate terms nil nil))
+ (setq const (car sep))
+ (setq var (cadr sep))
+ (setq const (eval (cons 'plus const) nil))
+ (return (cond ((null var) const)
+ ((eq const 0)
+ (cond ((null (cdr var)) (car var))
+ (t (cons 'plus var))))
+ (t (cons 'plus (cons const var)))))))
+
+;;; simplify the terms of a product
+(defun simpprod (terms)
+ (prog (sep const var)
+ (setq sep (separate terms nil nil))
+ (setq const (car sep))
+ (setq var (cadr sep))
+ (setq const (eval (cons 'times const) nil))
+ (return (cond ((null var) const)
+ ((eq const 0) 0)
+ ((eq const 1)
+ (cond ((null (cdr var)) (car var))
+ (t (cons 'times var))))
+ (t (cons 'times (cons const var)))))))
+
+;;; separate constants from variables in a list
+(defun separate (lst const var)
+ (cond ((null lst)
+ (list const var))
+ ((numberp (car lst))
+ (separate (cdr lst) (cons (car lst) const) var))
+ (t (separate (cdr lst) const (cons (car lst) var)))))
--- /dev/null
+++ b/lisp.c
@@ -1,0 +1,1033 @@
+#include "lisp.h"
+
+#ifdef PLAN9
+void exit(int n)
+{+ if(n == 0)
+ exits(nil);
+ exits("error");+}
+#endif
+
+FILE *sysin, *sysout, *syserr;
+
+C *fclist;
+F *fflist;
+C *pdl[PDLSZ];
+int pdp;
+Temlis temlis;
+C **alist;
+int nargs;
+C *oblist;
+Arglist largs;
+
+int gcen;
+int gcdbg = 0;
+
+void *Atom = (void*)CAR_ATOM;
+void *Fixnum = (void*)(CAR_ATOM|CAR_FIX);
+void *Flonum = (void*)(CAR_ATOM|CAR_FLO);
+
+/* absence of a value */
+C *noval = (C*)~0;
+
+/* some important atoms */
+C *pname;
+C *value;
+C *expr;
+C *subr;
+C *lsubr;
+C *fexpr;
+C *fsubr;
+C *macro;
+C *t;
+C *quote;
+C *label;
+C *function;
+C *funarg;
+C *lambda;
+C *cond;
+C *set;
+C *setq;
+C *go;
+C *retrn;
+
+C *star;
+C *digits[10];
+C *plus, *minus;
+
+jmp_buf tljmp;
+
+/* print error and jmp back into toplevel */
+void
+err(char *fmt, ...)
+{+ va_list ap;
+ va_start(ap, fmt);
+ vfprintf(syserr, fmt, ap);
+ fprintf(syserr, "\n");
+ va_end(ap);
+ longjmp(tljmp, 1);
+}
+
+void
+panic(char *fmt, ...)
+{+ va_list ap;
+ va_start(ap, fmt);
+ vfprintf(syserr, fmt, ap);
+ fprintf(syserr, "\n");
+ va_end(ap);
+#ifdef PLAN9
+ exits("panic");+#else
+ exit(1);
+#endif
+}
+
+C**
+push(C *c)
+{+ C **p;
+ assert(pdp >= 0 && pdp < PDLSZ);
+ p = &pdl[pdp++];
+ *p = c;
+ return p;
+}
+
+C*
+pop(void)
+{+ assert(pdp > 0 && pdp <= PDLSZ);
+ return pdl[--pdp];
+}
+
+C*
+cons(void *a, C *d)
+{+ C *c;
+ if(((P)a & CAR_ATOM) == 0)
+ temlis.ca = a;
+ temlis.cd = d;
+ if(gcen && (fclist == nil || gcdbg))
+ gc();
+ c = fclist;
+ assert(c != nil);
+ fclist = fclist->d;
+ temlis.ca = nil;
+ temlis.cd = nil;
+ c->a = a;
+ c->d = d;
+ return c;
+}
+
+F*
+consw(word fw)
+{+ F *f;
+ if(gcen && (fflist == nil || gcdbg))
+ gc();
+ f = fflist;
+ assert(f != nil);
+ fflist = fflist->p;
+ f->fw = fw;
+ return f;
+}
+
+C*
+mkfix(fixnum fix)
+{+ C *c;
+ if(fix >= 0 && fix < 10)
+ return digits[fix];
+ c = cons(Fixnum, nil);
+ c->fix = fix;
+ return c;
+}
+
+C*
+mkflo(flonum flo)
+{+ C *c;
+ c = cons(Flonum, nil);
+ c->flo = flo;
+ return c;
+}
+
+C*
+mksubr(C *(*subr)(void), int n)
+{+ F nf, sf;
+ nf.n = n;
+ sf.subr = subr;
+ temlis.ca = consw(nf.fw);
+ temlis.cd = consw(sf.fw);
+ return cons(temlis.ca, temlis.cd);
+}
+
+int
+atom(C *c)
+{+ return c == nil || c->ap & CAR_ATOM;
+}
+
+int
+fixnump(C *c)
+{+ return c != nil && c->ap & CAR_ATOM && c->ap & CAR_FIX;
+}
+
+int
+flonump(C *c)
+{+ return c != nil && c->ap & CAR_ATOM && c->ap & CAR_FLO;
+}
+
+int
+numberp(C *c)
+{+ return c != nil && c->ap & CAR_ATOM && c->ap & CAR_NUM;
+}
+
+int
+listp(C *c)
+{+ return c == nil || !(c->ap & CAR_ATOM);
+}
+
+fixnum
+length(C *c)
+{+ fixnum n;
+ if(!listp(c))
+ err("error: not a list");+ for(n = 0; c != nil; c = c->d){+ if(atom(c))
+ err("error: not a proper list");+ n++;
+ }
+ return n;
+}
+
+/* functions for handling pnames */
+int
+matchpname(C *c, char *name)
+{+ int i;
+ char *s;
+ char c1, c2;
+
+ s = name;
+ i = 0;
+ for(;;){+ c1 = *s++;
+ c2 = c ? c->af->c[i++] : '\0';
+ if(i == C2W){+ i = 0;
+ c = c->d;
+ }
+ if(c1 != c2)
+ return 0;
+ if(c1 == '\0')
+ return 1;
+ }
+}
+
+C*
+makepname(char *name)
+{+ int i;
+ F w;
+ char *s;
+ C *ret, **next;
+
+ /* TODO: maybe do this elsewhere? */
+ ret = cons(nil, nil);
+ temlis.pn = ret;
+ next = &ret->a;
+
+ /* split up name into full words
+ * and build list structure */
+ s = name;
+ while(*s != '\0'){+ w.fw = 0;
+ for(i = 0; i < C2W; i++){+ if(*s == '\0')
+ break;
+ w.c[i] = *s++;
+ }
+ *next = cons(consw(w.fw), nil);
+ next = &(*next)->d;
+ }
+ temlis.pn = nil;
+ return ret;
+}
+
+C*
+get(C *l, C *p)
+{+ assert(l != nil);
+ for(; l->d != nil; l = l->d->d){+ assert(listp(l->d));
+ if(l->d->a == p){+ assert(listp(l->d->d));
+ return l->d->d->a;
+ }
+ }
+ return nil;
+}
+C*
+getx(C *l, C *p)
+{+ for(l = l->d; l != nil; l = l->d->d)
+ if(l->a == p)
+ return l->d;
+ return nil;
+}
+
+/* returns noval instead of evaluating a function */
+C*
+assq(C *x, C *y)
+{+ for(; y != nil; y = y->d)
+ if(y->a->a == x)
+ return y->a;
+ return nil;
+}
+
+C*
+putprop(C *a, C *val, C *ind)
+{+ C *tt;
+ if(a == nil || numberp(a))
+ err("error: no p-list");+ for(tt = a->d; tt != nil; tt = tt->d->d)
+ if(tt->a == ind){+ tt->d->a = val;
+ return val;
+ }
+ temlis.a = a;
+ temlis.b = ind;
+ a->d = cons(ind, cons(val, a->d));
+ temlis.a = nil;
+ temlis.b = nil;
+ return val;
+}
+
+C*
+nconc(C *x, C *e)
+{+ C *m;
+ if(x == nil) return e;
+ m = x;
+ for(; x->d != nil; x = x->d);
+ x->d = e;
+ return m;
+}
+
+C*
+pair(C *x, C *y)
+{+ C *m, **p;
+// TODO: must save here?
+ temlis.b = x;
+ temlis.c = y;
+ assert(temlis.a == nil);
+ p = (C**)&temlis.a;
+ while(x != nil && y != nil){+ *p = cons(cons(x->a, y->a), nil);
+ p = &(*p)->d;
+ x = x->d;
+ y = y->d;
+ }
+ if(x != nil || y != nil)
+ err("error: pair not same length");+ m = temlis.a;
+ temlis.a = nil;
+ temlis.b = nil;
+ temlis.c = nil;
+ return m;
+}
+
+C*
+intern(char *name)
+{+ C *c;
+ C *pn;
+ for(c = oblist; c; c = c->d){+ if(numberp(c->a))
+ continue;
+ pn = get(c->a, pname);
+ if(pn == nil)
+ continue;
+ if(matchpname(pn, name))
+ return c->a;
+ }
+ c = cons(Atom,
+ cons(pname,
+ makepname(name)));
+ oblist = cons(c, oblist);
+ return c;
+}
+
+/*
+ * output
+ */
+
+void
+princpname(C *c)
+{+ char chr;
+ word fw;
+ int i;
+ for(c = c->a; c != nil; c = c->d){+ fw = ((F*)c->a)->fw;
+ for(i = 0; i < C2W; i++){+ chr = fw&0xFF;
+ if(chr == 0) return;
+ putc(chr, sysout);
+ fw >>= 8;
+ }
+ }
+}
+
+void
+printpname(C *c)
+{+ char chr;
+ C *cc;
+ word fw;
+ int i;
+ int spec;
+
+ cc = c;
+ spec = 0;
+ for(c = c->a; c != nil; c = c->d){+ fw = ((F*)c->a)->fw;
+ for(i = 0; i < C2W; i++){+ chr = fw&0xFF;
+ if(chr == 0) goto pr;
+ if(!isupper(fw&0x7F)){+ spec = 1;
+ goto pr;
+ }
+ fw >>= 8;
+ }
+ }
+pr:
+ if(spec) putc('|', sysout);+ princpname(cc);
+ if(spec) putc('|', sysout);+}
+
+void
+printatom(C *c, void (*pnm)(C *c))
+{+ if(c == nil)
+ fprintf(sysout, "NIL");
+ else if(fixnump(c))
+ fprintf(sysout, "%lld", (long long int)c->fix);
+ else if(flonump(c))
+ fprintf(sysout, "%f", c->flo);
+ else{+ assert(atom(c));
+ for(; c != nil; c = c->d)
+ if(c->a == pname){+ pnm(c->d);
+ return;
+ }
+ fprintf(sysout, "%%ATOM%%");
+ }
+}
+
+void
+printsxp(C *c, void (*pnm)(C *c))
+{+ int fst;
+ if(atom(c))
+ printatom(c, pnm);
+ else{+ putc('(', sysout);+ fst = 1;
+ for(; c != nil; c = c->d){+ if(atom(c)){+ fprintf(sysout, " . ");
+ printatom(c, pnm);
+ break;
+ }
+ if(!fst)
+ putc(' ', sysout);+ lprint(c->a);
+ fst = 0;
+ }
+ putc(')', sysout);+ }
+}
+
+void
+lprint(C *c)
+{+ printsxp(c, printpname);
+}
+
+void
+princ(C *c)
+{+ printsxp(c, princpname);
+}
+
+/*
+ * input
+ */
+
+int nextc;
+
+static int
+chsp(void)
+{+ int c;
+ if(nextc){+ c = nextc;
+ nextc = 0;
+ return c;
+ }
+ c = getc(sysin);
+ // remove comments
+ if(c == ';')
+ while(c != '\n')
+ c = getc(sysin);
+ if(isspace(c))
+ c = ' ';
+ return c;
+}
+
+static int
+ch(void)
+{+ int c;
+ while(c = chsp(), c == ' ');
+ return c;
+}
+
+C*
+readnum(char *buf)
+{+ int c;
+ int type;
+ fixnum oct;
+ fixnum dec;
+ flonum flo, fract, div;
+ int sign;
+ int ndigits;
+
+ sign = 1;
+ type = 0; /* octal */
+ oct = 0;
+ dec = 0;
+ flo = 0.0;
+ fract = 0.0;
+ div = 10.0;
+ ndigits = 0;
+
+
+ c = *buf;
+ if(c == '-' || c == '+'){+ sign = c == '-' ? -1 : 1;
+ buf++;
+ }
+
+ while(c = *buf++, c != '\0'){+ if(c >= '0' && c <= '9'){+ if(type == 0){+ oct = oct*8 + c-'0';
+ dec = dec*10 + c-'0';
+ flo = flo*10.0 + c-'0';
+ }else{+ type = 2; /* float */
+ fract += (c-'0')/div;
+ div *= 10.0;
+ }
+ ndigits++;
+ }else if(c == '.' && type == 0){+ type = 1; /* decimal */
+ }else
+ return nil;
+ }
+ if(ndigits == 0)
+ return nil;
+// use decimal default for now
+// if(type == 0)
+// return mkfix(sign*oct);
+// if(type == 1)
+// return mkfix(sign*dec);
+ if(type == 0 || type == 1)
+ return mkfix(sign*dec);
+ return mkflo(sign*(flo+fract));
+}
+
+C*
+readatom(void)
+{+ C *num;
+ int c;
+ char buf[128], *p;
+ int spec, lc;
+
+ p = buf;
+ spec = 0;
+ lc = 1;
+ while(c = chsp(), c != EOF){+ if(!spec && strchr(" ()", c)){+ nextc = c;
+ break;
+ }
+ if(c == '|'){+ lc = 0;
+ spec = !spec;
+ continue;
+ }
+ *p++ = c;
+ }
+ *p = '\0';
+ if(lc)
+ for(p = buf; *p; p++)
+ *p = toupper(*p);
+ if(strcmp(buf, "NIL") == 0)
+ return nil;
+ num = readnum(buf);
+ return num ? num : intern(buf);
+}
+
+C *readsxp(void);
+
+C*
+readlist(void)
+{+ int first;
+ int c;
+ C **p;
+
+ first = 1;
+ p = push(nil);
+ while(c = ch(), c != ')'){+ /* TODO: only valid when next letter is space */
+ if(c == '.'){+ if(first)
+ err("error: unexpected '.'");+ *p = readsxp();
+ if(c = ch(), c != ')')
+ err("error: expected ')' (got %c)", c);+ break;
+ }
+ nextc = c;
+ *p = cons(readsxp(), nil);
+ p = &(*p)->d;
+ first = 0;
+ }
+ return pop();
+}
+
+C*
+readsxp(void)
+{+ int c;
+ c = ch();
+ if(c == EOF)
+ return noval;
+ if(c == '\'')
+ return cons(quote, cons(readsxp(), nil));
+ if(c == '#'){+ c = ch();
+ if(c == '\'')
+ return cons(function, cons(readsxp(), nil));
+ err("expected '");+ }
+ if(c == ')')
+ err("error: unexpected ')'");+ if(c == '(')+ return readlist();
+ nextc = c;
+ return readatom();
+}
+
+/*
+ * Eval Apply
+ */
+
+Arglist
+spread(C *l)
+{+ Arglist al;
+ al.nargs = nargs;
+ al.alist = alist;
+ al.pdp = pdp;
+ nargs = 0;
+ alist = &pdl[pdp];
+ for(; l != nil; l = l->d){+ push(l->a);
+ nargs++;
+ }
+ return al;
+}
+
+void
+restore(Arglist al)
+{+ pdp = al.pdp;
+ alist = al.alist;
+ nargs = al.nargs;
+}
+
+C*
+evbody(C *c, C *a)
+{+ C *t;
+ t = nil;
+ for(; c != nil; c = c->d)
+ t = eval(c->a, a);
+ return t;
+}
+
+C*
+evcon(C *c, C *a)
+{+ C *tt;
+ int spdp;
+ spdp = pdp;
+ push(c);
+ push(a);
+ for(; c != nil; c = c->d){+ tt = eval(c->a->a, a);
+ if(tt != nil){+ pdp = spdp;
+ return evbody(c->a->d, a);
+ }
+ }
+ err("error: no cond clause");+ return nil; /* make compiler happy */
+}
+
+C*
+applysubr(C *subr, C *args)
+{+ C *tt;
+ Arglist al;
+
+ al = spread(args);
+ if(subr->af->n != nargs)
+ err("error: arg count (expected %d, got %d)",+ subr->af->n, nargs);
+ tt = subr->df->subr();
+ restore(al);
+ return tt;
+}
+
+C*
+applylsubr(C *subr, C *args)
+{+ C *tt;
+ Arglist al, ll;
+
+ al = spread(args);
+ ll = largs;
+ largs.nargs = nargs;
+ largs.alist = alist-1;
+ tt = subr->df->subr();
+ largs = ll;
+ restore(al);
+ return tt;
+}
+
+C*
+eval(C *form, C *a)
+{+ C *tt, *arg;
+ int spdp;
+ Arglist al;
+
+tail:
+ if(form == nil)
+ return nil;
+ if(numberp(form))
+ return form;
+ if(atom(form)){+ if(tt = getx(form, value), tt != nil)
+ return tt->a;
+ if(tt = assq(form, a), tt == nil)
+ err("error: no value");+ return tt->d;
+ }
+ if(form->a == cond)
+ return evcon(form->d, a);
+ spdp = pdp;
+ push(form);
+ push(a);
+ if(atom(form->a)){+ if(form->a == nil || numberp(form->a))
+lprint(form),
+ err("error: no function");+ for(tt = form->a->d; tt != nil; tt = tt->d->d){+ if(tt->a == expr){+ arg = evlis(form->d, a);
+ pdp = spdp;
+ return apply(tt->d->a, arg, a);
+ }else if(tt->a == fexpr){+ arg = cons(form->d, cons(a, nil));
+ pdp = spdp;
+ return apply(tt->d->a, arg, a);
+ }else if(tt->a == subr){+ arg = evlis(form->d, a);
+ pdp = spdp;
+ return applysubr(tt->d->a, arg);
+ }else if(tt->a == lsubr){+ arg = evlis(form->d, a);
+ pdp = spdp;
+ return applylsubr(tt->d->a, arg);
+ }else if(tt->a == fsubr){+ pdp = spdp;
+ al = spread(nil);
+ push(form->d);
+ push(a);
+ nargs = 2;
+ tt = tt->d->af->subr();
+ restore(al);
+ return tt;
+ }else if(tt->a == macro){+ arg = cons(form, nil);
+ pdp = spdp;
+ form = apply(tt->d->a, arg, a);
+ goto tail;
+ }
+ }
+ if(tt = assq(form->a, a), tt == nil)
+lprint(form),
+ err("error: no function");+ form = cons(tt->d, form->d);
+ pdp = spdp;
+ goto tail;
+ }
+ arg = evlis(form->d, a);
+ pdp = spdp;
+ return apply(form->a, arg, a);
+}
+
+C*
+evlis(C *m, C *a)
+{+ C **p;
+ int spdp;
+
+ p = push(nil);
+ spdp = pdp;
+ push(m);
+ push(a);
+ for(; m != nil; m = m->d){+ *p = cons(eval(m->a, a), nil);
+ p = &(*p)->d;
+ }
+ pdp = spdp;
+ return pop();
+}
+
+C*
+apply(C *fn, C *args, C *a)
+{+ C *tt;
+ int spdp;
+ Arglist al, ll;
+
+ if(atom(fn)){+ if(fn == nil || numberp(fn))
+lprint(fn),
+ err("error: no function");+ for(tt = fn->d; tt != nil; tt = tt->d->d){+ if(tt->a == expr)
+ return apply(tt->d->a, args, a);
+ else if(tt->a == subr)
+ return applysubr(tt->d->a, args);
+ else if(tt->a == lsubr)
+ return applylsubr(tt->d->a, args);
+ }
+ if(tt = assq(fn, a), tt == nil)
+lprint(fn),
+ err("error: no function");+ return apply(tt->d, args, a);
+ }
+ spdp = pdp;
+ push(fn);
+ push(args);
+ push(a);
+ if(fn->a == label){+ tt = cons(fn->d->a, fn->d->d->a);
+ a = cons(tt, a);
+ pdp = spdp;
+ return apply(fn->d->d->a, args, a);
+ }
+ if(fn->a == funarg){+ pdp = spdp;
+ return apply(fn->d->a, args, fn->d->d->a);
+ }
+ if(fn->a == lambda){+ if(fn->d->a && atom(fn->d->a)){+ tt = cons(fn->d->a, mkfix(length(args)));
+ pdp = spdp;
+ al = spread(args);
+ ll = largs;
+ largs.nargs = nargs;
+ largs.alist = alist-1;
+ tt = evbody(fn->d->d, cons(tt, a));
+ largs = ll;
+ restore(al);
+ return tt;
+ }else{+ args = pair(fn->d->a, args);
+ pdp = spdp;
+ return evbody(fn->d->d, nconc(args, a));
+ }
+ }
+ fn = eval(fn, a);
+ pdp = spdp;
+ return apply(fn, args, a);
+}
+
+
+/*
+ * top level
+ */
+
+void
+init(void)
+{+ int i;
+
+ sysin = stdin;
+ sysout = stdout;
+ syserr = stderr;
+
+ gc();
+
+ /* init oblist so we can use intern */
+ pname = cons(Atom, nil);
+ pname->d = cons(pname, makepname("PNAME"));+ oblist = cons(pname, nil);
+
+ /* Now enable GC */
+ gcen = 1;
+
+ t = intern("T");+ value = intern("VALUE");+ subr = intern("SUBR");+ lsubr = intern("LSUBR");+ fsubr = intern("FSUBR");+ expr = intern("EXPR");+ fexpr = intern("FEXPR");+ macro = intern("MACRO");+ quote = intern("QUOTE");+ label = intern("LABEL");+ funarg = intern("FUNARG");+ function = intern("FUNCTION");+ lambda = intern("LAMBDA");+ cond = intern("COND");+ set = intern("SET");+ setq = intern("SETQ");+ go = intern("GO");+ retrn = intern("RETURN");+
+ for(i = 0; i < 10; i++){+ digits[i] = cons(Fixnum, nil);
+ digits[i]->fix = i;
+ oblist = cons(digits[i], oblist);
+ }
+ plus = intern("+");+ minus = intern("-");+
+ initsubr();
+
+ star = intern("*");+}
+
+void
+eval_repl(void)
+{+ C *e;
+
+ putprop(star, star, value);
+ for(;;){+ putc('\n', sysout);+ princ(eval(star, nil));
+ putc('\n', sysout);+ e = readsxp();
+ if(e == noval)
+ return;
+ e = eval(e, nil);
+ if(e == noval)
+ putprop(star, star, value);
+ else
+ putprop(star, e, value);
+ }
+}
+
+void
+eval_file(void)
+{+ C *e;
+ for(;;){+ e = readsxp();
+ if(e == noval)
+ return;
+ eval(e, nil);
+ }
+}
+
+void
+load(char *filename)
+{+ FILE *oldin, *f;
+ f = fopen(filename, "r");
+ if(f == nil)
+ return;
+ oldin = sysin;
+ sysin = f;
+ if(setjmp(tljmp))
+ exit(1);
+ eval_file();
+ sysin = oldin;
+ fclose(f);
+}
+
+#ifdef PLAN9
+void
+main(int, char**)
+#else
+int
+main()
+#endif
+{+#ifdef LISP32
+ /* only works on 32 bits */
+ assert(sizeof(void*) == 4);
+#else
+ /* only works on 64 bits */
+ assert(sizeof(void*) == 8);
+#endif
+
+ init();
+
+ load("lib.l");+
+// lprint(oblist);
+// fprintf(sysout, "\n");
+
+ if(setjmp(tljmp))
+ fprintf(sysout, "→\n");
+ pdp = 0;
+ alist = nil;
+ memset(&temlis, 0, sizeof(temlis));
+
+ eval_repl();
+#ifdef PLAN9
+ exits(nil);
+#else
+ return 0;
+#endif
+}
--- /dev/null
+++ b/lisp.h
@@ -1,0 +1,189 @@
+#ifdef PLAN9
+#include <u.h>
+#include <libc.h>
+#include <stdio.h>
+#include <ctype.h>
+typedef uintptr uintptr_t;
+typedef u32int uint32_t;
+typedef s32int int32_t;
+typedef u64int uint64_t;
+typedef s64int int64_t;
+#else
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdarg.h>
+#include <string.h>
+#include <ctype.h>
+#include <math.h>
+#include <setjmp.h>
+#include <assert.h>
+
+#define nil NULL
+#endif
+
+#define FIXMIN (-FIXMAX-1)
+
+/* basic data types */
+typedef uintptr_t P;
+#ifdef LISP32
+/* assume we're running on 32 bits!!! */
+typedef uint32_t word;
+typedef int32_t fixnum;
+typedef float flonum;
+#define FIXMAX ((fixnum)0x7FFFFFFF)
+#define FLOMAX 3.40282347E+38f
+enum
+{+ B2W = 32, /* bits per word */
+ C2W = B2W/8, /* character per word */
+};
+#else
+/* assume we're running on 64 bits!!! */
+typedef uint64_t word;
+typedef int64_t fixnum;
+typedef double flonum;
+#define FIXMAX ((fixnum)0x7FFFFFFFFFFFFFFF)
+#define FLOMAX 1.7976931348623157E+308
+enum
+{+ B2W = 64, /* bits per word */
+ C2W = B2W/8, /* character per word */
+};
+#endif
+
+extern FILE *sysin, *sysout, *syserr;
+
+/* static storage sizes */
+enum
+{+ NUMCONS = 32*1024,
+ NUMFW = 32*1024,
+ PDLSZ = 1024,
+};
+
+
+typedef struct C C;
+typedef union F F;
+
+/* A cons cell */
+struct C
+{+ union {+ C *a;
+ F *af;
+ P ap;
+ };
+ union {+ C *d;
+ F *df;
+ P dp;
+
+ fixnum fix;
+ flonum flo;
+ };
+};
+
+/* CAR bits */
+enum
+{+ CAR_MARK = 1,
+ CAR_ATOM = 2,
+ CAR_FIX = 4,
+ CAR_FLO = 8,
+ CAR_NUM = CAR_FIX | CAR_FLO
+};
+
+
+/* A full word */
+union F
+{+ word fw;
+ char c[C2W];
+ F *p;
+ fixnum n;
+ C *(*subr)(void);
+};
+
+
+/* free storage */
+extern C *fclist;
+extern F *fflist;
+
+/* push down list */
+extern C *pdl[PDLSZ];
+extern int pdp;
+
+/* Temporary variables automatically saved */
+typedef struct Temlis Temlis;
+struct Temlis
+{+ /* temp */
+ void *a, *b, *c;
+ /* arguments to cons */
+ void *ca;
+ void *cd;
+ /* pname */
+ void *pn;
+};
+extern Temlis temlis;
+extern C **alist;
+extern int nargs;
+extern C *oblist;
+
+typedef struct Arglist Arglist;
+struct Arglist {+ int nargs;
+ C **alist;
+ int pdp;
+};
+extern Arglist largs; /* LEXPR/LSUBR args */
+
+extern C *noval;
+extern C *t;
+extern C *value;
+extern C *expr;
+extern C *subr;
+extern C *lsubr;
+extern C *fexpr;
+extern C *fsubr;
+extern C *macro;
+extern C *funarg;
+extern C *cond;
+extern C *set;
+extern C *setq;
+extern C *go;
+extern C *retrn;
+
+void err(char *fmt, ...);
+void panic(char *fmt, ...);
+C **push(C *c);
+C *pop(void);
+
+C *cons(void *a, C *d);
+F *consw(word fw);
+C *mkfix(fixnum fix);
+C *mkflo(flonum flo);
+C *mksubr(C *(*subr)(void), int n);
+int atom(C *c);
+int fixnump(C *c);
+int flonump(C *c);
+int numberp(C *c);
+int listp(C *c);
+fixnum length(C *c);
+C *get(C *l, C *p);
+C *assq(C *x, C *y);
+C *putprop(C *l, C *p, C *ind);
+C *pair(C *x, C *y);
+C *intern(char *name);
+C *readsxp(void);
+void lprint(C *c);
+void princ(C *c);
+void printatom(C *c, void (*pnm)(C *c));
+C *eval(C *form, C *a);
+C *evlis(C *m, C *a);
+C *apply(C *fn, C *args, C *a);
+
+void gc(void);
+
+void initsubr(void);
--- /dev/null
+++ b/mem.c
@@ -1,0 +1,92 @@
+#include "lisp.h"
+
+C cstore[NUMCONS];
+F fstore[NUMFW];
+word fmark[NUMFW/B2W];
+
+void
+mark(C *c)
+{+ C *a;
+ F *f;
+ int n;
+
+tail:
+ if(c == nil)
+ return;
+
+ /* Mark full word */
+ f = (F*)c;
+ if(f >= &fstore[0] && f < &fstore[NUMFW]){+ n = f - fstore;
+ fmark[n/B2W] |= (word)1 << n%B2W;
+ return;
+ }
+
+ /* Must be a cons cell */
+ if(c >= &cstore[0] && c < &cstore[NUMCONS]){+ if(c->ap & CAR_MARK)
+ return;
+ a = c->a;
+ c->ap |= CAR_MARK;
+ if(c->ap & CAR_ATOM){+ if(c->ap & CAR_NUM)
+ return;
+ }else
+ mark(a);
+ c = c->d;
+ goto tail;
+ }
+
+ panic("invalid ptr: %p\n", c);+}
+
+void
+gc(void)
+{+ int i, j;
+ C *c, **cp;
+ F *f;
+ word m;
+ int nc, nf;
+
+ /* Mark */
+ mark(oblist);
+ for(i = 0; i < pdp; i++)
+ mark(pdl[i]);
+ for(cp = (C**)&temlis; cp < (C**)(&temlis+1); cp++)
+ mark(*cp);
+
+ /* Sweep */
+ fclist = nil;
+ nc = 0;
+ for(c = cstore; c < &cstore[NUMCONS]; c++){+ if(c->ap & CAR_MARK)
+ c->ap &= ~CAR_MARK;
+ else{+ c->a = nil;
+ c->d = fclist;
+ fclist = c;
+ nc++;
+ }
+ }
+
+ fflist = nil;
+ f = fstore;
+ nf = 0;
+ for(i = 0; i < NUMFW/B2W; i++){+ m = fmark[i];
+ fmark[i] = 0;
+ for(j = 0; j < B2W; j++){+ if(!(m&1)){+ f->p = fflist;
+ fflist = f;
+ nf++;
+ }
+ m >>= 1;
+ f++;
+ }
+ }
+
+// fprintf(syserr, "reclaimed: %d %d\n", nc, nf);
+}
--- /dev/null
+++ b/mkfile
@@ -1,0 +1,18 @@
+</$objtype/mkfile
+BIN=/$objtype/bin
+CFLAGS=$CFLAGS -DPLAN9 -DLISP$bits
+
+TARG=lisp
+OFILES=\
+ lisp.$O\
+ subr.$O\
+ mem.$O
+
+HFILES=lisp.h
+
+UPDATE=\
+ mkfile\
+ $HFILES\
+ ${OFILES:%.$O=%.c}\+
+</sys/src/cmd/mkone
--- /dev/null
+++ b/subr.c
@@ -1,0 +1,1213 @@
+#include "lisp.h"
+/*
+#include <limits.h>
+#include <float.h>
+#include <math.h>
+*/
+
+int
+floeq(flonum x, flonum y)
+{+ return fabs(x-y) < 0.000003;
+}
+
+int
+equal(C *a, C *b)
+{+ if(atom(a) != atom(b))
+ return 0;
+ if(atom(a)){+ if(fixnump(a))
+ return fixnump(b) &&
+ a->fix == b->fix;
+ if(flonump(a))
+ return flonump(b) &&
+ floeq(a->flo, b->flo);
+ return a == b;
+ }
+ return equal(a->a, b->a)
+ && equal(a->d, b->d);
+}
+
+/* this is a bit ugly... */
+int
+getnumcase(C *lt, C *rt)
+{+ int type;
+ type = 0;
+ if(fixnump(lt))
+ {}+ else if(flonump(lt))
+ type |= 1;
+ else
+ type |= ~0;
+ if(fixnump(rt))
+ {}+ else if(flonump(rt))
+ type |= 2;
+ else
+ type |= ~0;
+ return type;
+}
+
+/* Types */
+
+C *atom_subr(void){+ return atom(alist[0]) ? t : nil;
+}
+C *fixp_subr(void){+ return fixnump(alist[0]) ? t : nil;
+}
+C *floatp_subr(void){+ return flonump(alist[0]) ? t : nil;
+}
+C *numberp_subr(void){+ return numberp(alist[0]) ? t : nil;
+}
+
+/* Basics */
+
+C *eval_subr(void){+ nargs = 0;
+ return eval(alist[0], alist[1]);
+}
+C *apply_subr(void){+ nargs = 0;
+ return apply(alist[0], alist[1], alist[2]);
+}
+C *quote_fsubr(void){+ if(alist[0] == nil)
+ err("error: arg count");+ return alist[0]->a;
+}
+C *function_fsubr(void){+ if(alist[0] == nil)
+ err("error: arg count");+ return cons(funarg, cons(alist[0]->a, cons(alist[1], nil)));
+}
+C *comment_fsubr(void){+ return noval;
+}
+C *prog2_lsubr(void){+ if(largs.nargs < 2)
+ err("error: arg count");+ return largs.alist[2];
+}
+C *progn_lsubr(void){+ if(largs.nargs < 1)
+ err("error: arg count");+ return largs.alist[largs.nargs];
+}
+C *arg_subr(void){+ fixnum n;
+ if(!fixnump(alist[0]))
+ err("error: not a fixnum");+ n = alist[0]->fix;
+ if(n < 1 || n > largs.nargs)
+ err("error: arg out of bounds");+ return largs.alist[n];
+}
+
+/* List functions */
+
+C *car(C *pair){+ if(pair == nil)
+ return nil;
+ if(numberp(pair))
+ err("error: not a pair");+ return pair->a;
+}
+C *cdr(C *pair){+ if(pair == nil)
+ return nil;
+ if(numberp(pair))
+ err("error: not a pair");+ return pair->d;
+}
+C *car_subr(void){ return car(alist[0]); }+C *cdr_subr(void){ return cdr(alist[0]); }+C *caar_subr(void){ return car(car(alist[0])); }+C *cadr_subr(void){ return car(cdr(alist[0])); }+C *cdar_subr(void){ return cdr(car(alist[0])); }+C *cddr_subr(void){ return cdr(cdr(alist[0])); }+C *caaar_subr(void){ return car(car(car(alist[0]))); }+C *caadr_subr(void){ return car(car(cdr(alist[0]))); }+C *cadar_subr(void){ return car(cdr(car(alist[0]))); }+C *caddr_subr(void){ return car(cdr(cdr(alist[0]))); }+C *cdaar_subr(void){ return cdr(car(car(alist[0]))); }+C *cdadr_subr(void){ return cdr(car(cdr(alist[0]))); }+C *cddar_subr(void){ return cdr(cdr(car(alist[0]))); }+C *cdddr_subr(void){ return cdr(cdr(cdr(alist[0]))); }+C *caaaar_subr(void){ return car(car(car(car(alist[0])))); }+C *caaadr_subr(void){ return car(car(car(cdr(alist[0])))); }+C *caadar_subr(void){ return car(car(cdr(car(alist[0])))); }+C *caaddr_subr(void){ return car(car(cdr(cdr(alist[0])))); }+C *cadaar_subr(void){ return car(cdr(car(car(alist[0])))); }+C *cadadr_subr(void){ return car(cdr(car(cdr(alist[0])))); }+C *caddar_subr(void){ return car(cdr(cdr(car(alist[0])))); }+C *cadddr_subr(void){ return car(cdr(cdr(cdr(alist[0])))); }+C *cdaaar_subr(void){ return cdr(car(car(car(alist[0])))); }+C *cdaadr_subr(void){ return cdr(car(car(cdr(alist[0])))); }+C *cdadar_subr(void){ return cdr(car(cdr(car(alist[0])))); }+C *cdaddr_subr(void){ return cdr(car(cdr(cdr(alist[0])))); }+C *cddaar_subr(void){ return cdr(cdr(car(car(alist[0])))); }+C *cddadr_subr(void){ return cdr(cdr(car(cdr(alist[0])))); }+C *cdddar_subr(void){ return cdr(cdr(cdr(car(alist[0])))); }+C *cddddr_subr(void){ return cdr(cdr(cdr(cdr(alist[0])))); }+C *eq_subr(void){+ return alist[0] == alist[1] ? t : nil;
+}
+C *equal_subr(void){+ return equal(alist[0], alist[1]) ? t : nil;
+}
+C *assoc_subr(void){+ C *l;
+ if(!listp(alist[1]))
+ err("error: no list");+ for(l = alist[1]; l != nil; l = l->d)
+ if(equal(l->a->a, alist[0]))
+ return l->a;
+ return nil;
+}
+C *assq_subr(void){+ if(!listp(alist[1]))
+ err("error: no list");+ return assq(alist[0], alist[1]);
+}
+C *sassoc_subr(void){+ C *l;
+ l = assoc_subr();
+ return l != nil ? l : apply(alist[2], nil, nil);
+}
+C *sassq_subr(void){+ C *l;
+ l = assq_subr();
+ return l != nil ? l : apply(alist[2], nil, nil);
+}
+C *last_subr(void){+ C *l;
+ if(!listp(alist[0]))
+ err("error: no list");+ for(l = alist[0]; l != nil; l = l->d)
+ if(atom(l->d))
+ return l;
+ return nil;
+}
+C *length_subr(void){+ return mkfix(length(alist[0]));
+}
+C *member_subr(void){+ C *l;
+ for(l = alist[1]; l != nil; l = l->d){+ if(atom(l))
+ err("error: no list");+ if(equal(l->a, alist[0]))
+ return t;
+ }
+ return nil;
+}
+C *memq_subr(void){+ C *l;
+ for(l = alist[1]; l != nil; l = l->d){+ if(atom(l))
+ err("error: no list");+ if(l->a == alist[0])
+ return t;
+ }
+ return nil;
+}
+C *null_subr(void){+ return alist[0] == nil ? t : nil;
+}
+
+/* Creating list structure */
+
+C *cons_subr(void){+ return cons(alist[0], alist[1]);
+}
+C *ncons_subr(void){+ return cons(alist[0], nil);
+}
+C *xcons_subr(void){+ return cons(alist[1], alist[0]);
+}
+C *list_fsubr(void){+ return evlis(alist[0], alist[1]) ;
+}
+C *append_subr(void){+ C *l, **p;
+ assert(temlis.a == nil);
+ p = (C**)&temlis.a;
+ for(l = alist[0]; l != nil; l = l->d){+ if(atom(l))
+ err("error: no list");+ *p = cons(l->a, nil);
+ p = &(*p)->d;
+ }
+ *p = alist[1];
+ l = temlis.a;
+ temlis.a = nil;
+ return l;
+}
+C *reverse_subr(void){+ C *l;
+ assert(temlis.a == nil);
+ for(l = alist[0]; l != nil; l = l->d){+ if(atom(l))
+ err("error: no list");+ temlis.a = cons(l->a, temlis.a);
+ }
+ l = temlis.a;
+ temlis.a = nil;
+ return l;
+}
+
+/* Modifying list structure */
+
+C *rplaca_subr(void){+ if(atom(alist[0]))
+ err("error: atom");+ alist[0]->a = alist[1];
+ return alist[0];
+}
+C *rplacd_subr(void){+ if(atom(alist[0])) /* this could work on a symbolic atom */
+ err("error: atom");+ alist[0]->d = alist[1];
+ return alist[0];
+}
+C *nconc_subr(void){+ C *l;
+ for(l = alist[0]; l != nil; l = l->d){+ if(atom(l))
+ err("error: no list");+ if(l->d == nil){+ l->d = alist[1];
+ break;
+ }
+ }
+ return alist[0];
+}
+C *nreverse_subr(void){+
+ C *l, *n, *last;
+ last = nil;
+ for(l = alist[0]; l != nil; l = n){+ if(atom(l))
+ err("error: no list");+ n = l->d;
+ l->d = last;
+ last = l;
+ }
+ return last;
+}
+
+/* Boolean logic */
+
+C *and_fsubr(void){+ C *l;
+ int ret;
+ ret = 1;
+ for(l = alist[0]; l != nil; l = l->d)
+ if(eval(l->a, alist[1]) == nil){+ ret = 0;
+ break;
+ }
+ return ret ? t : nil;
+}
+C *or_fsubr(void){+ C *l;
+ int ret;
+ ret = 0;
+ for(l = alist[0]; l != nil; l = l->d)
+ if(eval(l->a, alist[1]) != nil){+ ret = 1;
+ break;
+ }
+ return ret ? t : nil;
+}
+
+/* Symbols, values */
+
+C *setq_fsubr(void){+ C *tt, *l, *last;
+ last = nil;
+ for(l = alist[0]; l != nil; l = l->d->d){+ tt = l->a;
+ if(!atom(tt))
+ err("error: need atom");+ tt = assq(tt, alist[1]);
+ if(tt == nil)
+ err("error: undefined");+ tt->d = last = eval(l->d->a, alist[1]);
+ }
+ return last;
+}
+/* Has to be FSUBR here, also extended syntax */
+C *set_fsubr(void){+ C *tt, *l, *last;
+ last = nil;
+ for(l = alist[0]; l != nil; l = l->d->d){+ tt = eval(l->a, alist[1]);
+ if(!atom(tt))
+ err("error: need atom");+ tt = assq(tt, alist[1]);
+ if(tt == nil)
+ err("error: undefined");+ tt->d = last = eval(l->d->a, alist[1]);
+ }
+ return last;
+}
+
+/* slightly advanced cset functions */
+C *cset_subr(void){+ return putprop(alist[0], alist[1], value);
+}
+C *csetq_fsubr(void){+ C *l;
+ for(l = alist[0]; l != nil; l = l->d->d){+ if(!atom(l->a))
+ err("error: need atom");+ if(l->d == nil){+ putprop(l->a, nil, value);
+ break;
+ }
+ putprop(l->a, eval(l->d->a, alist[1]), value);
+ }
+ return noval;
+}
+
+/* Property list */
+
+C *get_subr(void){+ return get(alist[0], alist[1]);
+/*
+ C *l;
+ for(l = alist[0]; l != nil; l = l->d)
+ if(l->a == alist[1])
+ return l->d->a;
+ return nil;
+*/
+}
+C *putprop_subr(void){+ return putprop(alist[0], alist[1], alist[2]);
+}
+C *defprop_fsubr(void){+ if(length(alist[0]) != 3)
+ err("error: arg count");+ return putprop(alist[0]->a, alist[0]->d->a, alist[0]->d->d->a);
+}
+C *remprop_subr(void){+ C *l, **p;
+ p = &alist[0]->d;
+ for(l = *p; l != nil; l = l->d){+ if(l->a == alist[1]){+ *p = l->d->d;
+ break;
+ }
+ p = &(*p)->d;
+ }
+ return nil;
+}
+
+/* Number predicates */
+
+C *zerop_subr(void){+ int res;
+ res = 0;
+ if(fixnump(alist[0]))
+ res = alist[0]->fix == 0;
+ else if(flonump(alist[0]))
+ res = floeq(alist[0]->flo, 0.0);
+ else
+ err("error: not a number");+ return res ? t : nil;
+}
+C *plusp_subr(void){+ int res;
+ res = 0;
+ if(fixnump(alist[0]))
+ res = alist[0]->fix > 0;
+ else if(flonump(alist[0]))
+ res = alist[0]->flo > 0.0;
+ else
+ err("error: not a number");+ return res ? t : nil;
+}
+C *minusp_subr(void){+ int res;
+ res = 0;
+ if(fixnump(alist[0]))
+ res = alist[0]->fix < 0;
+ else if(flonump(alist[0]))
+ res = alist[0]->flo < 0.0;
+ else
+ err("error: not a number");+ return res ? t : nil;
+}
+C *greaterp_lsubr(void){+ C *lt, *rt;
+ int i;
+
+ if(largs.nargs < 2)
+ err("error: arg count");+ for(i = 1; i < largs.nargs; i++){+ lt = largs.alist[i];
+ rt = largs.alist[i+1];
+ switch(getnumcase(lt, rt)){+ case 0:
+ if(lt->fix <= rt->fix)
+ return nil;
+ break;
+ case 1:
+ if(lt->flo <= rt->fix)
+ return nil;
+ break;
+ case 2:
+ if(lt->fix <= rt->flo)
+ return nil;
+ break;
+ case 3:
+ if(lt->flo <= rt->flo)
+ return nil;
+ break;
+ default:
+ err("error: not a number");+ return nil;
+ }
+ }
+ return t;
+}
+C *lessp_lsubr(void){+ C *lt, *rt;
+ int i;
+
+ if(largs.nargs < 2)
+ err("error: arg count");+ for(i = 1; i < largs.nargs; i++){+ lt = largs.alist[i];
+ rt = largs.alist[i+1];
+ switch(getnumcase(lt, rt)){+ case 0:
+ if(lt->fix >= rt->fix)
+ return nil;
+ break;
+ case 1:
+ if(lt->flo >= rt->fix)
+ return nil;
+ break;
+ case 2:
+ if(lt->fix >= rt->flo)
+ return nil;
+ break;
+ case 3:
+ if(lt->flo >= rt->flo)
+ return nil;
+ break;
+ default:
+ err("error: not a number");+ return nil;
+ }
+ }
+ return t;
+}
+C *max_lsubr(void){+ int i;
+ C *tt;
+ fixnum fix;
+ flonum flo;
+ int type;
+
+ fix = FIXMIN;
+ flo = -FLOMAX;
+ type = 0; // fix;
+ for(i = 1; i <= largs.nargs; i++){+ tt = largs.alist[i];
+ if(fixnump(tt))
+ fix = tt->fix > fix ? tt->fix : fix;
+ else if(flonump(tt)){+ flo = tt->flo > flo ? tt->flo : flo;
+ type = 1;
+ }else
+ err("error: not a number");+ }
+ return type == 0 ? mkfix(fix) : mkflo(fix > flo ? fix : flo);
+}
+C *min_lsubr(void){+ int i;
+ C *tt;
+ fixnum fix;
+ flonum flo;
+ int type;
+
+ fix = FIXMAX;
+ flo = FLOMAX;
+ type = 0; // fix;
+ for(i = 1; i <= largs.nargs; i++){+ tt = largs.alist[i];
+ if(fixnump(tt))
+ fix = tt->fix < fix ? tt->fix : fix;
+ else if(flonump(tt)){+ flo = tt->flo < flo ? tt->flo : flo;
+ type = 1;
+ }else
+ err("error: not a number");+ }
+ return type == 0 ? mkfix(fix) : mkflo(fix < flo ? fix : flo);
+}
+
+/* Arithmetic */
+
+C *plus_lsubr(void){+ int i;
+ C *tt;
+ fixnum fix;
+ flonum flo;
+ int type;
+
+ fix = 0;
+ flo = 0.0;
+ type = 0; // fix;
+ for(i = 1; i <= largs.nargs; i++){+ tt = largs.alist[i];
+ if(fixnump(tt))
+ fix += tt->fix;
+ else if(flonump(tt)){+ flo += tt->flo;
+ type = 1;
+ }else
+ err("error: not a number");+ }
+ return type == 0 ? mkfix(fix) : mkflo(fix+flo);
+}
+C *difference_lsubr(void){+ int i;
+ C *tt;
+ fixnum fix;
+ flonum flo;
+ int type;
+ int first;
+
+ first = 1;
+ fix = 0;
+ flo = 0.0;
+ type = 0; // fix;
+ if(largs.nargs == 0)
+ err("error: not enough args");+ for(i = 1; i <= largs.nargs; i++){+ tt = largs.alist[i];
+ if(fixnump(tt))
+ fix += first ? tt->fix : -tt->fix;
+ else if(flonump(tt)){+ flo += first ? tt->flo : -tt->flo;
+ type = 1;
+ }else
+ err("error: not a number");+ first = 0;
+ }
+ if(largs.nargs == 1)
+ return type == 0 ? mkfix(-fix) : mkflo(-fix-flo);
+ return type == 0 ? mkfix(fix) : mkflo(fix+flo);
+}
+C *times_lsubr(void){+ int i;
+ C *tt;
+ fixnum fix;
+ flonum flo;
+ int type;
+
+ fix = 1;
+ flo = 1.0;
+ type = 0; // fix;
+ for(i = 1; i <= largs.nargs; i++){+ tt = largs.alist[i];
+ if(fixnump(tt))
+ fix *= tt->fix;
+ else if(flonump(tt)){+ flo *= tt->flo;
+ type = 1;
+ }else
+ err("error: not a number");+ }
+ return type == 0 ? mkfix(fix) : mkflo(fix*flo);
+}
+C *quotient_lsubr(void){+ int i;
+ C *tt;
+ fixnum fix;
+ flonum flo;
+ int type;
+
+ fix = 1;
+ flo = 1.0;
+ type = 0; // fix;
+ if(largs.nargs == 0)
+ return mkfix(1);
+ for(i = 2; i <= largs.nargs; i++){+ tt = largs.alist[i];
+ if(fixnump(tt))
+ fix *= tt->fix;
+ else if(flonump(tt)){+ flo *= tt->flo;
+ type = 1;
+ }else
+ err("error: not a number");+ }
+
+ tt = largs.alist[1];
+ if(largs.nargs == 1){+ if(fixnump(tt))
+ return mkfix(1/tt->fix);
+ else if(flonump(tt))
+ return mkflo(1.0/tt->flo);
+ else
+ err("error: not a number");+ }
+
+ if(fixnump(tt))
+ return type == 0 ? mkfix(tt->fix/fix) : mkflo(tt->fix/(fix*flo));
+ else if(flonump(tt))
+ return type == 0 ? mkflo(tt->flo/fix) : mkflo(tt->flo/(fix*flo));
+ else
+ err("error: not a number");+ /* can't happen */
+ return nil;
+}
+C *add1_subr(void){+ if(fixnump(alist[0]))
+ return mkfix(alist[0]->fix+1);
+ if(flonump(alist[0]))
+ return mkflo(alist[0]->flo+1.0);
+ err("error: not a number");+ return nil;
+}
+C *sub1_subr(void){+ if(fixnump(alist[0]))
+ return mkfix(alist[0]->fix-1);
+ if(flonump(alist[0]))
+ return mkflo(alist[0]->flo-1.0);
+ err("error: not a number");+ return nil;
+}
+C *remainder_subr(void){+ switch(getnumcase(alist[0], alist[1])){+ case 0:
+ if(alist[1]->fix == 0)
+ err("error: division by zero");+ return mkfix(alist[0]->fix % alist[1]->fix);
+ break;
+ case 1:
+ return mkflo(fmod(alist[0]->flo, alist[1]->fix));
+ break;
+ case 2:
+ return mkflo(fmod(alist[0]->fix, alist[1]->flo));
+ break;
+ case 3:
+ return mkflo(fmod(alist[0]->flo, alist[1]->flo));
+ break;
+ default:
+ err("error: not a number");+ return nil;
+ }
+}
+C *expt_subr(void){+ switch(getnumcase(alist[0], alist[1])){+ case 0:
+ if(alist[1]->fix == 0)
+ err("error: division by zero");+ return mkfix(pow(alist[0]->fix, alist[1]->fix));
+ break;
+ case 1:
+ return mkflo(exp(log(alist[0]->flo) * alist[1]->fix));
+ break;
+ case 2:
+ return mkflo(exp(log(alist[0]->fix) * alist[1]->flo));
+ break;
+ case 3:
+ return mkflo(exp(log(alist[0]->flo) * alist[1]->flo));
+ break;
+ default:
+ err("error: not a number");+ return nil;
+ }
+}
+
+/* Bitwise operations */
+
+C *logior_lsubr(void){+ int i;
+ C *tt;
+ fixnum fix;
+
+ fix = 0;
+ for(i = 1; i <= largs.nargs; i++){+ tt = largs.alist[i];
+ if(fixnump(tt))
+ fix |= tt->fix;
+ else
+ err("error: not a fixnum");+ }
+ return mkfix(fix);
+}
+C *logand_lsubr(void){+ int i;
+ C *tt;
+ fixnum fix;
+
+ fix = ~0;
+ for(i = 1; i <= largs.nargs; i++){+ tt = largs.alist[i];
+ if(fixnump(tt))
+ fix &= tt->fix;
+ else
+ err("error: not a fixnum");+ }
+ return mkfix(fix);
+}
+C *logxor_lsubr(void){+ int i;
+ C *tt;
+ fixnum fix;
+
+ fix = 0;
+ for(i = 1; i <= largs.nargs; i++){+ tt = largs.alist[i];
+ if(fixnump(tt))
+ fix ^= tt->fix;
+ else
+ err("error: not a fixnum");+ }
+ return mkfix(fix);
+}
+C *lsh_subr(void){+ if(!fixnump(alist[0]) || !fixnump(alist[1]))
+ err("error: not a fixnum");+ if(alist[1]->fix < 0)
+ return mkfix((word)alist[0]->fix >> -alist[1]->fix);
+ else
+ return mkfix((word)alist[0]->fix << alist[1]->fix);
+}
+
+/* Mapping */
+
+C *maplist_subr(void){+ C *l, *c, **p;
+ p = push(nil);
+ for(l = alist[1]; l != nil; l = l->d){+ push(c = cons(l, nil));
+ c->a = apply(alist[0], c, nil);
+ c->d = nil;
+ *p = pop();
+ p = &(*p)->d;
+ }
+ return pop();
+}
+C *mapcar_subr(void){+ C *l, *c, **p;
+ p = push(nil);
+ for(l = alist[1]; l != nil; l = l->d){+ push(c = cons(l->a, nil));
+ c->a = apply(alist[0], c, nil);
+ c->d = nil;
+ *p = pop();
+ p = &(*p)->d;
+ }
+ return pop();
+}
+C *map_subr(void){+ C *l, *a;
+ push(a = cons(nil, nil));
+ for(l = alist[1]; l != nil; l = l->d){+ a->a = l;
+ a->d = nil;
+ apply(alist[0], a, nil);
+ }
+ pop();
+ return nil;
+}
+C *mapc_subr(void){+ C *l, *a;
+ push(a = cons(nil, nil));
+ for(l = alist[1]; l != nil; l = l->d){+ a->a = l->a;
+ a->d = nil;
+ apply(alist[0], a, nil);
+ }
+ pop();
+ return nil;
+}
+C *mapcon_subr(void){+ C *l, *a, **p;
+ p = push(nil);
+ push(a = cons(nil, nil));
+ for(l = alist[1]; l != nil; l = l->d){+ a->a = l;
+ a->d = nil;
+ *p = apply(alist[0], a, nil);
+ if(*p == nil)
+ err("error: nil in mapcon");+ for(; *p != nil; p = &(*p)->d)
+ if(atom(*p))
+ err("error: no list");+ }
+ pop();
+ return pop();
+}
+C *mapcan_subr(void){+ C *l, *a, **p;
+ p = push(nil);
+ push(a = cons(nil, nil));
+ for(l = alist[1]; l != nil; l = l->d){+ a->a = l->a;
+ a->d = nil;
+ *p = apply(alist[0], a, nil);
+ if(*p == nil)
+ err("error: nil in mapcon");+ for(; *p != nil; p = &(*p)->d)
+ if(atom(*p))
+ err("error: no list");+ }
+ pop();
+ return pop();
+}
+
+/* IO */
+
+C *read_subr(void){+ return readsxp();
+}
+C *prin1_subr(void){+ lprint(alist[0]);
+ return t;
+}
+C *print_subr(void){+ fprintf(sysout, "\n");
+ lprint(alist[0]);
+ return t;
+}
+C *princ_subr(void){+ princ(alist[0]);
+ return t;
+}
+C *terpri_subr(void){+ fprintf(sysout, "\n");
+ return nil;
+}
+
+
+/*
+ * LISP 1.5 leftover
+ */
+
+C *attrib_subr(void){+ C *l;
+ for(l = alist[0]; l != nil; l = l->d){+// if(atom(l)) // have to allow this for p-lists
+ if(numberp(l))
+ err("error: no list");+ if(l->d == nil){+ l->d = alist[1];
+ break;
+ }
+ }
+ return alist[1];
+}
+C *prop_subr(void){+ C *l;
+ for(l = alist[0]; l != nil; l = l->d)
+ if(l->a == alist[1])
+ return l->d;
+ return apply(alist[2], nil, nil);
+}
+C *pair_subr(void){+ return pair(alist[0], alist[1]);
+}
+C *copy_subr(void){+ C *l, **p;
+ assert(temlis.a == nil);
+ p = (C**)&temlis.a;
+ for(l = alist[0]; l != nil; l = l->d){+ if(atom(l))
+ err("error: no list");+ *p = cons(l->a, nil);
+ p = &(*p)->d;
+ }
+ l = temlis.a;
+ temlis.a = nil;
+ return l;
+}
+C *efface_subr(void){+ C *l, **p;
+ p = &alist[1];
+ for(l = alist[1]; l != nil; l = l->d){+ if(atom(l))
+ err("error: no list");+ if(equal(l->a, alist[0])){+ *p = l->d;
+ break;
+ }
+ p = &(*p)->d;
+ }
+ return alist[1];
+}
+
+
+
+/* Prog feature */
+
+typedef struct Prog Prog;
+struct Prog
+{+ C *a;
+ C *go;
+ C *pc;
+ C *ret;
+};
+
+void
+setq_prog(Prog *prog, C *form)
+{+ C *tt;
+ if(form == nil)
+ err("error: arg count");+ if(!atom(form->a))
+ err("error: no atom");+ tt = assq(form->a, prog->a);
+ if(tt == nil)
+ err("error: undefined");+ tt->d = eval(form->d->a, prog->a);
+}
+
+void
+set_prog(Prog *prog, C *form)
+{+ C *tt;
+ if(form == nil)
+ err("error: arg count");+ tt = eval(form->a, prog->a);
+ if(!atom(tt))
+ err("error: no atom");+ tt = assq(tt, prog->a);
+ if(tt == nil)
+ err("error: undefined");+ tt->d = eval(form->d->a, prog->a);
+}
+
+void
+progstmt(Prog *prog, C *form)
+{+ C *tt;
+ C *pc;
+
+ if(atom(form))
+ {}+ else if(form->a == setq)
+ setq_prog(prog, form->d);
+ else if(form->a == set)
+ set_prog(prog, form->d);
+ else if(form->a == cond){+ for(form = form->d; form != nil; form = form->d)
+ if(eval(form->a->a, prog->a) != nil){+ for(pc = form->a->d; pc != nil; pc = pc->d)
+ progstmt(prog, pc->a);
+ return;
+ }
+ }else if(form->a == go){+ if(form->d == nil)
+ err("error: arg count");+ if(tt = assq(form->d->a, prog->go), tt == nil)
+ err("error: undefined label");+ prog->pc = tt->d;
+ }else if(form->a == retrn){+ if(form->d == nil)
+ prog->ret = nil;
+ else
+ prog->ret = eval(form->d->a, prog->a);
+ prog->pc = nil;
+ }else
+ eval(form, prog->a);
+}
+
+C *prog_fsubr(void){+ Prog prog;
+
+ C *p;
+ C **ap;
+
+ prog.pc = alist[0]->d;
+
+ /* build a-list */
+ assert(temlis.a == nil);
+ ap = (C**)&temlis.a;
+ for(p = alist[0]->a; p != nil; p = p->d){+ *ap = cons(cons(p->a, nil), nil);
+ ap = &(*ap)->d;
+ }
+ *ap = alist[1];
+ alist[1] = temlis.a;
+ prog.a = alist[1];
+ temlis.a = nil;
+
+ /* build go-list */
+ for(p = prog.pc; p != nil; p = p->d)
+ if(atom(p->a))
+ temlis.a = cons(p, temlis.a);
+ prog.go = temlis.a;
+ temlis.a = nil;
+ alist[nargs++] = prog.go;
+
+ /* execute */
+ prog.ret = nil;
+ while(prog.pc != nil){+ p = prog.pc->a;
+ prog.pc = prog.pc->d;
+ progstmt(&prog, p);
+ }
+
+ return prog.ret;
+}
+
+void
+initsubr(void)
+{+ C *a;
+
+ putprop(t, t, value);
+
+#define SUBR(str, func, narg) \
+ a = intern(str); \
+ putprop(a, mksubr(func, narg), subr);
+#define LSUBR(str, func) \
+ a = intern(str); \
+ putprop(a, mksubr(func, -1), lsubr);
+#define FSUBR(str, func) \
+ a = intern(str); \
+ putprop(a, (C*)consw((word)func), fsubr);
+
+ SUBR("ATOM", atom_subr, 1)+ SUBR("FIXP", fixp_subr, 1)+ SUBR("FLOATP", floatp_subr, 1)+ SUBR("NUMBERP", numberp_subr, 1)+
+ SUBR("APPLY", apply_subr, 3)+ SUBR("EVAL", eval_subr, 2)+ FSUBR("QUOTE", quote_fsubr)+ FSUBR("FUNCTION", function_fsubr)+ FSUBR("COMMENT", comment_fsubr)+ LSUBR("PROG2", prog2_lsubr)+ LSUBR("PROGN", progn_lsubr)+ SUBR("ARG", arg_subr, 1)+
+ SUBR("CAR", car_subr, 1)+ SUBR("CDR", cdr_subr, 1)+ SUBR("CAAR", caar_subr, 1)+ SUBR("CADR", cadr_subr, 1)+ SUBR("CDAR", cdar_subr, 1)+ SUBR("CDDR", cddr_subr, 1)+ SUBR("CAAAR", caaar_subr, 1)+ SUBR("CAADR", caadr_subr, 1)+ SUBR("CADAR", cadar_subr, 1)+ SUBR("CADDR", caddr_subr, 1)+ SUBR("CDAAR", cdaar_subr, 1)+ SUBR("CDADR", cdadr_subr, 1)+ SUBR("CDDAR", cddar_subr, 1)+ SUBR("CDDDR", cdddr_subr, 1)+ SUBR("CAAAAR", caaaar_subr, 1)+ SUBR("CAAADR", caaadr_subr, 1)+ SUBR("CAADAR", caadar_subr, 1)+ SUBR("CAADDR", caaddr_subr, 1)+ SUBR("CADAAR", cadaar_subr, 1)+ SUBR("CADADR", cadadr_subr, 1)+ SUBR("CADDAR", caddar_subr, 1)+ SUBR("CADDDR", cadddr_subr, 1)+ SUBR("CDAAAR", cdaaar_subr, 1)+ SUBR("CDAADR", cdaadr_subr, 1)+ SUBR("CDADAR", cdadar_subr, 1)+ SUBR("CDADDR", cdaddr_subr, 1)+ SUBR("CDDAAR", cddaar_subr, 1)+ SUBR("CDDADR", cddadr_subr, 1)+ SUBR("CDDDAR", cdddar_subr, 1)+ SUBR("CDDDDR", cddddr_subr, 1)+ SUBR("EQ", eq_subr, 2)+ SUBR("EQUAL", equal_subr, 2)+ SUBR("ASSOC", assoc_subr, 2)+ SUBR("ASSQ", assq_subr, 2)+ SUBR("SASSOC", sassoc_subr, 3)+ SUBR("SASSQ", sassq_subr, 3)+ SUBR("LAST", last_subr, 1)+ SUBR("LENGTH", length_subr, 1)+ SUBR("MEMBER", member_subr, 2)+ SUBR("MEMQ", memq_subr, 2)+ SUBR("NOT", null_subr, 1)+ SUBR("NULL", null_subr, 1)+
+ SUBR("CONS", cons_subr, 2)+ SUBR("NCONS", ncons_subr, 1)+ SUBR("XCONS", xcons_subr, 2)+ FSUBR("LIST", list_fsubr)+ SUBR("APPEND", append_subr, 2)+ SUBR("REVERSE", reverse_subr, 1)+
+ SUBR("RPLACA", rplaca_subr, 2)+ SUBR("RPLACD", rplacd_subr, 2)+ SUBR("NCONC", nconc_subr, 2)+ SUBR("NREVERSE", nreverse_subr, 1)+
+ FSUBR("AND", and_fsubr)+ FSUBR("OR", or_fsubr)+ FSUBR("PROG", prog_fsubr)+
+ FSUBR("SETQ", setq_fsubr)+ FSUBR("SET", set_fsubr)+ SUBR("CSET", cset_subr, 2)+ FSUBR("CSETQ", csetq_fsubr)+
+ SUBR("GET", get_subr, 2)+ SUBR("PUTPROP", putprop_subr, 3)+ FSUBR("DEFPROP", defprop_fsubr)+ SUBR("REMPROP", remprop_subr, 2)+
+ SUBR("ZEROP", zerop_subr, 1)+ SUBR("PLUSP", plusp_subr, 1)+ SUBR("MINUSP", minusp_subr, 1)+ LSUBR("<", lessp_lsubr)+ LSUBR(">", greaterp_lsubr)+ LSUBR("MAX", max_lsubr)+ LSUBR("MIN", min_lsubr)+
+ LSUBR("+", plus_lsubr)+ LSUBR("-", difference_lsubr)+ LSUBR("*", times_lsubr)+ LSUBR("/", quotient_lsubr)+ SUBR("1+", add1_subr, 1)+ SUBR("1-", sub1_subr, 1)+ SUBR("\\", remainder_subr, 2)+ SUBR("EXPT", expt_subr, 2)+
+ LSUBR("LOGIOR", logior_lsubr)+ LSUBR("LOGAND", logand_lsubr)+ LSUBR("LOGXOR", logxor_lsubr)+ SUBR("LSH", lsh_subr, 2)+
+ SUBR("MAPLIST", maplist_subr, 2)+ SUBR("MAPCAR", mapcar_subr, 2)+ SUBR("MAP", map_subr, 2)+ SUBR("MAPC", mapc_subr, 2)+ SUBR("MAPCON", mapcon_subr, 2)+ SUBR("MAPCAN", mapcan_subr, 2)+
+ SUBR("READ", read_subr, 0)+ SUBR("PRIN1", prin1_subr, 1)+ SUBR("PRINT", print_subr, 1)+ SUBR("PRINC", princ_subr, 1)+ SUBR("TERPRI", terpri_subr, 0)+
+
+
+
+ SUBR("ATTRIB", attrib_subr, 2)+ SUBR("PROP", prop_subr, 3)+ SUBR("PAIR", pair_subr, 2)+ SUBR("COPY", copy_subr, 1)+ SUBR("EFFACE", efface_subr, 2)+}