#include "scheme.h" static vlong peekbuf[10];static int peekind;static Rune stringbuf[512];static int bufind; #define EOF ~0 static intisdelim(Rune r){	return isspacerune(r) || runestrchr(L"()\"", r);} /* For ALL Biobufs */static voidungetrune(Rune r){	peekbuf[peekind++] = r;} static Runenextrunesp(Biobuf *file){	Rune r;	if(peekind == 0){		vlong x;		x = Bgetrune(file);		r = x;		if(x < 0)			r = EOF;	}else		r = peekbuf[--peekind];	if(r == L';')		while(r = Bgetrune(file), r != L'\n');	if(isspacerune(r))		r = L' ';	return r;} static Runenextrune(Biobuf *file){	Rune r;	while(r = nextrunesp(file), r == L' ');	return r;} static Sexp*readlist(Biobuf *file){	Rune r;	Sexp *first, *second; 	if(r = nextrune(file), r == L')')		return empty;	ungetrune(r); 	first = readsexp(file);	pushroot(&first); 	if(r = nextrune(file), r == L'.'){		// TODO: expect delimiter		second = readsexp(file);		poproot();		if(second == nil){			Bprint(&perr, "error: invalid cdr\n");			return nil;		}		if(r = nextrune(file), r != L')'){			Bprint(&perr, "error: ')' expected\n");			return empty;		}		return cons(first, second);	}else{		ungetrune(r);		second = readlist(file);		poproot();		return cons(first, second);	}} static Sexp*readproperlist(Biobuf *file){	Rune r;	Sexp *first, *second; 	if(r = nextrune(file), r == L')')		return empty;	ungetrune(r);	first = readsexp(file);	pushroot(&first);	second = readproperlist(file);	poproot();	return cons(first, second);} static intgetdigit(Rune r, int base){	int d;	if(r >= L'0' && r <= L'9')		d = r-L'0';	else if(r >= L'A' && r <= L'F')		d = r-L'A' + 10;	else if(r >= L'a' && r <= L'f')		d = r-L'a' + 10;	else		return -1;	if(d >= base)		return -1;	return d;} /* TODO */static Sexp*readnumber(Biobuf *file){	Sexp *e;	Rune r, *sp;	char *s;	int d, i;	double f, div;	int exp, esign;	int exactness;	int base;	int canprefix, signstate, digitstate;	int sign;	int numtype; 	bufind = 0;	while(r = nextrunesp(file), !isdelim(r))		stringbuf[bufind++] = r;	ungetrune(r);	stringbuf[bufind++] = 0; 	canprefix = 1;	signstate = 0;	/* 0 can't read sign	                   1 can read sign	                   2 can read esign */	digitstate = 0; /* 0 reading integer part	                   1 reading fractional part	                   2 reading exponent */	base = 10;	exactness = 0; 	sign = 1;	i = 0;   /* integer part */	f = 0.0; /* fractional part */	div = base;	exp = 0;	esign = 1;	numtype = Integer;	for(sp = stringbuf; *sp; sp++){		if(canprefix && *sp == L'#'){			sp++;			switch(*sp){			case L'b':				div = base = 2;				break;			case L'o':				div = base = 8;				break;			case L'd':				div = base = 10;				break;			case L'x':				div = base = 16;				break;			case L'i':				exactness = Inexact;				break;			case L'e':				exactness = 0;				break;			default:				goto symbol;			}			continue;		}		canprefix = 0; 		if(signstate && (*sp == '-' || *sp == '+')){			if(signstate == 1)				sign = (*sp == '-') ? -1 : 1;			else				esign = (*sp == '-') ? -1 : 1;			signstate = 0;			continue;		}		signstate = 0; 		if((d = getdigit(*sp, base)) >= 0){			if(digitstate == 0)				i = i*base + d;			else if(digitstate == 1){				f += d/div;				div *= base;			}else				exp = exp*base + d;			continue;		} 		if(*sp == L'.'){			if(digitstate == 1)				goto symbol;			digitstate = 1;			numtype = Real;			continue;		} 		if(*sp == L'e'){			numtype = Real;			signstate = digitstate = 2;			continue;		} 		goto symbol;	} 	i *= sign;	if(numtype == Integer){		return makeinteger(i);	}else{		f += i;		if(esign < 0)			while(exp--)				f /= 10.0f;	// TODO: or base?		else			while(exp--)				f *= 10.0f;		return makereal(f);	} symbol:	s = smprint("%S", stringbuf);	e = getsymbol(s);	free(s);	return e;} static Sexp*readsymbol(Biobuf *file){	Rune r;	char *s;	Sexp *e; 	bufind = 0;	while(r = nextrunesp(file), !isdelim(r))		stringbuf[bufind++] = r;	ungetrune(r);	stringbuf[bufind++] = 0;	s = smprint("%S", stringbuf);	e = getsymbol(s);	free(s);	return e;} Sexp*readsexp(Biobuf *file){	Rune r, rr;	Sexp *lst, *vec;	int len, i; 	if(r = nextrune(file), r == EOF)		return nil; 	switch(r){	/* List */	case L'(':		return readlist(file); 	case L')':		Bprint(&perr, "error: s-expression can't start with ')'\n");		Bflush(&perr);		return nil; 	/* String */	case L'"':		bufind = 0;		if(peekind != 0){			Bprint(&perr, "peekind shouldn't be 0 when reading string\n");			Bflush(&perr);		}		while(r = Bgetrune(file), r != L'"'){			if(r == L'\\'){				r = Bgetrune(file);				switch(r){				case L'n':					r = '\n';					break;				case L't':					r = '\t';					break;				default:					break;				}			}			stringbuf[bufind++] = r;		}		stringbuf[bufind++] = 0;		return consatom(String, 0, (uintptr)smprint("%S", stringbuf)); 	case L'#':		r = nextrunesp(file);		/* Booleans */		if(r == L'f')			return false;		if(r == L't')			return true;		/* Vector */		if(r == L'('){			lst = readproperlist(file);			pushroot(&lst);			len = listlen(lst);			vec = makevector(len, empty);			for(i = 0; i < len; i++, lst = lst->cdr)				vectorset(vec, i, lst->car);			poproot();			return vec;		}		/* Character */		if(r == L'\\'){			bufind = 0;			while(r = nextrunesp(file), !isdelim(r))				stringbuf[bufind++] = r;			ungetrune(r);			stringbuf[bufind++] = 0;			if(bufind == 2)				return consatom(Character, 0, (uintptr)stringbuf[0]);			if(runestrcmp(stringbuf, L"newline") == 0)				return consatom(Character, 0, (uintptr)L'\n');			if(runestrcmp(stringbuf, L"space") == 0)				return consatom(Character, 0, (uintptr)L' ');			Bprint(&perr, "unknown character: %S\n", stringbuf);			Bflush(&perr);			return nil;		}		if(runestrchr(L"iebodx", r)){			ungetrune(r);			ungetrune(L'#');			return readnumber(file);		}		Bprint(&perr, "can't read after hash\n");		Bflush(&perr);		return nil; 	case L'.':		r = nextrunesp(file);		if(runestrchr(L"0123456789", r)){			ungetrune(r);			ungetrune(L'.');			return readnumber(file);		}		if(r == ' '){			Bprint(&perr, "error: dot not allowed here\n");			Bflush(&perr);			return nil;		}		ungetrune(r);		ungetrune(L'.');		return readsymbol(file); 	case L'+':	case L'-':		rr = r;		r = nextrunesp(file);		if(runestrchr(L"i0123456789abcdefABCDEF", r)){			ungetrune(r);			ungetrune(rr);			/* can also return symbol */			return readnumber(file);		}		ungetrune(r);		ungetrune(rr);		return readsymbol(file); 	case L'\'':		return cons(quote, cons(readsexp(file), empty)); 	case L'`':		return cons(quasiquote, cons(readsexp(file), empty)); 	case L',':		r = nextrunesp(file);		if(r == L'@')			return cons(unquotesplicing, cons(readsexp(file), empty));		ungetrune(r);		return cons(unquote, cons(readsexp(file), empty)); 	default:		ungetrune(r);		if(runestrchr(L"0123456789", r))			return readnumber(file);		return readsymbol(file);	}} voidprintsexpnl(Sexp *e, Biobuf *file){	printsexp(e, file);	Bprint(file, "\n");	Bflush(file);} voidprintsexp(Sexp *o, Biobuf *file){	int len, i;	Rune r; 	if(ispair(o)){		/* HACK: */		if(o->car == beta){			Bprint(file, "β-closure");			return;		}		Bprint(file, "(");		for(; o != empty && ispair(o); o = o->cdr){			printsexp(o->car, file);			if(o->cdr != empty){				Bprint(file, " ");				if(!ispair(o->cdr)){					Bprint(file, ". ");					printsexp(o->cdr, file);				}			}		}		Bprint(file, ")");	}else switch(gettype(o)){	case Symbol:		Bprint(file, "%s", (char*)o->cdr);		break;	case Vector:		Bprint(file, "#(");		len = vectorlen(o);		for(i = 0; i < len; i++){			printsexp(vectorref(o, i), file);			if(i+1 != len)				Bprint(file, " ");		}		Bprint(file, ")");		break;/*	case Lambda:		Bprint(file, "λ");		break;*/	case Primitive:		Bprint(file, "#<primitive %p>", o->cdr);		break;	case Number:		if((getnumtype(o) & 0x3) == Integer)			Bprint(file, "%d", o->integ);		else			Bprint(file, "%f", o->real);		break;	case Character:		r = (Rune)(uintptr)o->cdr;		if(r == L'\n')			Bprint(file, "#\\newline");		else if(r == L' ')			Bprint(file, "#\\space");		else			Bprint(file, "#\\%C", r);		break;	case String:		Bprint(file, "\"%s\"", (char*)o->cdr);		break;	case Port:		Bprint(file, "port");		break;	case Special:		if(o == empty)			Bprint(file, "()");		else if(o == true)			Bprint(file, "#t");		else if(o == false)			Bprint(file, "#f");		else			Bprint(file, "special");		break;	case Free:		Bprint(file, "free");		break;	}}