shithub: mlisp

ref: 442728dece582ebc742f771362acf4ea861a812f
dir: /lisp.c/

#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);
		}
	}
	return nil;
}

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(&prog, 0, sizeof(prog));
	memset(&temlis, 0, sizeof(temlis));

	eval_repl();
#ifdef PLAN9
	exits(nil);
#else
	return 0;
#endif
}