shithub: mlisp

ref: a88cd71d79e142d686b01ff33624a4cc8febb268
dir: /subr.c/

#include "lisp.h"

int
floeq(flonum x, flonum y)
{
	return fabs(x-y) < 0.000003;
}

typedef int (*Eql)(C *a, C *b);

int
eq(C *a, C *b)
{
	return a == b;
}
int
equal(C *a, C *b)
{
tail:
	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);
		if(stringp(a))
			return stringp(b) &&
				strcmp(a->str, b->str) == 0;
		return a == b;
	}
	if(!equal(a->a, b->a))
		return 0;
	a = a->d;
	b = b->d;
	goto tail;
}

/* 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;
}
C *stringp_subr(void){
	return stringp(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(!listp(pair))
		err("error: not a pair");
	return pair->a;
}
C *cdr(C *pair){
	if(pair == nil)
		return nil;
	if(!listp(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_aux(Eql cmp){
	C *l;
	for(l = alist[1]; l != nil; l = l->d){
		if(atom(l))
			err("error: no list");
		if(cmp(l->a, alist[0]))
			return t;
	}
	return nil;
}
C *member_subr(void){ return member_aux(equal); }
C *memq_subr(void){ return member_aux(eq); }
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;
}
C *delete_aux(Eql cmp){
	C **p;
	fixnum n;
	if(largs.nargs < 2)
		err("error: arg count");
	n = -1;
	if(largs.nargs > 2)
		n = largs.alist[3]->fix;
	for(p = &largs.alist[2]; *p != nil; p = &(*p)->d){
		if(atom(*p))
			err("error: no list");
		if(cmp((*p)->a, largs.alist[1])){
			if(n-- == 0)
				break;
			*p = (*p)->d;
		}
	}
	return largs.alist[2];
}
C *delete_lsubr(void){ return delete_aux(equal); }
C *delq_lsubr(void){ return delete_aux(eq); }


/* 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, *a, *l, *last;
	last = nil;
	for(l = alist[0]; l != nil; l = l->d->d){
		a = l->a;
		if(a == nil || !symbolp(a))
			err("error: need symbol");
		last = eval(l->d->a, alist[1]);
		tt = assq(a, alist[1]);
		if(tt == nil)
			putprop(a, last, value);
		else
			tt->d = last;
	}
	return last;
}
/* Has to be FSUBR here, also extended syntax */
C *set_fsubr(void){
	C *tt, *a, *l, *last;
	last = nil;
	for(l = alist[0]; l != nil; l = l->d->d){
		a = eval(l->a, alist[1]);
		if(a == nil || !symbolp(a))
			err("error: need symbol");
		last = eval(l->d->a, alist[1]);
		tt = assq(a, alist[1]);
		if(tt == nil)
			putprop(a, last, value);
		else
			tt->d = last;
	}
	return last;
}
C *boundp_subr(void){
	if(alist[0] == nil || !symbolp(alist[0]))
		err("error: need symbol");
	return symeval(alist[0]) == unbound ? nil : t;
}
C *makunbound_subr(void){
	if(alist[0] == nil || !symbolp(alist[0]))
		err("error: need symbol");
	putprop(alist[0], unbound, value);
	return alist[0];
}

/* Property list */

C *get_subr(void){
	return get(alist[0], alist[1]);
}
C *getl_subr(void){
	C *pl, *l;
	pl = alist[0];
	if(pl == nil || !(listp(pl) || symbolp(pl)))
		return nil;
	for(pl = pl->d; pl != nil; pl = pl->d->d){
		assert(listp(pl));
		for(l = alist[1]; l != nil; l = l->d){
			if(atom(l))
				err("error: no list");
			if(pl->a == l->a)
				return pl;
		}
	}
	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;
}

C*
mkchar(char c)
{
	char str[2];
	str[0] = c;
	str[1] = '\0';
	return intern(str);
}

#define NEEDNAME(x) if(symbolp(x)) x = getpname(x); if(!stringp(x)) err("error: not a string")

/* pname/string functions */
C *samepnamep_subr(void){
	NEEDNAME(alist[0]);
	NEEDNAME(alist[1]);
	return strcmp(alist[0]->str, alist[1]->str) == 0 ? t : nil;
}
C *alphalessp_subr(void){
	NEEDNAME(alist[0]);
	NEEDNAME(alist[1]);
	return strcmp(alist[0]->str, alist[1]->str) < 0 ? t : nil;
}
C *getchar_subr(void){
	NEEDNAME(alist[0]);
	if(!fixnump(alist[1])) err("error: not a number");
	if(alist[1]->fix < 1 || alist[1]->fix > strlen(alist[0]->str))
		return nil;
	return mkchar(alist[0]->str[alist[1]->fix-1]);
}
C *intern_subr(void){
	C *c, *name;
	name = alist[0];
	NEEDNAME(name);
	c = findsym(name->str);
	if(c == nil){
		if(symbolp(alist[0]))
			c = alist[0];
		else
			c = mksym(name->str);
		oblist = cons(c, oblist);
	}
	return c;
}
C *remob_subr(void){
	C **c;
	if(!symbolp(alist[0])) err("error: not a symbol");
	for(c = &oblist; *c != nil; c = &(*c)->d){
		if((*c)->a == alist[0]){
			*c = (*c)->d;
			break;
		}
	}
	return nil;
}
C *gensym_lsubr(void){
	static int num = 1;
	static char chr = 'G';
	char str[6];

	if(largs.nargs == 1){
		if(symbolp(largs.alist[1])) largs.alist[1] = getpname(largs.alist[1]);
		if(stringp(largs.alist[1]))
			chr = largs.alist[1]->str[0];
		else if(fixnump(largs.alist[1]))
			num = largs.alist[1]->fix;
		else
			err("error: not string or number");
	}

	str[0] = chr;
	str[1] = '0' + ((num/1000)%10);
	str[2] = '0' + ((num/100)%10);
	str[3] = '0' + ((num/10)%10);
	str[4] = '0' + (num%10);
	num++;
	return mksym(str);
}

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

