shithub: mlisp

Info • Files • Log • Branches
ref: 3e8336c0ea2e6f70eb0b277f3d0927b114d0709c
dir: /subr.c/
#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)
}