#include "scheme.h" State s;Sexp *globalenv, *syntaxenv;Sexp *labellist; static Sexp *aeval_l, *evlis_l, *evlis1_l, *evblock_l, *evblock1_l,            *callwv1_l,            *if1_l, *and1_l, *or1_l, *set1_l, *define1_l, *nil_l, *error_l; static Sexp*makelabel(void (*ret)(void)){	return consatom(Number, 0, (uintptr)ret);} static voidsaveup(Sexp *ret){	s.clink = cons(s.exp,	          cons(s.unevlis,	          cons(s.env,	          cons(s.evlis,	          cons(ret,	          cons(s.clink, empty))))));} static voidrestore(void){	Sexp *temp; 	if(s.clink == empty){		Bprint(&perr, "process ran out - restore\n");		Bflush(&perr);		return;	}	temp = s.clink;	s.exp     = temp->car;	temp = temp->cdr;	s.unevlis = temp->car;	temp = temp->cdr;	s.env     = temp->car;	temp = temp->cdr;	s.evlis   = temp->car;	temp = temp->cdr;	s.pc      = temp->car;	temp = temp->cdr;	s.clink   = temp->car;} static voiddefineglobal(Sexp *key, Sexp *val){	Sexp *a;	a = assq(key, globalenv);	if(a != false)		a->cdr->car = val;	else{		a = cons(globalenv->car, globalenv->cdr);		globalenv->cdr = a;		globalenv->car = cons(key, cons(val, empty));	}} static voidthrowerror(char *str){	s.val0 = consatom(String, 0, (uintptr)str);	s.vals = empty;	s.nval = 1;	s.pc = error_l;} static voidaeval(void){	Sexp *tmp; 	if(debug){		Bprint(&pout, "evaluating: ");		printsexp(s.exp, &pout);		Bprint(&pout, "\n");		Bflush(&pout);	} 	int atype;	if(s.exp == true || s.exp == false){		s.val0 = s.exp;		s.nval = 1;		restore();		return;	}	if(isatom(s.exp)){		atype = gettype(s.exp);		switch(atype){		case Vector:		case Number:		case Character:		case String:		case Primitive:			s.val0 = s.exp;			s.nval = 1;			restore();			break; 		case Symbol:			tmp = assq(s.exp, s.env);			if(tmp != false){				s.val0 = tmp->cdr->car;				s.nval = 1;				restore();			}else				throwerror(smprint("Symbol \"%s\" not bound",				                   (char*)s.exp->cdr));			break; 		default:			throwerror(smprint("can't evaluate type %d", atype));		}	}else if(isatom(s.exp->car)){		if(s.exp->car == lambda || s.exp->car == λ){			s.val0 = cons(beta, cons(s.exp, cons(s.env, empty)));			s.nval = 1;			restore();		}else if(gettype(s.exp->car) == Symbol){			tmp = assq(s.exp->car, syntaxenv);			if(tmp != false){				s.pc = tmp->cdr->car;			}else{				s.evlis = empty;				s.unevlis = s.exp;				s.pc = evlis_l;			}		}else{			throwerror(smprint("can't apply type %d",			                   gettype(s.exp->car)));		}	}else{		if(s.exp->car->car == lambda || s.exp->car->car == λ){			s.evlis = cons(s.exp->car, empty);			s.unevlis = s.exp->cdr;			s.pc = evlis_l;		}else{			s.evlis = empty;			s.unevlis = s.exp;			s.pc = evlis_l;		}	}} static voidevlis(void){	void (*f)(void); 	if(s.unevlis == empty){		s.evlis = reverse(s.evlis);		if(isatom(s.evlis->car)){			if(gettype(s.evlis->car) != Primitive){				throwerror(smprint("can't apply non-primitive atom"));				return;			}			f = (void (*)(void)) s.evlis->car->cdr;			s.exp = s.evlis->cdr;			f();			// restore in f() if necessary		}else{			if(s.evlis->car->car == lambda || s.evlis->car->car == λ){				s.env = pairargs(s.evlis->car->cdr->car,				                 s.evlis->cdr, s.env);				s.exp = s.evlis->car->cdr->cdr;				s.pc = evblock_l;			}else if(s.evlis->car->car == beta){				s.env = pairargs(s.evlis->car->cdr->car->cdr->car,				                 s.evlis->cdr,				                 s.evlis->car->cdr->cdr->car);				s.exp = s.evlis->car->cdr->car->cdr->cdr;				s.pc = evblock_l;			}else if(s.evlis->car->car == delta){				s.clink = s.evlis->car->cdr->car;				restore();			}else{				throwerror(smprint("can't apply function"));			}		}	}else{		saveup(evlis1_l);		s.exp = s.unevlis->car;		s.pc = aeval_l;	}} static voidevlis1(void){	// TODO: check for nval > 0	s.evlis = cons(s.val0, s.evlis);	s.unevlis = s.unevlis->cdr;	s.pc = evlis_l;} static voidevblock(void){	if(s.exp->cdr != empty)		saveup(evblock1_l);	s.exp = s.exp->car;	s.pc = aeval_l;} static voidevblock1(void){	s.exp = s.exp->cdr;	s.pc = evblock_l;} static voidlist_prim(void){	s.val0 = s.exp;	s.nval = 1;	restore();} static voidvalues_prim(void){	s.nval = listlen(s.exp);	s.val0 = s.exp->car;	s.vals = s.exp->cdr;	restore();} static voidcons_prim(void){	s.val0 = cons(s.exp->car, s.exp->cdr->car);	s.nval = 1;	restore();} static voidcar_prim(void){	s.val0 = s.exp->car->car;	s.nval = 1;	restore();} static voidcdr_prim(void){	s.val0 = s.exp->car->cdr;	s.nval = 1;	restore();} static voidsetcar_prim(void){	s.exp->car->car = s.exp->cdr->car;	s.nval = 0;	restore();} static voidsetcdr_prim(void){	s.exp->car->cdr = s.exp->cdr->car;	s.nval = 0;	restore();} static voideq_prim(void){	if(s.exp->car == s.exp->cdr->car)		s.val0 = true;	else		s.val0 = false;	s.nval = 1;	restore();} static voidcallcc_prim(void){	Sexp *a;	a = cons(delta, cons(s.clink, empty));	pushroot(&a);	s.evlis = cons(a, cons(s.exp->car, empty));	poproot();	s.unevlis = empty;	s.pc = evlis_l;} static voidcallwv_prim(void){	saveup(callwv1_l);	s.evlis = cons(s.exp->car, empty);	s.unevlis = empty;	s.pc = evlis_l;} static voidcallwv1_prim(void){	s.evlis = cons(s.val0, s.vals);	s.evlis = cons(s.exp->cdr->car, s.evlis);	s.evlis = reverse(s.evlis);	s.unevlis = empty;	s.pc = evlis_l;} static voidread_prim(void){	s.val0 = readsexp(&pin);	s.nval = 1;	restore();} static voidprint_prim(void){	printsexp(s.exp->car, &pout);	Bprint(&pout, "\n");	Bflush(&pout);	s.nval = 0;	restore();} static voidpairargs_prim(void){	s.val0 = pairargs(s.exp->car, s.exp->cdr->car, s.exp->cdr->cdr->car);	s.nval = 1;	restore();} static voidadd_prim(void){	s.val0 = addnums(s.exp);	s.nval = 1;	restore();} static voidmul_prim(void){	s.val0 = mulnums(s.exp);	s.nval = 1;	restore();} static voidsub_prim(void){	s.val0 = subnums(s.exp);	s.nval = 1;	restore();} static voiddiv_prim(void){	s.val0 = divnums(s.exp);	s.nval = 1;	restore();} static voideqnum_prim(void){	s.val0 = testnums(s.exp, eq2nums);	s.nval = 1;	restore();} static voidltnum_prim(void){	s.val0 = testnums(s.exp, lt2nums);	s.nval = 1;	restore();} static voidgtnum_prim(void){	s.val0 = testnums(s.exp, gt2nums);	s.nval = 1;	restore();} static voidlenum_prim(void){	s.val0 = testnums(s.exp, le2nums);	s.nval = 1;	restore();} static voidgenum_prim(void){	s.val0 = testnums(s.exp, ge2nums);	s.nval = 1;	restore();} static voidquote_syntax(void){	s.val0 = s.exp->cdr->car;	s.nval = 1;	restore();} static voidquasiquote_syntax(void){	s.val0 = s.exp->cdr->car;	s.nval = 1;	restore();} static voidif_syntax(void){	saveup(if1_l);	s.exp = s.exp->cdr->car;	s.pc = aeval_l;} static voidif1_syntax(void){	// TODO: check for nval > 0	if(s.val0 != false)		s.exp = s.exp->cdr->cdr->car;	else		s.exp = s.exp->cdr->cdr->cdr->car;	s.pc = aeval_l;} static voidand_syntax(void){	s.exp = s.exp->cdr;	if(s.exp == empty){		s.val0 = true;		s.nval = 1;		restore();		return;	}	saveup(and1_l);	s.exp = s.exp->car;	s.pc = aeval_l;} static voidand1_syntax(void){	if(s.exp->cdr == empty || s.nval > 0 && s.val0 == false){		restore();		return;	}	s.exp = s.exp->cdr;	saveup(and1_l);	s.exp = s.exp->car;	s.pc = aeval_l;} static voidor_syntax(void){	s.exp = s.exp->cdr;	if(s.exp == empty){		s.val0 = false;		s.nval = 1;		restore();		return;	}	saveup(or1_l);	s.exp = s.exp->car;	s.pc = aeval_l;} static voidor1_syntax(void){	if(s.exp->cdr == empty || s.nval > 0 && s.val0 != false){		restore();		return;	}	s.exp = s.exp->cdr;	saveup(or1_l);	s.exp = s.exp->car;	s.pc = aeval_l;}

Lines 1–500 of 726. Load more