/* Character manipulation */

static C *mkfixchar(char c) { return mkfix(c); }
static C *str2list(char *str, C *(*f)(char)){
	C **lp;
	char *s;
	lp = push(nil);
	for(s = str; *s != '\0'; s++){
		*lp = cons(f(*s), nil);
		lp = &(*lp)->d;
	}
	return pop();
}
static Strbuf list2str(C *l){
	Strbuf buf;
	if(!listp(l)) err("error: not a list");
	initbuf(&buf);
	for(; l != nil; l = l->d){
		if(atom(l)){
			freebuf(&buf);
			err("error: no list");
		}
		if(symbolp(l->a))
			pushchar(&buf, getpname(l->a)->str[0]);
		else if(fixnump(l->a))
			pushchar(&buf, l->a->fix);
		else{
			freebuf(&buf);
			err("error: not an ascii character");
		}
	}
	pushchar(&buf, '\0');
	return buf;
}

C *ascii_subr(void){
	if(!fixnump(alist[0])) err("error: not a fixnum");
	return mkchar(alist[0]->fix);
}
C *maknam_subr(void){
	C *l;
	Strbuf buf;
	buf = list2str(alist[0]);
	l = mksym(buf.buf);
	freebuf(&buf);
	return l;
}
C *implode_subr(void){
	alist[0] = maknam_subr();
	return intern_subr();
}
C *explode_aux(void (*prnt)(C*), C *(*f)(char)){
	C *s;
	Stream strsv;

	strsv = sysout;
	sysout.type = IO_BUF;
	initbuf(&sysout.strbuf);
	prnt(alist[0]);
	tyo('\0');
	s = str2list(sysout.strbuf.buf, f);
	freebuf(&sysout.strbuf);
	sysout = strsv;
	return s;
}
C *explode_subr(void){ return explode_aux(lprint, mkchar); }
C *explodec_subr(void){ return explode_aux(princ, mkchar); }
C *exploden_subr(void){ return explode_aux(princ, mkfixchar); }
C *flat_aux(void (*prnt)(C*)){
	C *s;
	Stream strsv;

	strsv = sysout;
	sysout.type = IO_BUF;
	initbuf(&sysout.strbuf);
	prnt(alist[0]);
	tyo('\0');
	s = mkfix(strlen(sysout.strbuf.buf));
	freebuf(&sysout.strbuf);
	sysout = strsv;
	return s;
}
C *flatc_subr(void){ return flat_aux(princ); }
C *flatsize_subr(void){ return flat_aux(lprint); }
C *readlist_subr(void){
	C *l;
	Strbuf buf;
	Stream strsv;

	buf = list2str(alist[0]);
	buf.len = buf.pos;
	buf.pos = 0;

	strsv = sysin;
	sysin.type = IO_BUF;
	sysin.strbuf = buf;
	sysin.nextc = 0;

	// Be careful to clean up after errors here
	errsp++;
	if(setjmp(errlabel[errsp])){
		errsp--;
		sysin = strsv;
		freebuf(&buf);
		longjmp(errlabel[errsp], 1);
	}
	l = readsxp(1);
	errsp--;
	sysin = strsv;
	freebuf(&buf);
	return l;
}

/* Mapping */

/* zip is for internal use.
 * It returns successively zipped lists for mapping
 * leaving the list on the stack. */
static int
zip(C *(*f)(C*))
{
	int i;
	C **ap;
	ap = push(nil);
	for(i = 2; i <= largs.nargs; i++){
		if(largs.alist[i] == nil){
			pop();
			return 1;
		}
		*ap = cons(f(largs.alist[i]), nil);
		ap = &(*ap)->d;
		largs.alist[i] = largs.alist[i]->d;
	}
	return 0;
}
C *id(C *c) { return c; }
static int ziplist(void){ return zip(id); }
static int zipcar(void){ return zip(car); }

