shithub: mlisp

ref: 962acb87f81bc9ccdd5428c6561dd9cf6f696895
dir: /lisp.c/

#include "lisp.h"

#ifdef PLAN9
void exit(int n)
{
	if(n == 0)
		exits(nil);
	exits("error");
}
#endif

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);
void *String = (void*)(CAR_ATOM|CAR_STR);

/* absence of a value */
C *noval = (C*)~0;

/* some important atoms */
C *pname;
C *value;
C *unbound;	// not interned
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];

jmp_buf errlabel[10];
int errsp;

/* print error and jmp back into toplevel */
void
err(char *fmt, ...)
{
	va_list ap;
	va_start(ap, fmt);
	vfprintf(stderr, fmt, ap);
	fprintf(stderr, "\n");
	va_end(ap);
	longjmp(errlabel[errsp], 1);
}

void
panic(char *fmt, ...)
{
	va_list ap;
	va_start(ap, fmt);
	vfprintf(stderr, fmt, ap);
	fprintf(stderr, "\n");
	va_end(ap);
#ifdef PLAN9
	exits("panic");
#else
	exit(1);
#endif
}

void*
emalloc(ulong size)
{
	char *p;
	p = malloc(size);
	if(p == nil)
		panic("out of memory");
	return p;
}
void*
erealloc(void *p, ulong size)
{
	p = realloc(p, size);
	if(p == nil)
		panic("out of memory");
	return p;
}
char*
estrdup(char *s)
{
	char *t;
	t = emalloc(strlen(s)+1);
	strcpy(t, s);
	return t;
}

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];
}

/*
 * Type constructors
 */

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*
mkstr(char *s)
{
	C *c;
	c = cons(String, nil);
	c->str = estrdup(s);
	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);
}

C*
mksym(char *name)
{
	return cons(Atom, cons(pname, cons(mkstr(name), nil)));
}

/*
 * Type predicates
 */

int
atom(C *c)
{
	return c == nil || c->ap & CAR_ATOM;
}

int
symbolp(C *c)
{
	return c == nil || (c->ap&~CAR_MARK) == 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);
}

int
stringp(C *c)
{
	return c != nil && c->ap & CAR_ATOM && c->ap & CAR_STR;
}

/*
 * Elementary functions
 */

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;
}

C*
get(C *l, C *p)
{
	if(l == nil || !(listp(l) || symbolp(l)))
		return 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*
getpname(C *a)
{
	return get(a, pname);
}

C*
symeval(C *s)
{
	for(s = s->d; s != nil; s = s->d->d)
		if(s->a == value)
			return s->d->a;
	return unbound;
}

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 || !symbolp(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;
	// args are GC-safe, only called by apply
	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;
	return m;
}

C*
findsym(char *name)
{
	C *c;
	C *pn;
	for(c = oblist; c != nil; c = c->d){
		if(!symbolp(c->a))
			continue;
		pn = getpname(c->a);
		if(pn == nil)
			continue;
		assert(stringp(pn));
		if(strcmp(pn->str, name) == 0)
			return c->a;
	}
	return nil;
}

C*
intern(char *name)
{
	C *c;
	c = findsym(name);
	if(c == nil){
		c = mksym(name);
		oblist = cons(c, oblist);
	}
	return c;
}

/*
 * 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 *tt;
	int spdp;

	spdp = pdp;
	push(c);
	push(a);
	for(tt = nil; c != nil; c = c->d)
		tt = eval(c->a, a);
	pdp = spdp;
	return tt;
}

C*
evcon(C *c, C *a)
{
	int spdp;

	spdp = pdp;
	push(c);
	push(a);
	for(; c != nil; c = c->d)
		if(eval(c->a->a, a) != nil){
			pdp = spdp;
			return evbody(c->a->d, a);
		}
	pdp = spdp;
	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) || stringp(form))
		return form;
	if(atom(form)){
		if(tt = assq(form, a), tt != nil)
			return tt->d;
		if(tt = symeval(form), tt != unbound)
			return tt;
		err("error: no value");
	}
	if(form->a == cond)
		return evcon(form->d, a);
	spdp = pdp;
	push(form);
	push(a);
	if(atom(form->a)){
		if(form->a == nil || !symbolp(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){
			form = cons(tt->d, form->d);
			pdp = spdp;
			goto tail;
		}
lprint(form),
		err("error: no function");
	}
	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, *n;
	int spdp;
	Arglist al, ll;

	if(atom(fn)){
		if(fn == nil || !symbolp(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)
			return apply(tt->d, args, a);
lprint(fn),
		err("error: no function");
	}
	spdp = pdp;
	push(fn);
	push(args);
	push(a);
	if(fn->a == label){
		a = cons(cons(fn->d->a, fn->d->d->a), 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 != nil && symbolp(fn->d->a)){
			a = cons(cons(fn->d->a, n = mkfix(0)), a);
			pdp = spdp;
			/* almost same code as applylsubr... */
			al = spread(args);
			ll = largs;
			largs.nargs = nargs;
			largs.alist = alist-1;
			n->fix = nargs;
			tt = evbody(fn->d->d, 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;

	initio();

	gc();

	/* init oblist so we can use intern */
	pname = cons(Atom, nil);
	pname->d = cons(pname, cons(mkstr("PNAME"), nil));
	oblist = cons(pname, nil);

	unbound = cons(Atom, cons(pname, cons(mkstr("UNBOUND"), nil)));
	temlis.unbound = unbound;

	/* 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);
	}

	initsubr();

	star = intern("*");
}

void
eval_repl(void)
{
	C *e;

	putprop(star, star, value);
	for(;;){
		tyo('\n');
		lprint(eval(star, nil));
		tyo('\n');
		e = readsxp(1);
		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(1);
		if(e == noval)
			return;
		eval(e, nil);
	}
}

void
load(char *filename)
{
	FILE *f;
	Stream strsv;

	f = fopen(filename, "r");
	if(f == nil)
		return;

	strsv = sysin;
	sysin.type = IO_FILE;
	sysin.file = f;
	sysin.nextc = 0;
	if(setjmp(errlabel[errsp]))
		exit(1);
	eval_file();
	sysin = strsv;
	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

	errsp = 0;
	init();

	load("lib.l");

	if(setjmp(errlabel[errsp]))
		fprintf(stdout, "→\n");
	pdp = 0;
	alist = nil;
	memset(&prog, 0, sizeof(prog));
	memset(&temlis, 0, sizeof(temlis));
	temlis.unbound = unbound;

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