C *maplist_aux(int (*zip)(void)){
	C **p;
	if(largs.nargs < 2)
		err("error: arg count");
	p = push(nil);
	while(!zip()){
		*p = cons(apply(largs.alist[1], pop(), nil), nil);
		p = &(*p)->d;
	}
	return pop();
}
C *maplist_lsubr(void){ return maplist_aux(ziplist); }
C *mapcar_lsubr(void){ return maplist_aux(zipcar); }
C *map_aux(int (*zip)(void)){
	C *ret;
	if(largs.nargs < 2)
		err("error: arg count");
	ret = largs.alist[2];
	while(!zip())
		apply(largs.alist[1], pop(), nil);
	return ret;
}
C *map_lsubr(void){ return map_aux(ziplist); }
C *mapc_lsubr(void){ return map_aux(zipcar); }
C *mapcon_aux(int (*zip)(void)){
	C **p;
	if(largs.nargs < 2)
		err("error: arg count");
	p = push(nil);
	while(!zip()){
		*p = apply(largs.alist[1], pop(), nil);
		for(; *p != nil; p = &(*p)->d)
			if(atom(*p))
				err("error: no list");
	}
	return pop();
}
C *mapcon_lsubr(void){ return mapcon_aux(ziplist); }
C *mapcan_lsubr(void){ return mapcon_aux(zipcar); }

/* IO */

C *read_subr(void){
	return readsxp(1);
}
C *prin1_subr(void){
	lprint(alist[0]);
	return t;
}
C *print_subr(void){
	tyo('\n');
	lprint(alist[0]);
	tyo(' ');
	return t;
}
C *princ_subr(void){
	princ(alist[0]);
	return t;
}
C *terpri_subr(void){
	tyo('\n');
	return nil;
}


/* Prog feature */
Prog prog;

C *go_fsubr(void){
	C *tt, *p;
	if(prog.prog == nil)
		err("error: not in prog");
	if(alist[0] == nil)
		err("error: arg count");
	tt = alist[0]->a;
	while(!atom(tt))
		tt = eval(tt, alist[1]);
	for(p = prog.prog; p != nil; p = p->d)
		if(p->a == tt){
			prog.pc = p->d;
			return nil;
		}
	err("undefined label");
	return nil;	// hm...
}
C *return_fsubr(void){
	if(prog.prog == nil)
		err("error: not in prog");
	if(alist[0] == nil)
		prog.ret = nil;
	else
		prog.ret = eval(alist[0]->a, alist[1]);
	prog.pc = nil;
	return nil;	// hm...
}

C *prog_fsubr(void){
	Prog progsv;

	C *p, *a;
	C **ap;

	progsv = prog;
	prog.prog = alist[0]->d;
	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];		/* nconc */
	alist[1] = a = temlis.a;
	temlis.a = nil;

	/* execute */
	prog.ret = nil;
	while(prog.pc != nil){
		p = prog.pc->a;
		prog.pc = prog.pc->d;
		if(!atom(p))
			eval(p, a);
	}

	p = prog.ret;
	prog = progsv;
	return p;
}

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("STRINGP", stringp_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)
	LSUBR("DELETE", delete_lsubr)
	LSUBR("DELQ", delq_lsubr)

	FSUBR("AND", and_fsubr)
	FSUBR("OR", or_fsubr)
	FSUBR("PROG", prog_fsubr)
	FSUBR("RETURN", return_fsubr)
	FSUBR("GO", go_fsubr)

	FSUBR("SETQ", setq_fsubr)
	FSUBR("SET", set_fsubr)
	SUBR("BOUNDP", boundp_subr, 1);
	SUBR("MAKUNBOUND", makunbound_subr, 1);

	SUBR("GET", get_subr, 2)
	SUBR("GETL", getl_subr, 2)
	SUBR("PUTPROP", putprop_subr, 3)
	FSUBR("DEFPROP", defprop_fsubr)
	SUBR("REMPROP", remprop_subr, 2)

	SUBR("SAMEPNAMEP", samepnamep_subr, 2)
	SUBR("ALPHALESSP", alphalessp_subr, 2)
	SUBR("GETCHAR", getchar_subr, 2)
	SUBR("INTERN", intern_subr, 1)
	SUBR("REMOB", remob_subr, 1)
	LSUBR("GENSYM", gensym_lsubr)

	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("ASCII", ascii_subr, 1)
	SUBR("MAKNAM", maknam_subr, 1)
	SUBR("IMPLODE", implode_subr, 1)
	SUBR("EXPLODE", explode_subr, 1)
	SUBR("EXPLODEC", explodec_subr, 1)
	SUBR("EXPLODEN", exploden_subr, 1)
	SUBR("FLATC", flatc_subr, 1)
	SUBR("FLATSIZE", flatsize_subr, 1)
	SUBR("READLIST", readlist_subr, 1)

	LSUBR("MAPLIST", maplist_lsubr)
	LSUBR("MAPCAR", mapcar_lsubr)
	LSUBR("MAP", map_lsubr)
	LSUBR("MAPC", mapc_lsubr)
	LSUBR("MAPCON", mapcon_lsubr)
	LSUBR("MAPCAN", mapcan_lsubr)

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