tomo el fuego

Copyright 2012 blstuart

Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.

3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

implement BuiltIn;

include "sys.m";
sys: Sys;

include "math.m";
math: Math;

include "draw.m";

include "bufio.m";
bufio: Bufio;
Iobuf: import bufio;

include "string.m";
str: String;

include "cell.m";
cell: SCell;
Cell: import cell;
Pair: import cell;
Env: import cell;

include "scheme.m";
scheme: Scheme;
eval: import scheme;
readcell: import scheme;
printcell: import scheme;
scannum: import scheme;
reduce: import scheme;

stdin, stdout: ref Iobuf;

include "builtin.m";

init(sy: Sys, sch: Scheme, c: SCell, m: Math, st: String,
	b: Bufio, in: ref Iobuf, out: ref Iobuf)
{
	sys = sy;
	scheme = sch;
	cell = c;
	math = m;
	str = st;
	bufio = b;
	stdin = in;
	stdout = out;

	e := ref Env("+", cell->BuiltIn, nil, add) :: cell->globalenv;
	e = ref Env("*", cell->BuiltIn, nil, mult) :: e;
	e = ref Env("-", cell->BuiltIn, nil, minus) :: e;
	e = ref Env("/", cell->BuiltIn, nil, divide) :: e;
	e = ref Env("=", cell->BuiltIn, nil, numequal) :: e;
	e = ref Env("<", cell->BuiltIn, nil, numless) :: e;
	e = ref Env(">", cell->BuiltIn, nil, numgreater) :: e;
	e = ref Env("<=", cell->BuiltIn, nil, numleq) :: e;
	e = ref Env(">=", cell->BuiltIn, nil, numgeq) :: e;
	e = ref Env("acos", cell->BuiltIn, nil, acos) :: e;
	e = ref Env("apply", cell->BuiltIn, nil, apply) :: e;
	e = ref Env("asin", cell->BuiltIn, nil, asin) :: e;
	e = ref Env("atan", cell->BuiltIn, nil, atan) :: e;
	e = ref Env("call-with-current-continuation",
		cell->BuiltIn, nil, callwcont) :: e;
	e = ref Env("call-with-values", cell->BuiltIn, nil, callwval) :: e;
	e = ref Env("car", cell->BuiltIn, nil, car) :: e;
	e = ref Env("cdr", cell->BuiltIn, nil, cdr) :: e;
	e = ref Env("ceiling", cell->BuiltIn, nil, ceiling) :: e;
	e = ref Env("char?", cell->BuiltIn, nil, charp) :: e;
	e = ref Env("char=?", cell->BuiltIn, nil, chareqp) :: e;
	e = ref Env("char<?", cell->BuiltIn, nil, charltp) :: e;
	e = ref Env("char>?", cell->BuiltIn, nil, chargtp) :: e;
	e = ref Env("char<=?", cell->BuiltIn, nil, charlep) :: e;
	e = ref Env("char>=?", cell->BuiltIn, nil, chargep) :: e;
	e = ref Env("char->integer", cell->BuiltIn, nil, char2int) :: e;
	e = ref Env("close-input-port", cell->BuiltIn, nil, closeinport) :: e;
	e = ref Env("close-output-port", cell->BuiltIn, nil, closeoutport) :: e;
	e = ref Env("complex?", cell->BuiltIn, nil, complexp) :: e;
	e = ref Env("cons", cell->BuiltIn, nil, cons) :: e;
	e = ref Env("cos", cell->BuiltIn, nil, cos) :: e;
	e = ref Env("current-input-port", cell->BuiltIn, nil, curinport) :: e;
	e = ref Env("current-output-port", cell->BuiltIn, nil, curoutport) :: e;
	e = ref Env("denominator", cell->BuiltIn, nil, denominator) :: e;
	e = ref Env("display", cell->BuiltIn, nil, display) :: e;
	e = ref Env("dynamic-wind", cell->BuiltIn, nil, dynwind) :: e;
	e = ref Env("eof-object?", cell->BuiltIn, nil, eofp) :: e;
	e = ref Env("eq?", cell->BuiltIn, nil, eqp) :: e;
	e = ref Env("eqv?", cell->BuiltIn, nil, eqvp) :: e;
	e = ref Env("eval", cell->BuiltIn, nil, leval) :: e;
	e = ref Env("exact?", cell->BuiltIn, nil, exactp) :: e;
	e = ref Env("exact->inexact", cell->BuiltIn, nil, extoinex) :: e;
	e = ref Env("exp", cell->BuiltIn, nil, exp) :: e;
	e = ref Env("expt", cell->BuiltIn, nil, expt) :: e;
	e = ref Env("floor", cell->BuiltIn, nil, floor) :: e;
	e = ref Env("inexact?", cell->BuiltIn, nil, inexactp) :: e;
	e = ref Env("inexact->exact", cell->BuiltIn, nil, inextoex) :: e;
	e = ref Env("input-port?", cell->BuiltIn,nil, inportp) :: e;
	e = ref Env("integer?", cell->BuiltIn, nil, integerp) :: e;
	e = ref Env("integer->char", cell->BuiltIn, nil, int2char) :: e;
	e = ref Env("interaction-environment", cell->BuiltIn, nil, interenv) :: e;
	e = ref Env("list", cell->BuiltIn, nil, llist) :: e;
	e = ref Env("load", cell->BuiltIn, nil, lload) :: e;
	e = ref Env("log", cell->BuiltIn, nil, log) :: e;
	e = ref Env("make-string", cell->BuiltIn, nil, makestring) :: e;
	e = ref Env("make-vector", cell->BuiltIn, nil, makevector) :: e;
	e = ref Env("modulo", cell->BuiltIn, nil, modulo) :: e;
	e = ref Env("null-environment", cell->BuiltIn, nil, nullenv) :: e;
	e = ref Env("number?", cell->BuiltIn, nil, numberp) :: e;
	e = ref Env("number->string", cell->BuiltIn, nil, numtostr) :: e;
	e = ref Env("numerator", cell->BuiltIn, nil, numerator) :: e;
	e = ref Env("open-input-file", cell->BuiltIn, nil, openinfile) :: e;
	e = ref Env("open-output-file", cell->BuiltIn, nil, openoutfile) :: e;
	e = ref Env("output-port?", cell->BuiltIn, nil, outportp) :: e;
	e = ref Env("pair?", cell->BuiltIn, nil, pairp) :: e;
	e = ref Env("peek-char", cell->BuiltIn, nil, peekchar) :: e;
	e = ref Env("procedure?", cell->BuiltIn, nil, procedurep) :: e;
	e = ref Env("quotient", cell->BuiltIn, nil, quotient) :: e;
	e = ref Env("rational?", cell->BuiltIn, nil, rationalp) :: e;
	e = ref Env("read", cell->BuiltIn, nil, lread) :: e;
	e = ref Env("read-char", cell->BuiltIn, nil, preadchar) :: e;
	e = ref Env("real?", cell->BuiltIn, nil, realp) :: e;
	e = ref Env("remainder", cell->BuiltIn, nil, remainder) :: e;
	e = ref Env("round", cell->BuiltIn, nil, round) :: e;
	e = ref Env("scheme-report-environment",
		cell->BuiltIn, nil, schrepenv) :: e;
	e = ref Env("set-car!", cell->BuiltIn, nil, setcar) :: e;
	e = ref Env("set-cdr!", cell->BuiltIn, nil, setcdr) :: e;
	e = ref Env("sin", cell->BuiltIn, nil, sin) :: e;
	e = ref Env("sqrt", cell->BuiltIn, nil, sqrt) :: e;
	e = ref Env("string?", cell->BuiltIn, nil, stringp) :: e;
	e = ref Env("string-length", cell->BuiltIn, nil, stringlen) :: e;
	e = ref Env("string->number", cell->BuiltIn, nil, strtonum) :: e;
	e = ref Env("string-ref", cell->BuiltIn, nil, stringref) :: e;
	e = ref Env("string-set!", cell->BuiltIn, nil, stringset) :: e;
	e = ref Env("string=?", cell->BuiltIn, nil, stringeq) :: e;
	e = ref Env("string-ci=?", cell->BuiltIn, nil, stringcieq) :: e;
	e = ref Env("string<?", cell->BuiltIn, nil, stringlt) :: e;
	e = ref Env("string>?", cell->BuiltIn, nil, stringgt) :: e;
	e = ref Env("string<=?", cell->BuiltIn, nil, stringle) :: e;
	e = ref Env("string>=?", cell->BuiltIn, nil, stringge) :: e;
	e = ref Env("string-ci<?", cell->BuiltIn, nil, stringcilt) :: e;
	e = ref Env("string-ci>?", cell->BuiltIn, nil, stringcigt) :: e;
	e = ref Env("string-ci<=?", cell->BuiltIn, nil, stringcile) :: e;
	e = ref Env("string-ci>=?", cell->BuiltIn, nil, stringcige) :: e;
	e = ref Env("substring", cell->BuiltIn, nil, substring) :: e;
	e = ref Env("string-append", cell->BuiltIn, nil, stringappend) :: e;
	e = ref Env("string-copy", cell->BuiltIn, nil, stringcopy) :: e;
	e = ref Env("string-fill!", cell->BuiltIn, nil, stringfill) :: e;
	e = ref Env("string->symbol", cell->BuiltIn, nil, str2sym) :: e;
	e = ref Env("symbol?", cell->BuiltIn, nil, symbolp) :: e;
	e = ref Env("symbol->string", cell->BuiltIn, nil, sym2str) :: e;
	e = ref Env("tan", cell->BuiltIn, nil, tan) :: e;
	e = ref Env("truncate", cell->BuiltIn, nil, truncate) :: e;
	e = ref Env("values", cell->BuiltIn, nil, values) :: e;
	e = ref Env("vector?", cell->BuiltIn, nil, vectorp) :: e;
	e = ref Env("vector-length", cell->BuiltIn, nil, vectorlen) :: e;
	e = ref Env("vector-ref", cell->BuiltIn, nil, vectorref) :: e;
	e = ref Env("vector-set!", cell->BuiltIn, nil, vectorset) :: e;
	e = ref Env("write", cell->BuiltIn, nil, lwrite) :: e;
	e = ref Env("write-char", cell->BuiltIn, nil, writechar) :: e;
	l := e;
	while(l != cell->nullenvironment) {
		x := hd l;
		if(x.ilk == cell->BuiltIn || x.ilk == cell->SpecialForm)
			x.val = ref Cell.Internal(x.name, x);
		l = tl l;
	}
	cell->baseenv = e;
	cell->globalenv = e;
}

newilk(ilk1: int, ilk2: int): (int, int)
{
	zt := ilk1 & ~cell->Exact;
	yt := ilk2 & ~cell->Exact;
	if(zt == cell->Complex || yt == cell->Complex)
		t := cell->Complex;
	else if(zt == cell->Real || yt == cell->Real)
		t = cell->Real;
	else if(zt == cell->Rational || yt == cell->Rational)
		t = cell->Rational;
	else
		t = cell->Integer;
	return (t, ilk1 & ilk2 & cell->Exact);
}

acos(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in acos\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->acos(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Real));
	* =>
		cell->error("non-numeric argument to acos\n");
		return (0, ref Cell.Link(nil));
	}
	return (0, ref Cell.Number(big 0, big 1, 0.0, cell->Integer | cell->Exact));
}

add(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil)
		return (0, ref Cell.Number(
			big 0, big 1, 0.0, cell->Integer|cell->Exact));
	pick y := x {
	Number =>
		if(cell->isnil(l)) {
			return (0, ref Cell.Number(y.i, y.j, y.r, y.ilk));
		}
		(nil, r) := add(l, env);
		pick z := r {
		Number =>
			(t, e) := newilk(z.ilk, y.ilk);
			if(t == cell->Real) {
				s := y.r + z.r;
				return (0, ref Cell.Number(big s, big 1, s, t | e));
			}
			else {
				sn, sd: big;
				if(y.j == z.j) {
					sn = y.i + z.i;
					sd = y.j;
				}
				else {
					sn = y.i * z.j + z.i * y.j;
					sd = y.j * z.j;
				}
				if(sd != big 1)
					(sn, sd) = reduce(sn, sd);
				if(sd == big 1)
					t = cell->Integer;
				else
					t = cell->Rational;
				return (0, ref Cell.Number(sn, sd, real sn / real sd, t | e));
			}
		* =>
			cell->error("non-numeric argument to +\n");
			return (0, ref Cell.Link(nil));
		}
	* =>
		cell->error("non-numeric argument to +\n");
		return (0, ref Cell.Link(nil));
	}
	return (0, ref Cell.Number(big 0, big 1, 0.0, cell->Integer|cell->Exact));
}

makequoted(x: ref Cell): ref Pair
{
	p1 := ref Pair(x, ref Cell.Link(nil));
	p2 := ref Pair(ref Cell.Symbol("quote", cell->lookupsym("quote", cell->globalenv)),
		ref Cell.Link(p1));
	return ref Pair(ref Cell.Link(p2), ref Cell.Link(nil));
}					

apply(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	if(args == nil || cell->isnil(args)) {
		cell->error("wrong number of arguments in apply\n");
		return (0, nil);
	}
#scheme->printenv(env);
	newargs := ref Cell.Link(ref Pair(cell->lcar(args), ref Cell.Link(nil)));
	np := cell->lcdr(newargs);
	oldp := cell->lcdr(args);
	firstpart := 1;
	while(1) {
		if(oldp == nil || cell->isnil(oldp))
			break;
		t := cell->lcdr(oldp);
		if(t == nil || cell->isnil(t)) {
			if(firstpart == 1) {
				oldp = cell->lcar(oldp);
				firstpart = 0;
			}
			else {
				pick npl := np {
				Link =>
					npl.next = makequoted(cell->lcar(oldp));
				}
				break;
			}
		}
		else {
			pick npl := np {
			Link =>
				npl.next = makequoted(cell->lcar(oldp));
			}
			np = cell->lcdr(np);
			oldp = t;
		}
	}
	(r, nil) := eval(newargs, env);
	return (0, r);
}

asin(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in asin\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->asin(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Real));
	* =>
		cell->error("non-numeric argument to asin\n");
		return (0, ref Cell.Link(nil));
	}
	return (0, ref Cell.Number(big 0, big 1, 0.0, cell->Integer | cell->Exact));
}

atan(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	n: real;

	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in atan\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n = y.r;
	* =>
		cell->error("non-numeric argument to atan\n");
		return (0, ref Cell.Link(nil));
	}
	l := cell->lcdr(args);
	if(l == nil || cell->isnil(l)) {
		m := math->atan(n);
		return (0, ref Cell.Number(big m, big 1, m, cell->Real));
	}
	z := cell->lcar(l);
	pick zn := z {
	Number =>
		m := math->atan2(n, zn.r);
		return (0, ref Cell.Number(big m, big 1, m, cell->Real));
	* =>
		cell->error("non-numeric argument to atan\n");
		return (0, ref Cell.Link(nil));
	}
	return (0, ref Cell.Link(nil));
}

callwcont(nil: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	return (0, ref Cell.Link(nil));
}

callwval(nil: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	return (0, ref Cell.Link(nil));
}

car(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	l := cell->lcar(args);
	if(l == nil) {
		cell->error("non-pair argument to car\n");
		return (0, nil);
	}
	return (0, cell->lcar(l));
}

cdr(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	l := cell->lcar(args);
	if(l == nil) {
		cell->error("non-pair argument to cdr\n");
		return (0, nil);
	}
	return (0, cell->lcdr(l));
}

ceiling(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in ceiling\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->ceil(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Integer | (y.ilk & cell->Exact)));
	* =>
		cell->error("non-numeric argument to ceiling\n");
	}
	return (0, ref Cell.Link(nil));
}

charp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in char?\n");
		return (0, nil);
	}
	pick y := x {
	Char =>
		return (0, ref Cell.Boolean(1));
	}
	return (0, ref Cell.Boolean(0));
}

chareqp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to char=?\n");
		return (0, nil);
	}
	pick x1 := x {
	Char =>
		pick y1 := y {
		Char =>
			if(x1.c == y1.c)
				return (0, ref Cell.Boolean(1));
		* =>
			cell->error("non-character argument to char=?\n");
			return (0, nil);
		}
	* =>
		cell->error("non-character argument to char=?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

charltp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to char<?\n");
		return (0, nil);
	}
	pick x1 := x {
	Char =>
		pick y1 := y {
		Char =>
			if(x1.c < y1.c)
				return (0, ref Cell.Boolean(1));
		* =>
			cell->error("non-character argument to char<?\n");
			return (0, nil);
		}
	* =>
		cell->error("non-character argument to char<?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

chargtp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to char>?\n");
		return (0, nil);
	}
	pick x1 := x {
	Char =>
		pick y1 := y {
		Char =>
			if(x1.c > y1.c)
				return (0, ref Cell.Boolean(1));
		* =>
			cell->error("non-character argument to char>?\n");
			return (0, nil);
		}
	* =>
		cell->error("non-character argument to char>?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

charlep(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to char<=?\n");
		return (0, nil);
	}
	pick x1 := x {
	Char =>
		pick y1 := y {
		Char =>
			if(x1.c <= y1.c)
				return (0, ref Cell.Boolean(1));
		* =>
			cell->error("non-character argument to char<=?\n");
			return (0, nil);
		}
	* =>
		cell->error("non-character argument to char<=?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

chargep(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to char>=?\n");
		return (0, nil);
	}
	pick x1 := x {
	Char =>
		pick y1 := y {
		Char =>
			if(x1.c >= y1.c)
				return (0, ref Cell.Boolean(1));
		* =>
			cell->error("non-character argument to char>=?\n");
			return (0, nil);
		}
	* =>
		cell->error("non-character argument to char>=?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

char2int(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in char->integer\n");
		return (0, nil);
	}
	pick y := x {
	Char =>
		return (0, ref Cell.Number(
			big y.c, big 1, real y.c, cell->Integer|cell->Exact));
	}
	cell->error("non-character argument to char->integer\n");
	return (0, nil);
}

closeinport(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in close-*-port\n");
		return (0, nil);
	}
	pick y := x {
	Port =>
		y.p = nil;
		y.dir = -1;
	* =>
		cell->error("non-port argument to close-*-port\n");
	}
	return (0, nil);
}

closeoutport(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	return closeinport(args, env);
}

complexp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in complex?\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		return (0, ref Cell.Boolean(1));
	}
	cell->error("non-numeric argument to complex?\n");
	return (0, nil);
}

cons(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
#	if(x == nil || l == nil || cell->isnil(l)) {
	if(x == nil || l == nil) {
		cell->error("wrong number of arguments in cons\n");
		return (0, nil);
	}
	return (0, cell->lcons(x, cell->lcar(l)));
}

cos(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in cos\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->cos(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Real));
	}
	cell->error("non-numeric argument to cos\n");
	return (0, ref Cell.Link(nil));
}

curinport(nil: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	return (0, ref Cell.Port(stdin, Bufio->OREAD));
}

curoutport(nil: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	return (0, ref Cell.Port(stdout, Bufio->OWRITE));
}

denominator(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in denominator\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		return (0, ref Cell.Number(y.j, big 1, real y.j, cell->Integer | (y.ilk & cell->Exact)));
	* =>
		cell->error("non-numeric argument to denominator\n");
		return (0, ref Cell.Link(nil));
	}
}

display(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	port := stdout;
	x := cell->lcar(args);
	if(x == nil)
		return (0, nil);
	l := cell->lcdr(args);
	if(l != nil && !(cell->isnil(l))) {
		p := cell->lcar(l);
		pick q := p {
		Port =>
			if(q.dir != -1)
				port = q.p;
			else
				return (0, nil);
		}
	}
	printcell(x, port, 1);
	return (0, x);
}

divide(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil) {
		cell->error("wrong number of arguments in /\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		if(cell->isnil(l)) {
			yn := y.i;
			yd := y.j;
			if (y.i < big 0) {
				yn = -yn;
				yd = -yd;
			}
			t := cell->Rational;
			if((y.ilk & ~cell->Exact) == cell->Real)
				t = cell->Real;
			else if(yn == big 1)
				t = cell->Integer;
			return (0, ref Cell.Number(yd, yn, 1.0 / y.r, t | (y.ilk & cell->Exact)));
		}
		(nil, r) := mult(l, env);
		pick z := r {
		Number =>
			(t, e) := newilk(z.ilk, y.ilk);
			if(t == cell->Real) {
				quot := y.r / z.r;
				return (0, ref Cell.Number(
					big quot, big 1, quot, cell->Real | e));
			}
			else {
				dn := y.i * z.j;
				dd := y.j * z.i;
				if (dd == big 0)
					return (0, ref Cell.Number(big 0, big 1, real 0,
						cell->Integer | cell->Exact));
				if(dd != big 1)
					(dn, dd) = reduce(dn, dd);
				if(dd == big 1)
					t = cell->Integer;
				else
					t = cell->Rational;
				return (0, ref Cell.Number(dn, dd, real dn / real dd, t | e));
			}
		}
	}
	cell->error("non-numeric argument to /\n");
	return (0, ref Cell.Link(nil));
}

dynwind(nil: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	return (0, ref Cell.Link(nil));
}

eofp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in eof?\n");
		return (0, nil);
	}
	pick y := x {
	Char =>
		if(y.c == Bufio->EOF)
			return (0, ref Cell.Boolean(1));
	* =>
		cell->error("non-character argument to eof?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

eqp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x1 := cell->lcar(args);
	l := cell->lcdr(args);
	x2 := cell->lcar(l);
	if(x1 == nil || x2 == nil|| l== nil || cell->isnil(l)) {
		cell->error("wrong number of arguments in eq?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(cell->leqp(x1, x2)));
}

eqvp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x1 := cell->lcar(args);
	l := cell->lcdr(args);
	x2 := cell->lcar(l);
	if(x1 == nil || x2 == nil || l== nil || cell->isnil(l)) {
		cell->error("wrong number of arguments in eqv?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(cell->leqvp(x1, x2)));
}

leval(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil || cell->isnil(l))
		return (0, nil);
	y := cell->lcar(l);
	if(y == nil) {
		cell->error("wrong number of arguments in eval\n");
		return (0, nil);
	}
	pick yn := y {
	Environment =>
		(c, nil) := eval(x, yn.env);
		return (0, c);
	* =>
		cell->error("non-environment argument to eval\n");
		return (0, nil);
	}
	return (0, nil);
}

exactp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in exact?\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		if(y.ilk & cell->Exact)
			return (0, ref Cell.Boolean(1));
	* =>
		cell->error("non-numeric argument to exact?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

extoinex(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in exact->inexact\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		return (0, ref Cell.Number(y.i, y.j, y.r, y.ilk & ~cell->Exact));
	}
	cell->error("non-numeric argument to exact->inexact\n");
	return (0, ref Cell.Number(big 0, big 1, 0.0, cell->Exact));
}

exp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in exp\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->exp(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Real));
	}
	cell->error("non-numeric argument to exp\n");
	return (0, ref Cell.Link(nil));
}

expt(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	z2: real;
	zl: int;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to expt\n");
		return (0, ref Cell.Link(nil));
	}
	pick yn := y {
	Number =>
		z2 = yn.r;
		zl = yn.ilk;
	* =>
		cell->error("non-numeric argument to expt\n");
		return (0, ref Cell.Link(nil));
	}
	pick xn := x {
	Number =>
		n := math->pow(xn.r, z2);
		if((zl & ~cell->Exact) == cell->Integer && (xn.ilk & ~cell->Exact) == cell->Integer)
			t := cell->Integer;
		else
			t = cell->Real;
		t |= zl & xn.ilk & cell->Exact;
		return (0, ref Cell.Number(big n, big 1, n, t));
	* =>
		cell->error("non-numeric argument to expt\n");
		return (0, ref Cell.Link(nil));
	}
	return (0, ref Cell.Link(nil));
}

floor(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in floor\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->floor(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Integer | (y.ilk & cell->Exact)));
	}
	cell->error("non-numeric argument to floor\n");
	return (0, ref Cell.Link(nil));
}

inexactp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in inexact?\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		if((y.ilk & cell->Exact) == 0)
			return (0, ref Cell.Boolean(1));
	* =>
		cell->error("non-numeric argument to inexact?\n");
		return (0, ref Cell.Link(nil));
	}
	return (0, ref Cell.Boolean(0));
}

inextoex(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in inexact->exact\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		return (0, ref Cell.Number(y.i, y.j, y.r, y.ilk | cell->Exact));
	}
	cell->error("non-numeric argument to inexact->exact\n");
	return (0, ref Cell.Link(nil));
}

inportp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in inport?\n");
		return (0, nil);
	}
	pick y := x {
	Port =>
		if(y.dir == Bufio->OREAD || y.dir == Bufio->ORDWR)
			return (0, ref Cell.Boolean(1));
	* =>
		cell->error("non-numeric argument to inport?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

integerp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to integer?\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		if(y.ilk & cell->Exact) {
			if(y.j == big 1)
				return (0, ref Cell.Boolean(1));
		}
		else {
			n := math->rint(y.r);
			if(real n == y.r)
				return (0, ref Cell.Boolean(1));
		}
	}
	return (0, ref Cell.Boolean(0));
}

int2char(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in integer->char\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		return (0, ref Cell.Char(int y.i));
	}
	cell->error("non-numeric argument to integer->char\n");
	return (0, nil);
}

interenv(nil: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	return (2, ref Cell.Environment(cell->globalenv));
}

llist(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	return (0, args);
}

lload(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to load\n");
		return (0, nil);
	}
	pick y := x {
	String =>
		b := bufio->open(y.str, Bufio->OREAD);
		if(b == nil) {
			cell->error(sys->sprint("can't load%s : %r\n", y.str));
			return (0, nil);
		}
		e := env;
		while(1) {
			c := readcell(b, e);
			if(c == nil)
				break;
			(nil, e) = eval(c, e);
		}
		b = nil;
		return (0, ref Cell.Environment(e));
	}
	cell->error("non-string argument to load\n");
	return (0, nil);
}

log(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in log\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->log(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Real));
	}
	cell->error("non-numeric argument to log\n");
	return (0, ref Cell.Link(nil));
}

makestring(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	c := ' ';
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in make-string\n");
		return (0, nil);
	}
	l := cell->lcdr(args);
	if(l != nil && !(cell->isnil(l))) {
		y := cell->lcar(l);
		if(y != nil) {
			pick y1 := y {
			Char =>
				c = y1.c;
			}
		}
	}
	pick x1 := x {
	Number =>
		s: string;
		for(i := 0; big i < x1.i; ++i)
			s[i] = c;
		return (0, ref Cell.String(s));
	}
	cell->error("non-numeric argument to make-string\n");
	return (0, nil);
}

makevector(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	v: array of ref Cell;
	k: int;

	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in make-vector\n");
		return (0, nil);
	}
	pick x1 := x {
	Number =>
		k = int x1.i;
		v = array[k] of ref Cell;
	* =>
		cell->error("non-numeric argument to make-vector\n");
		return (0, nil);
	}
	l := cell->lcdr(args);
	if(l != nil && !(cell->isnil(l))) {
		y := cell->lcar(l);
		for(i := 0; i < k; ++i)
			v[i] = y;
	}
	return (0, ref Cell.Vector(v));
}

minus(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil)
		return (0, ref Cell.Number(
			big 0, big 1, 0.0, cell->Integer|cell->Exact));
	pick y := x {
	Number =>
		if(cell->isnil(l))
			return (0, ref Cell.Number(-y.i, y.j, -y.r, y.ilk));
		(nil, r) := add(l, env);
		pick z := r {
		Number =>
			(t, e) := newilk(z.ilk, y.ilk);
			if(t == cell->Real) {
				diff := y.r - z.r;
				return (0, ref Cell.Number(big diff, big 1, diff, cell->Real | e));
			}
			else {
				dn, dd: big;
				if(y.j == z.j) {
					dn = y.i - z.i;
					dd = y.j;
				}
				else {
					dn = y.i * z.j - z.i * y.j;
					dd = y.j * z.j;
				}
				if(dd != big 1)
					(dn, dd) = reduce(dn, dd);
				if(dd == big 1)
					t = cell->Integer;
				else
					t = cell->Rational;
				return (0, ref Cell.Number(dn, dd, real dn / real dd, t | e));
			}
		* =>
			cell->error("non-numeric argument to -\n");
			return (0, ref Cell.Link(nil));
		}
	* =>
		cell->error("non-numeric argument to -\n");
		return (0, ref Cell.Link(nil));
	}
	return (0, ref Cell.Number(
		big 0, big 1, 0.0, cell->Integer|cell->Exact));
}

modulo(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	numer, denom: big;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments in modulo\n");
		return (0, ref Cell.Link(nil));
	}
	pick z := x {
	Number =>
		if((z.ilk & ~cell->Exact) == cell->Real)
			numer = big z.r;
		else
			numer = z.i;
		pick w := y {
		Number =>
			if((w.ilk & ~cell->Exact) == cell->Real)
				denom = big w.r;
			else
				denom = w.i;
			if (denom == big 0)
				return (0, ref Cell.Number(big 0, big 1, real 0, cell->Integer));
			mod := numer % denom;
			if(denom > big 0 && mod < big 0)
				mod += denom;
			else if(denom < big 0 && mod > big 0)
				mod += denom;
			return (0, ref Cell.Number(
				mod, big 1, real mod, cell->Integer | (z.ilk & w.ilk & cell->Exact)));
		* =>
			cell->error("non-numeric argument to modulo\n");
			return (0, ref Cell.Link(nil));
		}
	* =>
		cell->error("non-numeric argument to modulo\n");
		return (0, ref Cell.Link(nil));
	}
}

mult(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil)
		return (0, ref Cell.Number(
			big 1, big 1, 1.0, cell->Integer|cell->Exact));
	pick y := x {
	Number =>
		if(cell->isnil(l))
			return (0, ref Cell.Number(y.i, y.j, y.r, y.ilk));
		(nil, r) := mult(l, env);
		pick z := r {
		Number =>
			(t, e) := newilk(z.ilk, y.ilk);
			if(t == cell->Real) {
				prod := y.r * z.r;
				return (0, ref Cell.Number(big prod, big 1, prod, cell->Real | e));
			}
			else {
				pn := y.i * z.i;
				pd := y.j * z.j;
				if(pd != big 1)
					(pn, pd) = reduce(pn, pd);
				if(pd == big 1)
					t = cell->Integer;
				else
					t = cell->Rational;
				return (0, ref Cell.Number(pn, pd, real pn / real pd, t | e));
			}
		* =>
			cell->error("non-numeric argument to *\n");
			return (0, ref Cell.Link(nil));
		}
	* =>
		cell->error("non-numeric argument to *\n");
		return (0, ref Cell.Link(nil));
	}
	return (0, ref Cell.Number(
		big 0, big 1, 0.0, cell->Integer|cell->Exact));
}

nullenv(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	if(args == nil || cell->isnil(args))
		return (0, nil);
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in null-environment\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		if(y.i == big 5 && y.j == big 1)
			return (2, ref Cell.Environment(cell->nullenvironment));
	* =>
		cell->error("non-numeric argument to null-environment\n");
	}
	cell->error("unsupported environment version\n");
	return (0, nil);
}

numberp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to number?\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		return (0, ref Cell.Boolean(1));
	}
	return (0, ref Cell.Boolean(0));
}

numequal(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	y: ref Cell;
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil) {
		cell->error("wrong number of arguments in =\n");
		return (0, nil);
	}
	while(l != nil && !(cell->isnil(l))) {
		pick xn := x {
		Number =>
			y = cell->lcar(l);
			pick yn := y {
			Number =>
				(t, nil) := newilk(xn.ilk, yn.ilk);
				if(t == cell->Real) {
					if(xn.r != yn.r)
						return (0, ref Cell.Boolean(0));
				}
				else {
					if(xn.i * yn.j != yn.i * xn.j)
						return (0, ref Cell.Boolean(0));
				}
			* =>
				cell->error("non-numeric argument to =\n");
				return (0, nil);
			}
		* =>
			cell->error("non-numeric argument to =\n");
			return (0, nil);
		}
		l = cell->lcdr(l);
		x = y;
	}
	return (0, ref Cell.Boolean(1));
}

numgeq(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	y: ref Cell;
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil) {
		cell->error("wrong number of arguments in >=\n");
		return (0, nil);
	}
	while(l != nil && !(cell->isnil(l))) {
		pick xn := x {
		Number =>
			y = cell->lcar(l);
			pick yn := y {
			Number =>
				(t, nil) := newilk(xn.ilk, yn.ilk);
				if(t == cell->Real) {
					if(xn.r < yn.r)
						return (0, ref Cell.Boolean(0));
				}
				else {
					if(xn.i * yn.j < yn.i * xn.j)
						return (0, ref Cell.Boolean(0));
				}
			* =>
				cell->error("non-numeric argument to >=\n");
				return (0, nil);
			}
		* =>
			cell->error("non-numeric argument to >=\n");
			return (0, nil);
		}
		l = cell->lcdr(l);
		x = y;
	}
	return (0, ref Cell.Boolean(1));
}

numgreater(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	y: ref Cell;
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil) {
		cell->error("wrong number of arguments in >\n");
		return (0, nil);
	}
	while(l != nil && !(cell->isnil(l))) {
		pick xn := x {
		Number =>
			y = cell->lcar(l);
			pick yn := y {
			Number =>
				(t, nil) := newilk(xn.ilk, yn.ilk);
				if(t == cell->Real) {
					if(xn.r <= yn.r)
						return (0, ref Cell.Boolean(0));
				}
				else {
					if(xn.i * yn.j <= yn.i * xn.j)
						return (0, ref Cell.Boolean(0));
				}
			* =>
				cell->error("non-numeric argument to >\n");
				return (0, nil);
			}
		* =>
			cell->error("non-numeric argument to >\n");
			return (0, nil);
		}
		l = cell->lcdr(l);
		x = y;
	}
	return (0, ref Cell.Boolean(1));
}

numless(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	y: ref Cell;
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil) {
		cell->error("wrong number of arguments in <\n");
		return (0, nil);
	}
	while(l != nil && !(cell->isnil(l))) {
		pick xn := x {
		Number =>
			y = cell->lcar(l);
			pick yn := y {
			Number =>
				(t, nil) := newilk(xn.ilk, yn.ilk);
				if(t == cell->Real) {
					if(xn.r >= yn.r)
						return (0, ref Cell.Boolean(0));
				}
				else {
					if(xn.i * yn.j >= yn.i * xn.j)
						return (0, ref Cell.Boolean(0));
				}
			* =>
				cell->error("non-numeric argument to <\n");
				return (0, nil);
			}
		* =>
			cell->error("non-numeric argument to <\n");
			return (0, nil);
		}
		l = cell->lcdr(l);
		x = y;
	}
	return (0, ref Cell.Boolean(1));
}

numleq(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	y: ref Cell;
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil) {
		cell->error("wrong number of arguments in <=\n");
		return (0, nil);
	}
	while(l != nil && !(cell->isnil(l))) {
		pick xn := x {
		Number =>
			y = cell->lcar(l);
			pick yn := y {
			Number =>
				(t, nil) := newilk(xn.ilk, yn.ilk);
				if(t == cell->Real) {
					if(xn.r > yn.r)
						return (0, ref Cell.Boolean(0));
				}
				else {
					if(xn.i * yn.j > yn.i * xn.j)
						return (0, ref Cell.Boolean(0));
				}
			* =>
				cell->error("non-numeric argument to <=\n");
				return (0, nil);
			}
		* =>
			cell->error("non-numeric argument to <=\n");
			return (0, nil);
		}
		l = cell->lcdr(l);
		x = y;
	}
	return (0, ref Cell.Boolean(1));
}

numtostr(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	radix := 10;
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to number->string\n");
		return (0, nil);
	}
	l := cell->lcdr(args);
	if(l != nil && !(cell->isnil(l))) {
		y := cell->lcar(l);
		pick yn := y {
		Number =>
			radix = int yn.i;
		}
	}
	pick xn := x {
	Number =>
		t := xn.ilk & ~cell->Exact;
		if(t == cell->Real)
			return (0, ref Cell.String(sys->sprint("%.#g", xn.r)));
		case radix {
		2 =>
			if(t == cell->Integer)
				return (0, ref Cell.String(binstr(xn.i)));
			else
				return (0, ref Cell.String(sys->sprint("%s/%s",
					binstr(xn.i), binstr(xn.j))));
		8 =>	
			if(t == cell->Integer)
				return (0, ref Cell.String(sys->sprint("%bo", xn.i)));
			else
				return (0, ref Cell.String(
					sys->sprint("%bo/%bo", xn.i, xn.j)));
		16 =>
			if(t == cell->Integer)
				return (0, ref Cell.String(sys->sprint("%bx", xn.i)));
			else
				return (0, ref Cell.String(
					sys->sprint("%bx/%bx", xn.i, xn.j)));
		* =>
			if(t == cell->Integer)
				return (0, ref Cell.String(sys->sprint("%bd", xn.i)));
			else
				return (0, ref Cell.String(
					sys->sprint("%bd/%bd", xn.i, xn.j)));
		}
	* =>
		cell->error("non-numeric argument to number->string\n");
	}
	return (0, nil);
}

numerator(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to numerator\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		if(y.ilk & cell->Exact) {
			if(y.i >= big 0)
				n := y.i;
			else
				n = -y.i;
			return (0, ref Cell.Number(n, big 1, real n, cell->Integer | (y.ilk & cell->Exact)));
		}
	* =>
		cell->error("non-numeric argument to numerator\n");
	}
	return (0, ref Cell.Link(nil));
}

openinfile(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to open-input-file\n");
		return (0, nil);
	}
	pick y := x {
	String =>
		b := bufio->open(y.str, Bufio->OREAD);
		if(b == nil) {
			cell->error(sys->sprint("Cannot open %s: %r\n", y.str));
			return (0, nil);
		}
		return (0, ref Cell.Port(b, Bufio->OREAD));
	* =>
		cell->error("non-string argument to open-input-file\n");
	}
	return (0, nil);
}

openoutfile(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to open-output-file\n");
		return (0, nil);
	}
	pick y := x {
	String =>
		b := bufio->create(y.str, Bufio->OWRITE, 8r664);
		if(b == nil) {
			cell->error(sys->sprint("Cannot open %s: %r\n", y.str));
			return (0, nil);
		}
		return (0, ref Cell.Port(b, Bufio->OWRITE));
	* =>
		cell->error("non-string argument to open-output-file\n");
	}
	return (0, nil);
}

outportp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments for output-port?\n");
		return (0, nil);
	}
	pick y := x {
	Port =>
		if(y.dir == Bufio->OWRITE || y.dir == Bufio->ORDWR)
			return (0, ref Cell.Boolean(1));
	}
	return (0, ref Cell.Boolean(0));
}

pairp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to pair?\n");
		return (0, nil);
	}
	pick y := x {
	Link =>
		if(y.next != nil)
			return (0, 	ref Cell.Boolean(1));
	}
	return (0, ref Cell.Boolean(0));
}

peekchar(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	port: ref Iobuf;

	x := cell->lcar(args);
	if(x == nil)
		port = stdin;
	else {
		pick y := x {
		Port =>
			if(y.dir != -1)
				port = y.p;
			else {
				cell->error("non-open port in peek-char\n");
				return (0, nil);
			}
		}
	}
	c := port.getc();
	port.ungetc();
	return (0, ref Cell.Char(c));
}

procedurep(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to procedure?\n");
		return (0, nil);
	}
	pick y := x {
	Lambda =>
		return (0, ref Cell.Boolean(1));
	Internal =>
		return (0, ref Cell.Boolean(1));
	}
	return (0, ref Cell.Boolean(0));
}

quotient(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments in quotient\n");
		return (0, ref Cell.Link(nil));
	}
	pick z := x {
	Number =>
		pick w := y {
		Number =>
			q := z.i / w.i;
			return (0, ref Cell.Number(
				q, big 1, real q, cell->Integer | (z.ilk & w.ilk & cell->Exact)));
		* =>
			cell->error("non-numeric argument to quotient\n");
			return (0, ref Cell.Link(nil));
		}
	* =>
		cell->error("non-numeric argument to quotiend\n");
		return (0, ref Cell.Link(nil));
	}
	return (0, ref Cell.Link(nil));
}

rationalp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in rational?\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		if(y.ilk & cell->Exact)
			return (0, ref Cell.Boolean(1));
	* =>
		cell->error("non-numeric argument to rational?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

lread(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	port := stdin;
	x := cell->lcar(args);
	if(x != nil) {
		pick y := x {
		Port =>
			if(y.dir != -1)
				port = y.p;
			else {
				cell->error("non-open port in read\n");
				return (0, ref Cell.Link(nil));
			}
		}
	}
	r := readcell(port, env);
	if (r == nil)
		return (0, ref Cell.String(""));
	return (0, r);
}

preadchar(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	port := stdin;
	x := cell->lcar(args);
	if(x != nil) {
		pick y := x {
		Port =>
			if(y.dir != -1)
				port = y.p;
			else {
				cell->error("non-open port in read-char\n");
				return (0, nil);
			}
		}
	}
	c := port.getc();
	return (0, ref Cell.Char(c));
}

realp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to real?\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		return (0, ref Cell.Boolean(1));
	* =>
		cell->error("non-numeric argument to real?\n");
		return (0, nil);
	}
	return (0, ref Cell.Boolean(0));
}

remainder(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	numer, denom: big;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments in remainder\n");
		return (0, ref Cell.Link(nil));
	}
	pick z := x {
	Number =>
		numer = z.i;
		pick w := y {
		Number =>
			denom = w.i;
			mod := numer % denom;
			if(numer > big 0 && mod < big 0)
				mod += denom;
			else if(numer < big 0 && mod > big 0)
				mod -= denom;
			return (0, ref Cell.Number(
				mod, big 1, real mod, cell->Integer | (z.ilk & w.ilk & cell->Exact)));
		* =>
			cell->error("non-numeric argument in remainder\n");
			return (0, ref Cell.Link(nil));
		}
	* =>
		cell->error("non-numeric argument to remainder\n");
		return (0, ref Cell.Link(nil));
	}
}

round(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	math->FPcontrol(math->RND_NR, math->RND_MASK);
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to round\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->rint(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Integer | (y.ilk & cell->Exact)));
	* =>
		cell->error("non-numeric argument to round\n");
	}
	return (0, ref Cell.Link(nil));
}

schrepenv(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	if(args == nil || cell->isnil(args))
		return (0, nil);
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in scheme-repeat-environment\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		if(y.i == big 5 && y.j == big 1)
			return (2, ref Cell.Environment(cell->reportenv));
	* =>
		cell->error("non-numeric argument to scheme-report-environment\n");
	}
	cell->error("unsupported version in scheme-report-environment\n");
	return (0, nil);
}

setcar(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	p := cell->lcar(args);
	l := cell->lcdr(args);
	o := cell->lcar(l);
	if(p == nil || o == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments in set-car!\n");
		return (0, nil);
	}
	pick x := p {
	Link =>
		x.next.car = o;
	* =>
		cell->error("non-pair argument to set-car!\n");
		return (0, nil);
	}
	return (0, p);
}

setcdr(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	p := cell->lcar(args);
	l := cell->lcdr(args);
	o := cell->lcar(l);
	if(p == nil || o == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to set-cdr!\n");
		return (0, nil);
	}
	pick x := p {
	Link =>
		x.next.cdr = o;
	* =>
		cell->error("non-pair argument to set->cdr!\n");
		return (0, nil);
	}
	return (0, nil);
}

sin(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in sin\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->sin(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Real));
	* =>
		cell->error("non-numeric argument to sin\n");
	}
	return (0, ref Cell.Link(nil));
}

sqrt(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in sqrt\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->sqrt(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Real));
	* =>
		cell->error("non-numeric argument to sqrt\n");
	}
	return (0, ref Cell.Link(nil));
}

stringp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to string?\n");
		return (0, nil);
	}
	pick y := x {
	String =>
		return (0, ref Cell.Boolean(1));
	}
	return (0, ref Cell.Boolean(0));
}

stringlen(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in string-length\n");
		return (0, nil);
	}
	pick y := x {
	String =>
		z := len y.str;
		return (0, ref Cell.Number(
			big z, big 1, real z, cell->Integer|cell->Exact));
	* =>
		cell->error("non-string argument to string-length\n");
	}
	return (0, nil);
}

stringref(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	i: int;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to string-ref\n");
		return (0, nil);
	}
	pick y1 := y {
	Number =>
		i = int y1.i;
	* =>
		cell->error("non-numeric index in string-ref\n");
		return (0, nil);
	}
	pick x1 := x {
	String =>
		return (0, ref Cell.Char(x1.str[i]));
	* =>
		cell->error("non-string argument to string-ref\n");
	}
	return (0, nil);
}

stringset(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	i: int;
	c: int;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	l = cell->lcdr(l);
	z := cell->lcar(l);
	if(x == nil || y == nil || z == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to string-set!\n");
		return (0, nil);
	}
	pick y1 := y {
	Number =>
		i = int y1.i;
	* =>
		cell->error("non-numeric index to string-set!\n");
		return (0, nil);
	}
	pick z1 := z {
	Char =>
		c = z1.c;
	* =>
		cell->error("non-character fill in string-set!\n");
		return (0, nil);
	}
	pick x1 := x {
	String =>
		x1.str[i] = c;
	* =>
		cell->error("non-string argument to string-set!\n");
		return (0, nil);
	}
	return (0, x);
}

getstrargs(args: ref Cell): (int, string, string)
{
	s1: string;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments in string comparison\n");
		return (0, nil, nil);
	}
	pick x1 := x {
	String =>
		s1 = x1.str;
	* =>
		cell->error("non-string argument in string comparison\n");
		return (0,nil,nil);
	}
	pick y1 := y {
	String =>
		return (1, s1, y1.str);
	}
	cell->error("non-string argument in string comparison\n");
	return (0, nil, nil);
}

stringeq(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(s1 == s2)
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

stringcieq(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(str->toupper(s1) == str->toupper(s2))
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

stringlt(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(s1 < s2)
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

stringgt(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(s1 > s2)
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

stringle(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(s1 <= s2)
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

stringge(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(s1 >= s2)
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

stringcilt(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(str->toupper(s1) < str->toupper(s2))
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

stringcigt(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(str->toupper(s1) > str->toupper(s2))
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

stringcile(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(str->toupper(s1) <= str->toupper(s2))
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

stringcige(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	(r, s1, s2) := getstrargs(args);
	if(!r)
		return (0, nil);
	if(str->toupper(s1) >= str->toupper(s2))
		return (0, ref Cell.Boolean(1));
	else
		return (0, ref Cell.Boolean(0));
}

strtonum(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil) {
		cell->error("wrong number of arguments in string->number\n");
		return (0, nil);
	}
	radix := 10;
	if(l != nil && !(cell->isnil(l))) {
		y := cell->lcar(l);
		if(y == nil) {
			cell->error("non-numeric radix in string->number\n");
			return (0, nil);
		}
		pick yn := y {
		Number =>
			radix = int yn.i;
		* =>
			cell->error("non-numeric radix in string->number\n");
			return (0, nil);
		}
	}
	pick xn := x {
	String =>
		if(xn.str == "")
			return (0, ref Cell.Boolean(0));
		return (0, scannum(xn.str, radix));
	* =>
		cell->error("non-string argument to string->number\n");
	}
	return (0, nil);
}

substring(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	start, end: int;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	l = cell->lcdr(l);
	z := cell->lcar(l);
	if(x == nil || y == nil || z == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments in substring\n");
		return (0, nil);
	}
	pick y1 := y {
	Number =>
		start = int y1.i;
	* =>
		cell->error("non-numeric index in substring\n");
		return (0, nil);
	}
	pick z1 := z {
	Number =>
		end = int z1.i;
	* =>
		cell->error("non-numeric index in substring\n");
		return (0, nil);
	}
	pick x1 := x {
	String =>
		return (0, ref Cell.String(x1.str[start:end]));
	* =>
		cell->error("non-string argument to substring\n");
	}
	return (0, nil);
}

stringappend(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	s := "";
	l := args;
	while(l != nil && !(cell->isnil(l))) {
		x := cell->lcar(l);
		if(x == nil)
			return (0, nil);
		l = cell->lcdr(l);
		pick y := x {
		String =>
			s += y.str;
		* =>
			cell->error("non-string argument to string-append\n");
			return (0, nil);
		}
	}
	return (0, ref Cell.String(s));
}

stringcopy(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to string-copy\n");
		return (0, nil);
	}
	pick y := x {
	String =>
		return (0, ref Cell.String(y.str));
	* =>
		cell->error("non-string argument to string-copy\n");
	}
	return (0, nil);
}

stringfill(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	c: int;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to string-fill!\n");
		return (0, nil);
	}
	pick y1 := y {
	Char =>
		c = y1.c;
	* =>
		cell->error("non-character fill in string-fill!\n");
		return (0, nil);
	}
	pick x1 := x {
	String =>
		for(i := 0; i < len x1.str; ++i)
			x1.str[i] = c;
	* =>
		cell->error("non-string argument to string-fill!\n");
		return (0, nil);
	}
	return (0, x);
}

str2sym(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in string->symbol\n");
		return (0, nil);
	}
	pick y := x {
	String =>
		return (0, ref Cell.Symbol(y.str, nil));
	* =>
		cell->error("non-string argument to string->symbol\n");
	}
	return (0, nil);
}

symbolp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to symbol?\n");
		return (0, nil);
	}
	pick y := x {
	Symbol =>
		return (0, ref Cell.Boolean(1));
	}
	return (0, ref Cell.Boolean(0));
}

sym2str(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in symbol->string\n");
		return (0, nil);
	}
	pick y := x {
	Symbol =>
		return (0, ref Cell.String(y.sym));
	* =>
		cell->error("non-symbol argument to symbol->string\n");
	}
	return (0, nil);
}

tan(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in tan\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		n := math->tan(y.r);
		return (0, ref Cell.Number(big n, big 1, n, cell->Real));
	* =>
		cell->error("non-numeric argument to tan\n");
	}
	return (0, ref Cell.Link(nil));
}

truncate(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to truncate\n");
		return (0, ref Cell.Link(nil));
	}
	pick y := x {
	Number =>
		math->FPcontrol(math->RND_Z, math->RND_MASK);
		n := math->rint(y.r);
		math->FPcontrol(math->RND_NR, math->RND_MASK);
		return (0, ref Cell.Number(big n, big 1, n, cell->Integer | (y.ilk & cell->Exact)));
	* =>
		cell->error("non-numeric argument to truncate\n");
	}
	return (0, ref Cell.Link(nil));
}

values(nil: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	return (0, ref Cell.Link(nil));
}

vectorp(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in vector?\n");
		return (0, nil);
	}
	pick y := x {
	Vector =>
		return (0, ref Cell.Boolean(1));
	}
	return (0, ref Cell.Boolean(0));
}

vectorlen(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments in vector-length\n");
		return (0, nil);
	}
	pick y := x {
	Vector =>
		z := len y.v;
		return (0, ref Cell.Number(
			big z, big 1, real z, cell->Integer|cell->Exact));
	* =>
		cell->error("non-vector argument to vector-length\n");
	}
	return (0, nil);
}

vectorref(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	k: int;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	if(x == nil || y == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments in vector-ref\n");
		return (0, nil);
	}
	pick y1 := y {
	Number =>
		k = int y1.i;
	* =>
		cell->error("non-numeric index in vector-ref\n");
		return (0, nil);
	}
	pick x1 := x {
	Vector =>
		return (0, x1.v[k]);
	* =>
		cell->error("non-vector argument to vector-ref\n");
	}
	return (0, nil);
}

vectorset(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	k: int;

	x := cell->lcar(args);
	l := cell->lcdr(args);
	y := cell->lcar(l);
	l = cell->lcdr(l);
	z := cell->lcar(l);
	if(x == nil || y == nil || z == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of arguments to vector-set!\n");
		return (0, nil);
	}
	pick y1 := y {
	Number =>
		k = int y1.i;
	* =>
		cell->error("non-numeric index in vector-set!\n");
		return (0, nil);
	}
	pick x1 := x {
	Vector =>
		x1.v[k] = z;
	* =>
		cell->error("non-vector argument to vector-set!\n");
	}
	return (0, z);
}

lwrite(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	port := stdout;
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(l != nil && !(cell->isnil(l))) {
		p := cell->lcar(l);
		if(p == nil) {
			cell->error("invalid port in write\n");
			return (0, nil);
		}
		pick q := p {
		Port =>
			if(q.dir != -1)
				port = q.p;
			else {
				cell->error("non-open port in write\n");
				return (0, nil);
			}
		}
	}
	printcell(x, port, 0);
	return (0, x);
}

writechar(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	port := stdout;
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to write-char\n");
		return (0, nil);
	}
	l := cell->lcdr(args);
	if(l != nil && !(cell->isnil(l))) {
		p := cell->lcar(l);
		if(p == nil) {
			cell->error("invalid port in write-char\n");
			return (0, nil);
		}
		pick q := p {
		Port =>
			if(q.dir != -1)
				port = q.p;
			else {
				cell->error("non-open port in write-char\n");
				return (0, nil);
			}
		}
	}
	pick y := x {
	Char =>
		port.putc(y.c);
	* =>
		cell->error("non-character argument to write-char\n");
		return (0, nil);
	}
	port.flush();
	return (0, x);
}

binstr(n: big): string
{
	if(n == big 0)
		return "0";
	s := "";
	while(n != big 0) {
		if((n & big 1) == big 1)
			s = "1" + s;
		else
			s = "0" + s;
		n >>= 1;
	}
	if(len s != 64)
		s = "0" + s;
	return s;
}

BuiltIn: module
{
	PATH: con "/dis/scheme/builtin.dis";

	init: fn(sy: Sys, sch: Scheme, c: SCell, m: Math, st: String,
		b: Bufio, in: ref Iobuf, out: ref Iobuf);
	closeinport: fn(args: ref Cell, env: list of ref Env): (int, ref Cell);

};

implement SCell;

include "sys.m";
sys: Sys;

include "bufio.m";
bufio: Bufio;
Iobuf: import bufio;

include "cell.m";

init(s: Sys)
{
	sys = s;
}

lcar(args: ref Cell): ref Cell
{
	if(args == nil)
		return nil;
	pick x := args {
	Link =>
		if(x.next == nil)
			return nil;
		return x.next.car;
	}
	return nil;
}

lcdr(args: ref Cell): ref Cell
{
	if(args == nil)
		return nil;
	pick x := args {
	Link =>
		if(x.next == nil)
			return nil;
		return x.next.cdr;
	}
	return nil;
}

lcons(car: ref Cell, cdr: ref Cell) : ref Cell
{
	return ref Cell.Link(ref Pair(car, cdr));
}

ldefine(sym: string, exp: ref Cell, envlist: list of ref Env):
	(ref Cell, list of ref Env)
{
	ilk: int;
	f: ref fn(args: ref Cell, env: list of ref Env): (int, ref Cell);

	if(exp == nil)
		return (ref Cell.Link(nil), envlist);
	if(sym == "") {
		error("empty string for variable in define\n");
		return (ref Cell.Link(nil), envlist);
	}
	ilk = Variable;
	f = nil;
	if(exp != nil) {
		pick q := exp {
		Symbol =>
			if(q.env != nil) {
				ilk = q.env.ilk;
				f = q.env.handler;
			}
		}
	}
	e := ref Env(sym, ilk, exp, f);
	envlist = e :: envlist;
	return (ref Cell.Symbol(sym, e), envlist);
}

leqp(x1, x2: ref Cell): int
{
	pick y1 := x1 {
	Boolean =>
		pick y2 := x2 {
		Boolean =>
			if(y1.b == y2.b)
				return 1;
		}
	Symbol =>
		pick y2 := x2 {
		Symbol =>
			if(y1.sym == y2.sym)
				return 1;
		}
	String =>
		pick y2 := x2 {
		String =>
			if(y1.str == y2.str)
				return 1;
		}
	Char =>
		pick y2 := x2 {
		Char =>
			if(y1.c == y2.c)
				return 1;
		}
	Number =>
		pick y2 := x2 {
		Number =>
			if((y1.ilk ^ y2.ilk) & Exact) 
				return 0;
			else if(y1.ilk & y2.ilk & Exact) {
				if(y1.i == y2.i && y1.j == y2.j)
					return 1;
			}
			else {
				if(y1.r == y2.r)
					return 1;
			}
		}
	Link =>
		pick y2 := x2 {
		Link =>
			if(y1.next == nil && y2.next == nil)
				return 1;
			if(y1.next != nil && y2.next != nil
					&& y1.next.car == y2.next.car
					&& y1.next.cdr == y2.next.cdr)
				return 1;
		}
	Lambda =>
		pick y2 := x2 {
		Lambda =>
			if(y1 == y2)
				return 1;
		}
	Vector =>
		pick y2 := x2 {
		Vector =>
			if(len y1.v != len y2.v)
				return 0;
			for(i := 0; i < len y1.v; ++i)
				if(leqp(y1.v[i], y2.v[i]) == 0)
					return 0;
			return 1;
		}
	Port =>
		pick y2 := x2 {
		Port =>
			if(y1.p == y2.p && y1.dir == y2.dir)
				return 1;
		}
	Internal =>
		pick y2 := x2 {
		Internal =>
			if(y1.env == y2.env)
				return 1;
		}
	* =>
		sys->print("eq? of unrecognized type\n");
	}
	return 0;
}

leqvp(x1, x2: ref Cell): int
{
	pick y1 := x1 {
	Boolean =>
		pick y2 := x2 {
		Boolean =>
			if(y1.b == y2.b)
				return 1;
		}
	Symbol =>
		pick y2 := x2 {
		Symbol =>
			if(y1.sym == y2.sym)
				return 1;
		}
	String =>
		pick y2 := x2 {
		String =>
			if(y1.str == y2.str)
				return 1;
		}
	Char =>
		pick y2 := x2 {
		Char =>
			if(y1.c == y2.c)
				return 1;
		}
	Number =>
		pick y2 := x2 {
		Number =>
			if((y1.ilk ^ y2.ilk) & Exact) 
				return 0;
			else if(y1.ilk & y2.ilk & Exact) {
				if(y1.i == y2.i && y1.j == y2.j)
					return 1;
			}
			else {
				if(y1.r == y2.r)
					return 1;
			}
		}
	Link =>
		pick y2 := x2 {
		Link =>
			if(y1.next == nil && y2.next == nil)
				return 1;
			if(y1.next != nil && y2.next != nil
					&& y1.next.car == y2.next.car
					&& y1.next.cdr == y2.next.cdr)
				return 1;
		}
	Lambda =>
		pick y2 := x2 {
		Lambda =>
			if(y1 == y2)
				return 1;
		}
	Vector =>
		pick y2 := x2 {
		Vector =>
			if(len y1.v != len y2.v)
				return 0;
			for(i := 0; i < len y1.v; ++i)
				if(leqvp(y1.v[i], y2.v[i]) == 0)
					return 0;
			return 1;
		}
	Port =>
		pick y2 := x2 {
		Port =>
			if(y1.p == y2.p && y1.dir == y2.dir)
				return 1;
		}
	Internal =>
		pick y2 := x2 {
		Internal =>
			if(y1.env == y2.env)
				return 1;
		}
	}
	return 0;
}

lappend(c1, c2: ref Cell): ref Cell
{
	if(c1 == nil || isnil(c1))
		return c2;
	return lcons(lcar(c1), lappend(lcdr(c1), c2));
}

isnil(l: ref Cell): int
{
	if(l == nil)
		return 0;
	pick x := l {
	Link =>
		if(x.next == nil)
			return 1;
	}
	return 0;
}

lookupsym(symbol: string, env: list of ref Env): ref Env
{
	for(l := env; l != nil; l = tl l) {
		x := hd l;
		if(x.name == symbol)
			return x;
	}
	for(l = globalenv; l != nil; l = tl l) {
		x := hd l;
		if(x.name == symbol)
			return x;
	}
	return nil;
}

listappend(l1, l2: list of ref Env): list of ref Env
{
	if(l1 == nil)
		return l2;
	return hd l1 :: listappend(tl l1, l2);
}

error(s: string)
{
	sys->fprint(sys->fildes(2), "*** Error: %s", s);
}

SCell: module
{
	PATH: con "/dis/scheme/cell.dis";

	Cell: adt
	{
		pick {
		Boolean =>
			b: int;
		Symbol =>
			sym: string;
			env: ref Env;
		Internal =>
			sym: string;
			env: ref Env;
		String =>
			str: string;
		Char =>
			c: int;
		Number =>
			i, j: big;
			r: real;
			ilk: int;
		Link =>
			next: cyclic ref Pair;
		Lambda =>
			formals: cyclic ref Cell;
			exp_list: cyclic ref Cell;
			env: list of ref Env;
		Vector =>
			v: cyclic array of ref Cell;
		Port =>
			p: ref Iobuf;
			dir: int;
		Environment =>
			env: list of ref Env;
		Channel =>
			ch: chan of ref Cell;
		Promise =>
			proc, val: cyclic ref Cell;
			env: list of ref Env;
		Continuation =>
			exp: cyclic ref Cell;
			env: list of ref Env;
		}
	};

	Integer,
	Rational,
	Real,
	Complex: con iota;
	Exact: con 16r80;

	Pair: adt
	{
		car: cyclic ref Cell;
		cdr: cyclic ref Cell;
	};

	Env: adt
	{
		name: string;
		ilk: int;
		val: cyclic ref Cell;
		handler: ref fn (args: ref Cell, env: list of ref Env): (int, ref Cell);
	};

	SpecialForm,
	BuiltIn,
	Procedure,
	Variable: con iota;

	baseenv: list of ref Env;
	reportenv, nullenvironment: list of ref Env;
	globalenv: list of ref Env;

	init: fn(s: Sys);
	lcar: fn(args: ref Cell): ref Cell;
	lcdr: fn(args: ref Cell): ref Cell;
	lcons: fn(car: ref Cell, cdr: ref Cell): ref Cell;
	ldefine: fn(sym: string, exp: ref Cell, envlist: list of ref Env):
		(ref Cell, list of ref Env);
	leqp: fn(x1, x2: ref Cell): int;
	leqvp: fn(x1, x2: ref Cell): int;
	lappend: fn(c1, c2: ref Cell): ref Cell;
	isnil: fn(l: ref Cell): int;
	lookupsym: fn(symbl: string, env: list of ref Env): ref Env;
	listappend: fn(l1, l2: list of ref Env): list of ref Env;
	error: fn(s: string);
};

implement Extension;

include "sys.m";
sys: Sys;
include "draw.m";
include "math.m";
math: Math;
include "string.m";
str: String;

include "sh.m";

include "bufio.m";
bufio: Bufio;
Iobuf: import bufio;

include "cell.m";
cell: SCell;
Cell: import cell;
Pair: import cell;
Env: import cell;

include "scheme.m";
scheme: Scheme;
eval: import scheme;

include "builtin.m";
builtin: BuiltIn;
closeinport: import builtin;

include "sform.m";

stdout:  ref Iobuf = nil;

ctxt: ref Draw->Context;

include "extension.m";

init(drawctxt: ref Draw->Context, s: Sys, sch: Scheme, c: SCell,
	b: BuiltIn, m: Math, st: String, bi: Bufio)
{
	ctxt = drawctxt;
	sys = s;
	scheme = sch;
	cell = c;
	builtin = b;
	math = m;
	str = st;
	bufio = bi;

	e := cell->globalenv;
	e = ref Env("<-=", cell->BuiltIn, nil, lsend) :: e;
	e = ref Env("=<-", cell->BuiltIn, nil, lrecv) :: e;
	e = ref Env("alt", cell->SpecialForm, nil, lalt) :: e;
	e = ref Env("channel", cell->BuiltIn, nil, lchannel) :: e;
	e = ref Env("close-inout-port", cell->BuiltIn, nil, closeinoutport) :: e;
	e = ref Env("open-inout-file", cell->BuiltIn, nil, openinoutfile) :: e;
	e = ref Env("open-input-string", cell->BuiltIn, nil, openinstr) :: e;
	e = ref Env("popen", cell->BuiltIn, nil, popen) :: e;
	e = ref Env("quit", cell->BuiltIn, nil, quit) :: e;
	e = ref Env("readfile", cell->BuiltIn, nil, readfile) :: e;
	e = ref Env("readline", cell->BuiltIn, nil, readline) :: e;
	e = ref Env("sleep", cell->BuiltIn, nil, lsleep) :: e;
	e = ref Env("spawn", cell->SpecialForm, nil, lspawn) :: e;
	cell->globalenv = e;
	l := e;
	while(l != nil) {
		x := hd l;
		if(x.ilk == cell->BuiltIn || x.ilk == cell->SpecialForm)
			x.val = ref Cell.Internal(x.name, x);
		l = tl l;
	}
}

lalt(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := args;
	i := 0;
	while(x != nil && !cell->isnil(x)) {
		++i;
		x = cell->lcdr(x);
	}
	ca := array[i] of chan of ref Cell;
	x = args;
	i = 0;
	while(x != nil && !cell->isnil(x)) {
		y := cell->lcar(x);
		if (y != nil && !cell->isnil(y)) {
			(r, nil) := eval(y, env);
			pick z := r {
			Channel =>
				ca[i++] = z.ch;
			}
		}
		x = cell->lcdr(x);
	}
	(idx, val) := <- ca;
	ic := ref Cell.Number(big idx, big 1, real idx, cell->Integer|cell->Exact);
	return (0, cell->lcons(ic, cell->lcons(val, ref Cell.Link(nil))));
}

lchannel(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	if(args == nil || cell->isnil(args)) {
		c := chan of ref Cell;
		return (0, ref Cell.Channel(c));
	}	
	x := cell->lcar(args);
	if(x == nil || cell->isnil(x)) {
		c := chan of ref Cell;
		return (0, ref Cell.Channel(c));
	}
	pick y := x {
	Number =>
		c := chan [int y.i] of ref Cell;
		return (0, ref Cell.Channel(c));
	}
	return (0, ref Cell.Link(nil));
}

closeinoutport(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	return closeinport(args, env);
}

openinoutfile(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to open-input-file\n");
		return (0, nil);
	}
	pick y := x {
	String =>
		b := bufio->open(y.str, Bufio->ORDWR);
		if(b == nil) {
			cell->error(sys->sprint("Cannot open %s: %r\n", y.str));
			return (0, nil);
		}
		return (0, ref Cell.Port(b, Bufio->ORDWR));
	* =>
		cell->error("non-string argument to open-input-file\n");
	}
	return (0, nil);
}

openinstr(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to open-input-file\n");
		return (0, nil);
	}
	pick y := x {
	String =>
		b := bufio->sopen(y.str);
		if(b == nil) {
			cell->error(sys->sprint("Cannot open %s: %r\n", y.str));
			return (0, nil);
		}
		return (0, ref Cell.Port(b, Bufio->OREAD));
	* =>
		cell->error("non-string argument to open-input-string\n");
	}
	return (0, nil);
}

popen(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	cmd: string;
	r: ref Cell;

	r = nil;
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to popen\n");
		return (0, nil);
	}
	pick name := x {
	String =>
		cmd = name.str;
	* =>
		cell->error("non-string argument to popen\n");
		return (0, nil);
	}
	infds := array[2] of ref Sys->FD;
	outfds := array[2] of ref Sys->FD;
	sys->pipe(infds);
	sys->pipe(outfds);
	spawn startshell(cmd, outfds[0], infds[1]);
	outfds[0] = nil;
	infds[1] = nil;
	rb := bufio->fopen(infds[0], Bufio->OREAD);
	tb := bufio->fopen(outfds[1], Bufio->OWRITE);
	rc := ref Cell.Port(rb, Bufio->OREAD);
	tc := ref Cell.Port(tb, Bufio->OWRITE);
	return (0, cell->lcons(rc, cell->lcons(tc, ref Cell.Link(nil))));
}

readfile(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	if(args == nil || cell->isnil(args))
		return (0, ref Cell.Link(nil));
	x := cell->lcar(args);
	pick y := x {
	String =>
		(exists, d) := sys->stat(y.str);
		if(exists != 0)
			return (0, ref Cell.Link(nil));
		buf := array [int d.length] of byte;
		fd := sys->open(y.str, Sys->OREAD);
		if(fd == nil)
			return (0, ref Cell.Link(nil));
		sys->read(fd, buf, int d.length);
		return (0, ref Cell.String(string buf));
	}
	return (0, ref Cell.Link(nil));
}

readline(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	if(args == nil || cell->isnil(args))
		return (0, ref Cell.Link(nil));
	x := cell->lcar(args);
	pick y := x {
	Port =>
		s := y.p.gets('\n');
		return (0, ref Cell.String(s));
	}
	return (0, ref Cell.Link(nil));
}

quit(nil: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	exit;
}

lrecv(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	pick y := x {
	Channel =>
		r := <- y.ch;
		return (0, r);
	}
	cell->error("recv must have a channel argument\n");
	return (0, nil);
}

lsend(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	cdrarg := cell->lcdr(args);
	if (cdrarg == nil || cell->isnil(cdrarg)) {
		cell->error("wrong number of arguments in lsend\n");
		return (0, nil);
	}
	y := cell->lcar(cell->lcdr(args));
	pick z := y {
	Channel =>
		z.ch <- = x;
		return (0, x);
	}
	cell->error("send must have a channel argument\n");
	return (0, nil);
}
	

lsleep(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if (x == nil) {
		cell->error("wrong number of argument in sleep\n");
		return (0, nil);
	}
	pick y := x {
	Number =>
		sys->sleep(int y.i);
	}
	return (0, nil);
}

startshell(cmd: string, infd: ref Sys->FD, outfd: ref Sys->FD)
{
	sh := load Sh Sh->PATH;
	if(sh == nil) {
		sys->print("loading sh failed: %r\n");
		exit;
	}
	sys->pctl(Sys->NEWFD, 2 :: infd.fd :: outfd.fd :: nil);
	sys->dup(infd.fd, 0);
	sys->dup(outfd.fd, 1);
	infd = nil;
	outfd = nil;
	sh->init(ctxt, "sh" :: "-c" :: cmd :: nil);
	cell->error(sys->sprint("child shell returned: %r\n"));
}

seval(args: ref Cell, env: list of ref Env)
{
	if (args == nil || cell->isnil(args)) {
		cell->error("Empty spawn");
		exit;
	}
	eval(cell->lcar(args), env);
	exit;
}

lspawn(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	spawn seval(args, env);
	return (0, ref Cell.Link(nil));
}

Extension: module
{
	PATH: con "/dis/scheme/extension.dis";

	init: fn(drawctxt: ref Draw->Context, s: Sys, sch: Scheme, c: SCell,
		b: BuiltIn, m: Math, st: String, bi: Bufio);
};

(define fact (lambda (n)
  (if (= n 0)
      1
      (* n (fact (- n 1))))))

;;;
;;; Vector Operations
;;;
(define vector->list
  (lambda (v)
    (define vliter
      (lambda (v k n)
        (if (= k n)
            '()
            (cons (vector-ref v k) (vliter v (+ k 1) n)))))
    (vliter v 0 (vector-length v))))
(define list->vector
  (lambda (l)
    (define dolv
      (lambda (v k l)
        (vector-set! v k (car l))
        (lviter v (+ k 1) (cdr l))))
    (define lviter
      (lambda (v k l)
        (if (null? l)
            v
            (dolv v k l))))
    (lviter (make-vector (length l)) 0 l)))
(define vector (lambda l (list->vector l)))
(define vector-fill!
  (lambda (v f)
    (define n (vector-length v))
    (define vfiter
      (lambda (v f k)
        (if (= k 0)
            (vector-set! v 0 f)
            ((lambda (v f k)
              (vector-set! v k f)
              (vfiter v f (- k 1))) v f k))))
    (vfiter v f (- n 1))))

;;;
;;; Equivalence operations
;;;
;(define equal?
;  (lambda (x y)
;    (define listeq
;      (lambda (x y)
;        (if (null? x)
;            (if (null? y) #t #f)
;            (if (equal? (car x) (car y)) (equal? (cdr x) (cdr y)) #f))))
;    (if (not (pair? x))
;        (if (not (pair? y)) (eqv? x y) #f)
;        (if (not (pair? y))
;            #f
;            (listeq x y)))))

(define equal?
  (lambda (x y)
    (define listeq
      (lambda (x y)
        (cond
          ((and (null? x) (null? y)) #t)
          ((or (null? x) (null? y)) #f)
          ((equal? (car x) (car y)) (equal? (cdr x) (cdr y)))
          (#t #f)
        )
      )
    )
    (cond
      ((and (pair? x) (pair? y)) (listeq x y))
      ((and (vector? x) (vector? y)) (listeq (vector->list x) (vector->list y)))
      ((or (pair? x) (pair? y)) #f)
      ((or (vector? x) (vector? y)) #f)
      (#t (eqv? x y))
    )
  )
)

;;;
;;; Boolean operations
;;;
(define not (lambda (b) (if (eq? b #f) #t #f)))
(define boolean? (lambda (x) (if (eqv? x #f) #t (if (eqv? x #t) #t #f))))

;;;
;;; Numerical operations
;;;
(define zero? (lambda (n) (= n 0)))
(define positive? (lambda (n) (> n 0)))
(define negative? (lambda (n) (< n 0)))
(define odd? (lambda (n) (not (= (remainder n 2) 0))))
(define even? (lambda (n) (= (remainder n 2) 0)))
(define abs (lambda (n) (if (negative? n) (- n) n)))

(define binop-list
  (lambda (f l)
    (if (null? l)
        '()
        (if (null? (cdr l))
            (car l)
            (f (car l) (binop-list f (cdr l)))))))
(define max (lambda l (binop-list (lambda (x1 x2) (if (> x1 x2) x1 x2)) l)))
(define min (lambda l (binop-list (lambda (x1 x2) (if (< x1 x2) x1 x2)) l)))
(define gcd
  (lambda l
    (define gcd2
      (lambda (n m)
         (define r (abs (if (= m 0) n (modulo n m))))
         (if (= r 0) m (gcd2 m r))))
    (if (null? l)
        0
        (if (null? (cdr l))
            (car l)
            (gcd2 (car l) (apply gcd (cdr l)))))))
(define lcm
  (lambda l
    (define lcm2 (lambda (n m) (abs (quotient (* n m) (gcd n m)))))
    (if (null? l)
        1
        (if (null? (cdr l))
            (car l)
            (lcm2 (car l) (apply lcm (cdr l)))))))

;;;; "ratize.scm" Convert number to rational number
;;; Adapted from SLIB, maintained by Aubrey Jaffer
(define rationalize
  (lambda (x e)
    (define sr
      (lambda (x y)
        (let ((fx (floor x)) (fy (floor y)))
          (cond
            ((not (< fx x)) fx)
            ((= fx fy) (+ fx (/ (sr (/ (- y fy)) (/ (- x fx))))))
            (#t (+ 1 fx))))))
     (define simplest
      (lambda (x y)
        (cond
          ((< y x) (simplest y x))
          ((not (< x y)) x)
          ((positive? x) (sr x y))
          ((negative? y) (- (sr (- y) (- x))))
          (#t (if (and (exact? x) (exact? y)) 0 0.0)))))
    (simplest (- x e) (+ x e))))
    
;(define (rational:simplest x y)
;  (define (sr x y) (let ((fx (floor x)) (fy (floor y)))
;                    (cond ((not (< fx x)) fx)
;                          ((= fx fy) (+ fx (/ (sr (/ (- y fy)) (/ (- x fx))))))
;                          (else (+ 1 fx)))))
;  (cond ((< y x) (rational:simplest y x))
;        ((not (< x y)) (if (rational? x) x (slib:error)))
;        ((positive? x) (sr x y))
;        ((negative? y) (- (sr (- y) (- x))))
;        (else (if (and (exact? x) (exact? y)) 0 0.0))))
;(define (rationalize x e) (rational:simplest (- x e) (+ x e)))

;;;
;;; List operations
;;;
(define caar (lambda (l) (car (car l))))
(define cadr (lambda (l) (car (cdr l))))
(define cdar (lambda (l) (cdr (car l))))
(define cddr (lambda (l) (cdr (cdr l))))
(define caaar (lambda (l) (car (car (car l)))))
(define caadr (lambda (l) (car (car (cdr l)))))
(define cadar (lambda (l) (car (cdr (car l)))))
(define caddr (lambda (l) (car (cdr (cdr l)))))
(define cdaar (lambda (l) (cdr (car (car l)))))
(define cdadr (lambda (l) (cdr (car (cdr l)))))
(define cddar (lambda (l) (cdr (cdr (car l)))))
(define cdddr (lambda (l) (cdr (cdr (cdr l)))))
(define caaaar (lambda (l) (car (car (car (car l))))))
(define caaadr (lambda (l) (car (car (car (cdr l))))))
(define caadar (lambda (l) (car (car (cdr (car l))))))
(define caaddr (lambda (l) (car (car (cdr (cdr l))))))
(define cadaar (lambda (l) (car (cdr (car (car l))))))
(define cadadr (lambda (l) (car (cdr (car (cdr l))))))
(define caddar (lambda (l) (car (cdr (cdr (car l))))))
(define cadddr (lambda (l) (car (cdr (cdr (cdr l))))))
(define cdaaar (lambda (l) (cdr (car (car (car l))))))
(define cdaadr (lambda (l) (cdr (car (car (cdr l))))))
(define cdadar (lambda (l) (cdr (car (cdr (car l))))))
(define cdaddr (lambda (l) (cdr (car (cdr (cdr l))))))
(define cddaar (lambda (l) (cdr (cdr (car (car l))))))
(define cddadr (lambda (l) (cdr (cdr (car (cdr l))))))
(define cdddar (lambda (l) (cdr (cdr (cdr (car l))))))
(define cddddr (lambda (l) (cdr (cdr (cdr (cdr l))))))

(define null? (lambda (l) (eq? () l)))
(define list?
  (lambda (l)
    (define list?2
      (lambda (l s)
        (if (eq? l s)
            #f
            (if (null? l)
                #t
                (if (pair? l)
                    (list?2 (cdr l) s)
                    #f)))))
    (if (null? l) #t (list?2 (cdr l) l))))
(define length
  (lambda (l)
    (if (null? l)
        0
        (+ 1 (length (cdr l))))))
;(define append
;  (lambda l
;    (binop-list
;      (lambda (l1 l2)
;        (if (null? l1)
;            l2
;            (cons (car l1) (append (cdr l1) l2))))
;      l)))

(define append (lambda (l1 l2)
  (cond
    ((null? l1) l2)
    (#t (cons (car l1) (append (cdr l1) l2)))
  )
))

(define reverse
  (lambda (l)
    (if (null? l)
        ()
        (append (reverse (cdr l)) (cons (car l) '())))))
(define list-tail
  (lambda (x k)
    (if (zero? k)
        x
        (list-tail (cdr x) (- k 1)))))
(define list-ref
  (lambda (x k)
    (if (= k 0)
        (car x)
        (list-ref (cdr x) (- k 1)))))
(define memq
  (lambda (x l)
    (if (null? l) #f
        (if (eq? x (car l)) l
            (memq x (cdr l))))))
(define memv
  (lambda (x l)
    (if (null? l) #f
        (if (eqv? x (car l)) l
            (memv x (cdr l))))))
(define member
  (lambda (x l)
    (if (null? l) #f
        (if (equal? x (car l)) l
            (member x (cdr l))))))
(define assq
  (lambda (x l)
    (if (null? l) #f
        (if (eq? x (caar l))
            (car l)
            (assq x (cdr l))))))
(define assv
  (lambda (x l)
    (if (null? l) #f
        (if (eqv? x (caar l))
            (car l)
            (assq x (cdr l))))))
(define assoc
  (lambda (x l)
    (if (null? l) #f
        (if (equal? x (caar l))
            (car l)
            (assq x (cdr l))))))

;;;
;;; Character operations
;;;
(define char-lower-case?
  (lambda (c)
     (if (char>=? c #\a)
         (if (char<=? c #\z) #t #f)
         #f)))
(define char-upper-case?
  (lambda (c)
    (if (char>=? c #\A)
        (if (char<=? c #\Z) #t #f)
        #f)))
(define char-alphabetic?
  (lambda (c)
    (if (char-lower-case? c) #t
        (if (char-upper-case? c) #t #f)
        #f)))
(define char-numeric?
  (lambda (c)
    (if (char>=? c #\0)
        (if (char<=? c #\9) #t #f)
        #f)))
(define char-whitespace?
  (lambda (c)
    (if (char=? c #\space) #t
        (if (char=? c #\tab) #t
            (if (char=? c #\newline) #t
                (if (char=? c #\formfeed) #t
                    (if (char=? c #\return) #t
                        #f) #f) #f) #f) #f)))
(define char-upcase
  (lambda (c)
    (define diff (- (char->integer #\A) (char->integer #\a)))
    (if (char-lower-case? c)
        (integer->char (+ (char->integer c) diff))
        c)))
(define char-downcase
  (lambda (c)
    (define diff (- (char->integer #\A) (char->integer #\a)))
    (if (char-upper-case? c)
        (integer->char (- (char->integer c) diff))
        c)))
(define charop-ci (lambda (f c1 c2) (f (char-upcase c1) (char-upcase c2))))
(define char-ci=? (lambda (c1 c2) (charop-ci char=? c1 c2)))
(define char-ci<? (lambda (c1 c2) (charop-ci char<? c1 c2)))
(define char-ci>? (lambda (c1 c2) (charop-ci char>? c1 c2)))
(define char-ci<=? (lambda (c1 c2) (charop-ci char<=? c1 c2)))
(define char-ci>=? (lambda (c1 c2) (charop-ci char>=? c1 c2)))

;;;
;;; String Operations
;;;
(define string (lambda l (list->string l)))
(define list->string
  (lambda (l)
    (define load-string
      (lambda (s k l)
        (if (not (null? l)) (string-set! s k (car l)))
        (if (not (null? l)) (load-string s (+ k 1) (cdr l)))
        s))
    (load-string (make-string (length l)) 0 l)))
(define string->list
  (lambda (s)
    (define unpack-string
      (lambda (k n s)
        (if (= k n) '() (cons (string-ref s k) (unpack-string (+ k 1) n s)))))
    (unpack-string 0 (string-length s) s)))

;;;
;;; Control features
;;;
(define map
  (lambda (p . l)
    (define cars
      (lambda (l)
        (if (null? l) '() (cons (caar l) (cars (cdr l))))))
    (define cdrs
      (lambda (l)
        (if (null? l) '() (cons (cdar l) (cdrs (cdr l))))))
    (if (null? (car l))
        '()
        (cons (apply p (cars l)) (apply map p (cdrs l))))))

;;; map already does things in the order required by for-each
(define for-each
  (lambda (p . l)
    (apply map p l)))

;;;
;;; I/O Operations
;;;
(define call-with-input-file
  (lambda (s p)
    (let ((port (open-input-file s)))
    (p port)
;    (close-input-port port)
)))
(define call-with-output-file
  (lambda (s p)
    (define port (open-output-file s))
    (p port)
    (close-output-port port)))
(define newline
  (lambda p
    (if (null? p)
        (write-char #\newline)
        (write-char #\newline (car p)))))

<../../mkconfig

TARG=\
	builtin.dis\
	cell.dis\
	sform.dis\
	extension.dis \

MODULES=\
	builtin.m\
	cell.m\
	scheme.m\
	sform.m\
	extension.m \

SYSMODULES=\
	bufio.m\
	draw.m\
	math.m\
	sh.m\
	string.m\
	sys.m\

DISBIN=$ROOT/dis/scheme

LIBDIR=$ROOT/lib/scheme

LIBTARG=\
	$LIBDIR/library.scm\
	$LIBDIR/symb.scm\

all:V:	scheme.dis

<$ROOT/mkfiles/mkdis

$DISBIN:
	mkdir $DISBIN

$LIBDIR:
	mkdir $LIBDIR

install:V:	$ROOT/dis/scheme.dis $LIBTARG $ROOT/man/1/scheme

$ROOT/dis/scheme.dis:	$DISBIN scheme.dis
	rm -f $target && cp scheme.dis $target

scheme.dis:	$MODULES $SYS_MODULES

$LIBDIR/%: $LIBDIR %
	rm -f $target && cp $stem $target

$ROOT/man/1/scheme: scheme.1
	rm -f $target && cp scheme.1 $target

nuke:V:
	rm -f $ROOT/dis/scheme.dis

.TH SCHEME 1
.SH NAME
scheme \- Scheme interpreter
.SH SYNOPSIS
.B scheme
.SH DESCRIPTION
This Scheme interpreter implements nearly all of the
essential procedures of the r4rs Scheme standard, save
for call-with-curent-continuation.
It also implements most of the features of r5rs, with
the major exceptions being macros and calls related
to continuation.
Finally, it behaves as r6rs, rather than r[45]rs in being
case-sensitive.
.SH EXTENSIONS
There are two procedures unique to this implementation
and not found in the r[456]rs standards.
.TP 5
(quit)
This does the obvious of exiting the interpreter.

.TP 5
.RI (popen\  cmd-string )
The
.I cmd-string
is executed by the shell.
The command's standard input and output are assigned
to two Scheme ports which make a list returned by this
function.
One particular use of
.I popen
is in talking to Tk.
For example,

.EX
(define tkports (popen "tkcmd"))
(define tkin (car tkports))
(define tkout (cadr tkport))
(display "label .l -text {Hello World}\n" tkout)
(display "pack .l\n" tkout)
.EE

.RS 0
is a simple graphical version of everyone's favorite
first program.
.SH SOURCE
.B /appl/scheme/*.b
.SH BUGS
It does not, as yet, implment proper tail recursion.
The (char-ready?) procedure is not likely to ever be
implemented; there's not really a good way to do it
in Inferno.

#
# TODO:
# Sec 6.4 control features
# proper tail recursion
# define-syntax
#
implement Scheme;

include "sys.m";
sys: Sys;

include "bufio.m";
bufio: Bufio;
Iobuf: import bufio;

include "string.m";
str: String;

include "math.m";
math: Math;

include "draw.m";

include "cell.m";
cell: SCell;
Cell: import cell;
Pair: import cell;
Env: import cell;

include "sform.m";
sform: SForm;

include "builtin.m";
builtin: BuiltIn;

include "extension.m";
extension: Extension;

include "scheme.m";

stdin, stdout: ref Iobuf = nil;

ctxt: ref Draw->Context;

init(drawctxt: ref Draw->Context, nil: list of string)
{
	sys = load Sys Sys->PATH;
	bufio = load Bufio Bufio->PATH;
	str = load String String->PATH;
	math = load Math Math->PATH;
	cell = load SCell SCell->PATH;
	sform = load SForm SForm->PATH;
	builtin = load BuiltIn BuiltIn->PATH;
	extension = load Extension Extension->PATH;

	ctxt = drawctxt;
	stdin = bufio->fopen(sys->fildes(0), Bufio->OREAD);
	stdout = bufio->fopen(sys->fildes(1), Bufio->OWRITE);

	cell->init(sys);

	e := ref Env("nil", cell->Variable, ref Cell.Link(nil), nil) :: nil;
	e = ref Env("else", cell->Variable, ref Cell.Boolean(1), nil) :: nil;


	cell->globalenv = e;
	sform->init(sys, load Scheme SELF, cell);

	e = cell->globalenv;
	cell->nullenvironment = e;

	builtin->init(sys, load Scheme SELF, cell, math, str,
		 bufio, stdin, stdout);

	e = cell->globalenv;
	b := bufio->open("/lib/scheme/library.scm", Bufio->OREAD);
	if(b == nil) {
		cell->error("Can't open library code\n");
	}
	else {
		while(1) {
			c := readcell(b, e);
			if(c == nil)
				break;
			(nil, e) = eval(c, e);
		}
	}
	b = nil;
	cell->reportenv = e;
	cell->globalenv = e;
	extension->init(ctxt, sys, load Scheme SELF, cell, builtin, math, str, bufio);

	e = cell->globalenv;

	while(1) {
		sform->resetbody();
		sys->print("> ");
		c := readcell(stdin, cell->globalenv);
		(r, ge) := eval(c, cell->globalenv);
		cell->globalenv = ge;
		printcell(r, stdout, 0); stdout.flush(); sys->print("\n");
	}
}

readcell(b: ref Iobuf, env: list of ref Env): ref Cell
{
	c: int;

	while(1) {
		do {
			c = b.getc();
		} while(c != Bufio->EOF && str->in(c, " \t\n"));
		case c {
		Bufio->EOF or ')' =>
			return nil;
		';' =>
			do {
				c = b.getc();
			} while(c != Bufio->EOF && c != '\n');
		'(' =>
			return readlist(b, env);
		'"' =>
			return readstring(b);
		'\'' =>
			return cell->lcons(ref Cell.Symbol("quote",
				cell->lookupsym("quote", cell->globalenv)),
				cell->lcons(readcell(b, env), ref Cell.Link(nil)));
		'`' =>
			return cell->lcons(ref Cell.Symbol("quasiquote",
				cell->lookupsym("quasiquote", cell->globalenv)),
				cell->lcons(readcell(b, env), ref Cell.Link(nil)));
		',' =>
			c = b.getc();
			if(c == '@')
				return cell->lcons(ref Cell.Symbol("unquote-splicing",
					cell->lookupsym("unquote-splicing", cell->globalenv)),
					cell->lcons(readcell(b, env), ref Cell.Link(nil)));
			else {
				b.ungetc();
				return cell->lcons(ref Cell.Symbol("unquote",
					cell->lookupsym("unquote", cell->globalenv)),
					cell->lcons(readcell(b, env), ref Cell.Link(nil)));
			}
		'+' or '-' or '.' or '0' to '9' =>
			b.ungetc();
			return readnumber(b, 0);
		'#' =>
			c = b.getc();
			case c {
			'b' or 'B' or 'o' or 'O' or 'd' or 'D' or 'x' or 'X' 
			or 'e' or 'E' or 'i' or 'I' =>
				b.ungetc();
				return readnumber(b, '#');
			'f' =>
				return ref Cell.Boolean(0);
			't' =>
				return ref Cell.Boolean(1);
			'\\' =>
				return readchar(b);
			'(' =>
				return readvector(b, env);
			}
		* =>
			b.ungetc();
			return readsymbol(b, env);
		}
	}
	return nil;
}

readchar(b: ref Iobuf): ref Cell
{
	lexeme: string;

	lexeme[0] = b.getc();
	i := 1;
	do {
		lexeme[i] = b.getc();
	} while(!str->in(lexeme[i++], " \t\n\r();"));
	b.ungetc();
	lexeme = lexeme[:len lexeme -1];
	if(len lexeme == 1)
		return ref Cell.Char(lexeme[0]);
	case str->tolower(lexeme) {
	"space" =>
		return ref Cell.Char(' ');
	"newline" =>
		return ref Cell.Char('\n');
	"return" =>
		return ref Cell.Char('\r');
	"tab" =>
		return ref Cell.Char('\t');
	"backspace" =>
		return ref Cell.Char('\b');
	"bell" or "alert" =>
		return ref Cell.Char('\a');
	"quote" =>
		return ref Cell.Char('\'');
	"doublequote" =>
		return ref Cell.Char('\"');
	"null" =>
		return ref Cell.Char(0);
	"backslash" =>
		return ref Cell.Char('\\');
	"escape" =>
		return ref Cell.Char(16r1b);
	"formfeed" =>
		return ref Cell.Char('\v');
	}
	return nil;
}

readvector(b: ref Iobuf, env: list of ref Env): ref Cell
{
	l: list of ref Cell;

	l = nil;
	while(1) {
		c := readcell(b, env);
		if(c == nil)
			break;
		l = c :: l;
	}
	v := array [len l] of ref Cell;
	for(i := len l - 1; i >= 0; --i) {
		v[i] = hd l;
		l = tl l;
	}
	return ref Cell.Vector(v);
}

readlist(b: ref Iobuf, env: list of ref Env): ref Cell
{
	c := readcell(b, env);
	if(c == nil)
		return ref Cell.Link(nil);
	pick x := c {
	Symbol =>
		if(x.sym == ".") {
			cdr := readcell(b, env);
			if(readcell(b, env) != nil) {
				cell->error("malformed improper list\n");
				return nil;
			}
			return cdr;
		}
	}
	p := Pair(nil, nil);
	p.car = c;
	p.cdr = readlist(b, env);
	return ref Cell.Link(ref p);
}

readstring(b: ref Iobuf): ref Cell
{
	x: string;

	i := 0;
	esc := 0;
loop:
	while(1) {
		x[i] = b.getc();
		case x[i] {
		'"' =>
			if(!esc)
				break loop;
			else {
				++i;
				esc = 0;
			}
		'\\' =>
			if(esc) {
				++i;
				esc = 0;
			}
			else
				esc = 1;
		't' =>
			if(esc) {
				x[i] = '\t';
				esc = 0;
			}
			++i;
		'n' =>
			if(esc) {
				x[i] = '\n';
				esc = 0;
			}
			++i;
		'r' =>
			if(esc) {
				x[i] = '\r';
				esc = 0;
			}
			++i;
		'b' =>
			if(esc) {
				x[i] = '\b';
				esc = 0;
			}
			++i;
		'a' =>
			if(esc) {
				x[i] = '\a';
				esc = 0;
			}
			++i;
		'v' =>
			if(esc) {
				x[i] = '\v';
				esc = 0;
			}
			++i;
		* =>
			esc = 0;
			++i;
		}

	}
	return ref Cell.String(x[:i]);
}

readnumber(b: ref Iobuf, seed: int): ref Cell
{
	s: string;

	# Get the string
	i := -1;
	if(seed != 0)
		s[++i] = seed;
	do {
		++i;
		s[i] = b.getc();
	} while(str->in(s[i], "-+.#oOxXiIsSlL0-9A-Fa-f/"));
	b.ungetc();
	if(s[:i] == ".")
		return ref Cell.Symbol(".", nil);
	else if(s[:i] == "+")
		return ref Cell.Symbol("+", cell->lookupsym("+", cell->globalenv));
	else if(s[:i] == "-")
		return ref Cell.Symbol("-", cell->lookupsym("-", cell->globalenv));
	--i;
	return scannum(s, 10);
}

readsymbol(b: ref Iobuf, env: list of ref Env): ref Cell
{
	x: string;

	i := 0;
	do {
		x[i] = b.getc();
	} while(!str->in(x[i++], " \t\n()"));
	b.ungetc();
	e := cell->lookupsym(x[:i-1], env);
#	if(e != nil && (e.ilk == cell->SpecialForm || e.ilk == cell->BuiltIn))
#		return ref Cell.Internal(x[:i-1], e);
	return ref Cell.Symbol(x[:i-1], e);
}

bugger: int;

eval(c: ref Cell, env: list of ref Env): (ref Cell, list of ref Env)
{
	z: ref Cell;
	r: ref Cell;
	lenv: list of ref Env;

	tailcont := 0;
	lenv = env;
	do {
		if(c == nil || cell->isnil(c))
			return (c, env);
#printcell(c, stdout, 0);
		pick c2 := c {
		Continuation =>
			lenv = c2.env;
			c = c2.exp;
		}
		pick x := c {
		Link =>
			if(x.next == nil)
				return (ref Cell.Link(nil), lenv);
			(r, lenv) = eval(x.next.car, lenv);
			if(r == nil) {
				cell->error("Undefined operation: ");
				printcell(x.next.car, stdout, 0);
				stdout.putc('\n');
				return (nil, lenv);
			}
			pick y := r {
			Internal =>
				e := cell->lookupsym(y.sym, lenv);
				if(e == nil)
					return (nil, lenv);
				case e.ilk {
				cell->BuiltIn =>
					l := evallist(x.next.cdr, lenv);
					(tailcont, z) = e.handler(l, lenv);
					if(tailcont == 2)
						return (z, lenv);
					else if(tailcont == 0) {
						if(z == nil || cell->isnil(z))
							return (z, lenv);
						pick v := z {
						Environment =>
							return (ref Cell.Link(nil), v.env);
						* =>
							return (z, lenv);
						}
					}
					else
						c = z;
				cell->SpecialForm =>
					(tailcont, z) = e.handler(x.next.cdr, lenv);
					if(tailcont == 0) {
						if(z == nil || cell->isnil(z))
							return (z, lenv);
						pick v := z {
						Environment =>
							return (ref Cell.Link(nil), v.env);
						* =>
							return (z, lenv);
						}
					}
					else
						c = z;
				}
			Symbol =>
				e := cell->lookupsym(y.sym, lenv);
				if(e == nil)
					return (nil, lenv);
				case e.ilk {
				cell->Variable =>
					# return eval(e.val);
					c = e.val;
					tailcont = 1;
				}
			Lambda =>
				l := evallist(x.next.cdr, lenv);
				lenv = cell->listappend(y.env, lenv);
				p := y.formals;
				q := l;
				dorest := 0;
				while(p != nil && q != nil) {
					fname := "";
					pick fp := p {
					Link =>
						if(fp.next != nil && fp.next.car != nil) {
							pick ffp := fp.next.car {
							Symbol =>
								fname = ffp.sym;
							* =>
								cell->error("non-symbol in formals\n");
								return (nil, lenv);
							}
							p = fp.next.cdr;
						}
						else
							p = nil;
					Symbol =>
						fname = fp.sym;
						dorest = 1;
						p = nil;
					* =>
						p = nil;
					}
					pick vp := q {
					Link =>
						if(vp.next != nil) {
							if(dorest) {
								if(fname == "")
									cell->error("empty name for define in lambda 1\n");
								(nil, lenv) = cell->ldefine(fname, vp, lenv);
								q = nil;
							}
							else {
								if(fname == "") {
									cell->error("empty name for define in lambda 2\n");
									printcell(y.formals, stdout, 1);
								}
								(nil, lenv) = cell->ldefine(fname, vp.next.car, lenv);
								q = vp.next.cdr;
							}
						}
						else {
							if(dorest) {
								if(fname == "")
									cell->error("empty name for define in lambda 3\n");
								(nil, lenv) = cell->ldefine(fname,
									 ref Cell.Link(nil), lenv);
							}
							q = nil;
						}
					* =>
						q = nil;
					}
				}
				if(p != nil || q != nil) {
					cell->error("wrong number of arguments for lambda\n");
					printcell(y.formals, stdout, 0);
					return (nil, lenv);
				}
				exp := y.exp_list;
				r: ref Cell;
				r = ref Cell.Link(nil);
				sform->startbody();
				while(exp != nil) {
					pick ep := exp {
					Link =>
						if(ep.next != nil) {
							(r, lenv) = eval(ep.next.car, lenv);
							if(r == nil) {
								return (nil, lenv);
							}
							exp = ep.next.cdr;
						}
						else
							exp = nil;
					* =>
						cell->error("malformed expression list\n");
						sform->resetbody();
						return (nil, lenv);
					}
				}
				sform->resetbody();
				return (r, env);
			* =>
				cell->error("non-lambda and non-symbol in eval\n");
				return (nil, lenv);
			}
		Symbol =>
	#		if(x.env == nil)
				s := cell->lookupsym(x.sym, lenv);
	#		else
	#			s = x.env;
			if(s == nil)
				return (nil, lenv);
			else
				return (s.val, lenv);
		* =>
			return (c, lenv);
		}
	} while (tailcont != 0) ;
	return (nil, lenv);
}

evallist(c: ref Cell, env: list of ref Env): ref Cell
{
	if(c == nil || cell->isnil(c))
		return c;
	pick x := c {
	Link =>
		if(x.next == nil)
			return ref Cell.Link(nil);
		(vc, e) := eval(x.next.car, env);
		if(vc == nil)
			return nil;
		vl := evallist(x.next.cdr, e);
		if(vl == nil)
			return nil;
		y := Pair(vc, vl);
		return ref Cell.Link(ref y);
	* =>
		cell->error("non-list in evallist\n");
	}
	return nil;
}

printlist(plist: ref Pair, b: ref Iobuf, disp: int)
{
	x: ref Pair;

	b.puts("(");
	x = plist;
	while(x != nil) {
		printcell(x.car, b, disp);
		y := x.cdr;
		if(y == nil) {
			cell->error("unexpected end of list\n");
			break;
		}
		pick z := y {
		Link =>
			x = z.next;
			if(x != nil)
				b.puts(" ");
		* =>
			b.puts(" . ");
			printcell(z, b, disp);
			x = nil;
		}
	}
	b.puts(")");
	b.flush();
}

printvector(v: array of ref Cell, b: ref Iobuf, disp: int)
{
	b.puts("#(");
	if(len v == 0) {
		b.puts(")");
		b.flush();
		return;
	}
	i := 0;
	while(1) {
		printcell(v[i], b, disp);
		if(++i >= len v)
			break;
		b.putc(' ');
	}
	b.puts(")");
	b.flush();
}

printcell(x: ref Cell, b: ref Iobuf, disp: int)
{
	if(x == nil) {
		b.puts("nil");
		b.flush();
		return;
	}
	pick y := x {
	Boolean =>
		if(y.b == 0)
			b.puts("#f");
		else
			b.puts("#t");
	Symbol =>
		b.puts(sys->sprint("%s", y.sym));
	Internal =>
		b.puts(sys->sprint("%s", y.sym));
	String =>
		if(disp)
			b.puts(y.str);
		else {
			b.putc('"');
			for(i := 0; i < len y.str; ++i)
				if(y.str[i] == '"')
					b.puts("\\\"");
				else
					b.putc(y.str[i]);
			b.putc('"');
		}
	Char =>
		if(disp)
			b.putc(y.c);
		else
		case y.c {
		'\n' =>
			b.puts("#\\newline");
		'\t' =>
			b.puts("#\\tab");
		'\r' =>
			b.puts("#\\return");
		'\b' =>
			b.puts("#\\backspace");
		'\a' =>
			b.puts("#\\bell");
		'\v' =>
			b.puts("#\\formfeed");
		* =>
			b.puts(sys->sprint("#\\%c", y.c));
		}
	Number =>
		case (y.ilk & ~cell->Exact) {
		cell->Integer =>
			if(!(y.ilk & cell->Exact))
				b.puts("#i");
			b.puts(sys->sprint("%bd", y.i));
		cell->Rational =>
			if(!(y.ilk & cell->Exact))
				b.puts("#i");
			b.puts(sys->sprint("%bd/%bd", y.i, y.j));
		* =>
			b.puts(sys->sprint("%.#g", y.r));
		}
	Link =>
		printlist(y.next, b, disp);
	Lambda =>
		b.puts("[lambda expression]");
	Port =>
		case y.dir {
		-1 =>
			b.puts("[closed port]");
		Bufio->OREAD =>
			b.puts("[input port]");
		Bufio->OWRITE =>
			b.puts("[output port]");
		}
	Vector =>
		printvector(y.v, b, disp);
	Environment =>
		b.puts("[environment]");
	Channel =>
		b.puts("[channel]");
	Promise =>
		b.puts("[promise]");
	Continuation =>
		b.puts("[continuation]");
	}
	b.flush();
}

scannum(s: string, radix: int): ref Cell
{
	n2: big;

	exact := cell->Exact;
	ilk := 0;
	sign := big 1;
	l := len s;

	# parse the prefix
	j := 0;
prefixlp:
	for(k := 0; j < l && k < 2; ++k) {
		if(s[j] != '#')
			break;
		++j;
		if (j >= l)
			break;
		case s[j] {
		'b' or 'B' =>
			radix = 2;
		'o' or 'O' =>
			radix = 8;
		'd' or 'D' =>
			radix = 10;
		'x' or 'X' =>
			radix = 16;
		'e' or 'E' =>
			exact = cell->Exact;
		'i' or 'I' =>
			exact = 0;
		* =>
			exact = 0;
			break prefixlp;
		}
		++j;
	}

	for(k = j; k < l; ++k)
		if (s[k] == '#')
			s[k] = '0';

	if(j >= l)
		j = l-1;
	# Get the initial sign
	if(s[j] == '+') {
		sign = big 1;
	}
	else if(s[j] == '-') {
		sign = big -1;
	}

	# Try to classify the number (ugly ad hoc)
	# As a first cut, just integers and reals
	if(radix == 10)
		(s1,s2) := str->splitl(s[j:], ".eEsSfFdDlL");
	else
		s2 = nil;
	if(s2 == nil) {
		(s1, s2) = str->splitl(s[j:], "/");
		(n1, rs) := str->tobig(s1, radix);
		if (rs != nil && (!str->in(rs[0], " \n\r\t\f\v)/") || rs == s1))
			return ref Cell.Boolean(0);
		if(s2 != nil) {
			ilk = cell->Rational;
			(n2, rs) = str->tobig(s2[1:], radix);
			if (rs != nil && (!str->in(rs[0], " \n\r\t\f\v)/") || rs == s1))
				return ref Cell.Boolean(0);
		}
		else {
			ilk = cell->Integer;
			n2 = big 1;
		}
		if (n2 == big 0)
			return ref Cell.Number(big 0, big 1, real 0, cell->Integer|exact);
		if(n2 != big 1)
			(n1, n2) = reduce(n1, n2);
		if(n2 == big 1)
			ilk = cell->Integer;
		else
			ilk = cell->Rational;
		return ref Cell.Number(n1, n2, real n1 / real n2, ilk|exact);
	}
	else {
		for(m := j; m < len s; ++m) {
			case s[m] {
			's' or 'S' or 'f' or 'F' or 'd' or 'D' or 'l' or 'L' =>
				s[m] = 'e';
			}
		}
		if(s[j] != '.')
			(n, rs) := str->toreal(s[j:], 10);
		else if(len s[j:] <= 1 || s[j+1] < '0' || s[j+1] > '9')
			return ref Cell.Boolean(0);
		else
			(n, rs) = str->toreal("0" + s[j:], 10);
		if (rs != nil && (!str->in(rs[0], " \n\r\t\f\v)/") || rs == s1))
			return ref Cell.Boolean(0);
		if(n > real 18446744073709551615)
			return ref Cell.Number(big 0, big 1, n, cell->Real);
		return ref Cell.Number(big n, big 1, n, cell->Real);
	}
}

printenv(env: list of ref Env)
{
	sys->print("\n***Env: ");
	for(p := env; p != nil; p = tl p) {
		sys->print("%s:", (hd p).name);
		printcell((hd p).val, stdout, 0);
		sys->print(" ");
	}
	sys->print("\n");
}

# Basically Euclid's gcd algorithm
reduce(n, m: big): (big,big)
{
	j := n;
	k := m;
	while(1) {
		r := j % k;
		if(r == big 0) {
			x := n / k;
			y := m / k;
			if (y < big 0) {
				x = -x;
				y = -y;
			}
			return (x, y);
		}
		j = k;
		k = r;
	}
}

Scheme: module
{
	PATH: con "/dis/scheme.dis";

	init: fn(nil: ref Draw->Context, nil: list of string);
	eval: fn(c: ref Cell, env: list of ref Env): (ref Cell, list of ref Env);
	readcell: fn(b: ref Iobuf, env: list of ref Env): ref Cell;
	printcell: fn(x: ref Cell, b: ref Iobuf, disp: int);
	printenv: fn(env: list of ref Env);
	scannum: fn(s: string, radix: int): ref Cell;
	reduce: fn(n, m: big): (big, big);
};

implement SForm;

include "sys.m";
include "draw.m";

include "bufio.m";
bufio: Bufio;
Iobuf: import bufio;

include "cell.m";
cell: SCell;
Cell: import cell;
Pair: import cell;
Env: import cell;

include "scheme.m";
scheme: Scheme;
eval: import scheme;

include "sform.m";

stdout:  ref Iobuf = nil;
lsys: Sys;

defkludge: ref Env;

init(sys: Sys, sch: Scheme, c: SCell)
{
	cell = c;
	scheme = sch;
bufio = load Bufio Bufio->PATH;

	e := cell->globalenv;
	e = ref Env("quote", cell->SpecialForm, nil, quote) :: e;
	e = ref Env("quasiquote", cell->SpecialForm, nil, qquote) :: e;
	e = ref Env("define", cell->SpecialForm, nil, define) :: e;
	defkludge = hd e;
	e = ref Env("delay", cell->SpecialForm, nil, delay) :: e;
	e = ref Env("force", cell->SpecialForm, nil, force) :: e;
	e = ref Env("if", cell->SpecialForm, nil, ifsf) :: e;
	e = ref Env("lambda", cell->SpecialForm, nil, lambda) :: e;
	e = ref Env("set!", cell->SpecialForm, nil, setbang) :: e;
	e = ref Env("unquote", cell->SpecialForm, nil, unquote) :: e;
	e = ref Env("unquote-splicing", cell->SpecialForm, nil, unquotesplice) :: e;
	e = ref Env("and", cell->SpecialForm, nil, land) :: e;
	e = ref Env("begin", cell->SpecialForm, nil, begin) :: e;
	e = ref Env("or", cell->SpecialForm, nil, lor) :: e;
	e = ref Env("case", cell->SpecialForm, nil, lcase) :: e;
	e = ref Env("cond", cell->SpecialForm, nil, cond) :: e;
	e = ref Env("do", cell->SpecialForm, nil, ldo) :: e;
	e = ref Env("let", cell->SpecialForm, nil, let) :: e;
	e = ref Env("let*", cell->SpecialForm, nil, letstar) :: e;
	e = ref Env("letrec", cell->SpecialForm, nil, letrec) :: e;
	cell->globalenv = e;
	l := e;
	while(l != nil) {
		x := hd l;
		if(x.ilk == cell->BuiltIn || x.ilk == cell->SpecialForm)
			x.val = ref Cell.Internal(x.name, x);
		l = tl l;
	}
lsys = sys;
stdout = bufio->fopen(sys->fildes(1), Bufio->OWRITE);
}

land(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	c: ref Cell;
	e: list of ref Env;

	c = ref Cell.Boolean(1);
	p := cell->lcar(args);
	if (p == nil || cell->isnil(p))
		return (0, ref Cell.Boolean(1));
	l := cell->lcdr(args);
	e = env;
	while(l != nil && !(cell->isnil(l))) {
		(c, e) = eval(p, e);
		if (c == nil)
			return (0, ref Cell.Boolean(0));
		pick cn := c {
		Boolean =>
			if(cn.b == 0)
				return (0, c);
		}
		if(l == nil || cell->isnil(l))
			break;
		p = cell->lcar(l);
		l = cell->lcdr(l);
	}
	return (1, ref Cell.Continuation(p, e));
}

begin(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	c: ref Cell;
	e: list of ref Env;

	p := cell->lcar(args);
	if(p == nil) {
		return (0, ref Cell.Link(nil));
	}
	l := cell->lcdr(args);
	e = env;
	while(l != nil && !(cell->isnil(l))) {
		(c, e) = eval(p, e);
		p = cell->lcar(l);
		l = cell->lcdr(l);
	}
(r, nil) := eval(p, e);
return (0, r);
#	return (1, ref Cell.Continuation(p, e));
}

lbegin(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	(t, x) := begin(args, env);
	if(t) {
		(r, nil) := eval(x, env);
		return (0, r);
	}
	else
		return (0, x);
}

ldo(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	r, tv: ref Cell;
	t: int;

	il := cell->lcar(args);
	tc := cell->lcdr(args);
	te := cell->lcar(tc);
	c := cell->lcdr(tc);
	ii := il;
	el := env;
	while(ii != nil && !cell->isnil(ii)) {
		ij := cell->lcar(ii);
		pick x := cell->lcar(ij) {
		Symbol =>
			(r, el) = eval(cell->lcar(cell->lcdr(ij)), el);
			if(x.sym == "")
				cell->error("nil name for binding in do\n");
			(nil, el) = cell->ldefine(x.sym, r, el);
		}
		ii = cell->lcdr(ii);
	}
bigloop:
	while(1) {
		(tv, el) = eval(cell->lcar(te), el);
		if(tv == nil || cell->isnil(tv)) {
			(nil, r) = lbegin(cell->lcdr(te), el);
			break;
		}
		pick y := tv {
		Boolean =>
			if (y.b == 1) {
				be := cell->lcdr(te);
				if (be == nil || cell->isnil(be)) {
					t = 0;
					r = ref Cell.Link(nil);
				}
				else
					(t, r) = begin(cell->lcdr(te), el);
				break bigloop;
			}
		}
		if(c != nil && !cell->isnil(c))
			lbegin(c, el);

		ii = il;
		nel := env;
		while(ii != nil && !cell->isnil(ii)) {
			ij := cell->lcar(ii);
			pick x := cell->lcar(ij) {
			Symbol =>
				updl := cell->lcdr(cell->lcdr(ij));
				if (updl == nil || cell->isnil(updl)) {
					(r, nil) = eval(x, el);
				}
				else {
					upd := cell->lcar(updl);
					(r, nil) = eval(upd, el);
				}
				if(x.sym == "")
					cell->error("empty string for define in do 2\n");
				(nil, nel) = cell->ldefine(x.sym, r, nel);
			}
			ii = cell->lcdr(ii);
		}
		el = nel;
	}
	if (t == 0)
		return (0, r);
	pick cont := r {
	Continuation =>
		res := ref Cell.Continuation(cont.exp, el);
		return (1, res);
	* =>
		return (0, r);
	}
}

lcase(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil || cell->isnil(l)) {
		cell->error("wrong number of expressions in case\n");
		return (0, nil);
	}
	(key, nil) := eval(cell->lcar(args), env);
	if(key == nil) {
		cell->error("key expression missing in case\n");
		return (0, nil);
	}
	do {
		clause := cell->lcar(l);
		if(clause == nil || cell->isnil(clause)) {
			cell->error("non-pair clause in case\n");
			return (0, nil);
		}
		data := cell->lcar(clause);
		if(data == nil || cell->isnil(data)) {
			cell->error("non-pair clause in case\n");
			return (0, nil);
		}
		exprs := cell->lcdr(clause);
		if(exprs == nil || cell->isnil(exprs)) {
			cell->error("non-pair clause in case\n");
			return (0, nil);
		}
		pick elp := data {
		Symbol =>
			if(elp.sym == "else")
				return begin(exprs, env);
		}
		dl := data;
		do {
			datum := cell->lcar(dl);
			if(cell->leqvp(key, datum) == 1)
				return begin(exprs, env);
			dl = cell->lcdr(dl);
		} while(dl != nil && !(cell->isnil(dl)));
		l = cell->lcdr(l);
	} while(l != nil && !(cell->isnil(l)));
	return (0, nil);
}

procel(res, el: ref Cell, env: list of ref Env): (int, ref Cell)
{
	if(el == nil || cell->isnil(el))
		return (0, res);
	pick arrow := cell->lcar(el) {
	Symbol =>
		if(arrow.sym == "=>") {
			l := cell->lcdr(el);
			if(l == nil || cell->isnil(l))
				return (0, nil);
			(c, nil) := eval(cell->lcar(l), env);
			qr := cell->lcons(ref Cell.Symbol("quote", nil),
				cell->lcons(res, ref Cell.Link(nil)));
			(r, nil) := eval(cell->lcons(c, cell->lcons(qr, ref Cell.Link(nil))), env);
			return (0, r);
		}
	}
	return begin(el, env);
}

cond(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	cl := cell->lcar(args);
	l := cell->lcdr(args);
#	if(cl == nil || cell->isnil(cl) || l == nil || cell->isnil(l)) {
	if(cl == nil || cell->isnil(cl)) {
		cell->error("wrong number of arguments in cond\n");
		return (0, nil);
	}
	while(1) {
		test := cell->lcar(cl);
		if(test == nil || cell->isnil(test)) {
			cell->error("invalid test in cond\n");
			return (0, nil);
		}
		(res, nil) := eval(test, env);
		if (res == nil || cell->isnil(res)) {
			cell->error("invalid cond expression\n");
			return (0, nil);
		}
		el := cell->lcdr(cl);
		pick r := res {
		Boolean =>
			if(r.b == 1)
				return procel(res, el, env);
		* =>
			return procel(res, el, env);
		}
		if(l == nil || cell->isnil(l))
			break;
		cl = cell->lcar(l);
		l = cell->lcdr(l);
	}
	return (0, ref Cell.Link(nil));
}

innerdef(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil) {
		cell->error("wrong number of arguments in define\n");
		return (0, nil);
	}
	pick y := x {
	Symbol =>
		(r, e2) := eval(cell->lcar(l), env);
		if(y.sym == "")
			cell->error("empty name for define in innerdef\n");
		(nil, el) := cell->ldefine(y.sym, r, e2);
		return (0, ref Cell.Environment(el));
	Link =>
		pick z := cell->lcar(x) {
		Symbol =>
			lc := ref Cell.Symbol("lambda", cell->lookupsym("lambda", env));
			fp := ref Cell.Link(ref Pair(cell->lcdr(x), l));
			lp := ref Cell.Link(ref Pair(lc, fp));
			e := cell->lookupsym(z.sym, env);
			if(e != nil) {
				(e.val, nil) = eval(lp, env);
				return (0, ref Cell.Symbol(z.sym, e));
			}
			(r, e2) := eval(lp, env);
			if(z.sym == "")
				cell->error("empty name for define in innerdef 2\n");
			(nil, el) := cell->ldefine(z.sym, r, e2);
			return (0, ref Cell.Environment(el));
		}
	}
	return (0, ref Cell.Link(nil));
}

define(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	l := cell->lcdr(args);
	if(x == nil || l == nil) {
		cell->error("wrong number of arguments in define\n");
		return (0, nil);
	}
	pick y := x {
	Symbol =>
		e := cell->lookupsym(y.sym, env);
		if(e != nil) {
			(e.val, nil) = eval(cell->lcar(l), env);
			return (0, ref Cell.Symbol(y.sym, e));
		}
	}
	return innerdef(args, env);
}

startbody()
{
	defkludge.handler = innerdef;
}

resetbody()
{
	defkludge.handler = define;
}

delay(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	return (0, ref Cell.Promise(cell->lcar(args), nil, env));
}

force(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	(p, nil) := eval(cell->lcar(args), env);
	if (p == nil || cell->isnil(p))
		return (0, nil);
	pick x := p {
	Promise =>
		if(x.val == nil) {
			lenv := cell->listappend(x.env, env);
			(c, nil) := eval(x.proc, lenv);
			if(x.val == nil)
				x.val = c;
		}
		return (0, x.val);
	}
	return (0, p);
}

ifsf(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	e3: ref Cell;

	e1 := cell->lcar(args);
	l := cell->lcdr(args);
	e2 := cell->lcar(l);
	if(e1 == nil || e2 == nil || l == nil) {
		cell->error("wrong number of expressions in if\n");
		return (0, nil);
	}
	l = cell->lcdr(l);
	if(l == nil || cell->isnil(l))
		e3 = ref Cell.Link(nil);
	else
		e3 = cell->lcar(l);
	(truth, nenv) := eval(e1, env);
	if (truth == nil || cell->isnil(truth))
		return (0, ref Cell.Link(nil));
	pick x := truth {
	Boolean =>
		if (x.b == 0) {
			(r, nil) := eval(e3, nenv);
			return (0, r);
		}
	}
	(r, nil) := eval (e2, nenv);
	return (0, r);

#	pick x := truth {
#	Boolean =>
#		if(x.b == 0)
#			return (1, ref Cell.Continuation(e3, nenv));
#	}
#	return (1, ref Cell.Continuation(e2, nenv));
}

lambda(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	if(args == nil) {
		cell->error("too few arguments in lambda expressions\n");
		return (0, nil);
	}
	pick x := args {
	Link =>
		if(x.next == nil || x.next.cdr == nil)
			return (0, ref Cell.Link(nil));
		return (0, ref Cell.Lambda(x.next.car,
			x.next.cdr, env));
	}
	cell->error("invalid lambda expression\n");
	return (0, nil);	
}

let(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	vals: list of (string, ref Cell);
	el: list of ref Env;

	if(args == nil || cell->isnil(args)) {
		cell->error("too few arguments in let\n");
		return (0, nil);
	}
	binds := cell->lcar(args);
	exprs := cell->lcdr(args);
	if(binds == nil || cell->isnil(binds)) {
		startbody();
		r := begin(exprs, env);
		resetbody();
		return r;
	}
	func_name := "";
	pick x := binds {
	Symbol =>
		func_name = x.sym;
		binds = cell->lcar(exprs);
		exprs = cell->lcdr(exprs);
	}
	vals = nil;
	bl := binds;
	do {
		b := cell->lcar(bl);
		if(b == nil || cell->isnil(b))
			break;
		exp := cell->lcdr(b);
		pick var := cell->lcar(b) {
		Symbol =>
			(nil, y) := lbegin(exp, env);
			vals = (var.sym, y) :: vals;
		}
		bl = cell->lcdr(bl);
	} while(bl != nil && !(cell->isnil(bl)));
	bl = binds;
	el = env;
	do {
		b := cell->lcar(bl);
		if(b == nil || cell->isnil(b))
			break;
		if(vals == nil)
			break;
		(var, val) := hd vals;
		if(var == "")
			cell->error("empty name for define in let\n");
		(nil, el) = cell->ldefine(var, val, el);
		bl = cell->lcdr(bl);
		vals = tl vals;
	} while(bl != nil && !(cell->isnil(bl)));
	if(func_name != "") {
		bl = binds;
		formals := ref Cell.Link(nil);
		f: ref Cell;
		f = formals;
		do {
			fname: string;
			b := cell->lcar(bl);
			if(b == nil || cell->isnil(b))
				break;
			pick bn := cell->lcar(b) {
			Symbol =>
				fname = bn.sym;
			}
			pick fl := f {
			Link =>
				fl.next = ref Pair(
					ref Cell.Symbol(fname, nil), ref Cell.Link(nil));
				f = cell->lcdr(f);
			}
			bl = cell->lcdr(bl);
		} while(bl != nil && !(cell->isnil(bl)));
		lambda_exp := cell->lcons(
			ref Cell.Symbol("lambda", cell->lookupsym("lambda", el)),
				cell->lcons(formals,
				cell->lcons(cell->lcar(exprs), ref Cell.Link(nil))));
		(r, nil) := eval(lambda_exp, el);
		if(func_name == "")
			cell->error("emtpy function name in let\n");
		(nil, el) = cell->ldefine(func_name, r, el);
	}
	startbody();
	(t, r) := begin(exprs, el);
	resetbody();
	if (t == 0)
		return (0, r);
	pick c := r {
	Continuation =>
		res := ref Cell.Continuation(c.exp, el);
		return (1, res);
	* =>
		return (0, r);
	}
}

letstar(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	el: list of ref Env;

	if(args == nil || cell->isnil(args)) {
		cell->error("too few arguments to let*\n");
		return (0, nil);
	}
	binds := cell->lcar(args);
	exprs := cell->lcdr(args);
	if(binds == nil || cell->isnil(binds)) {
		startbody();
		r := begin(exprs, env);
		resetbody();
		return r;
	}
	bl := binds;
	el = env;
	do {
		b := cell->lcar(bl);
		if(b == nil || cell->isnil(b))
			break;
		pick var := cell->lcar(b) {
		Symbol =>
			exp := cell->lcdr(b);
			(nil, y) := lbegin(exp, el);
			if(var.sym == "")
				cell->error("empty name for define in letstar\n");
			(nil, el) = cell->ldefine(var.sym, y, el);
		}
		bl = cell->lcdr(bl);
	} while(bl != nil && !(cell->isnil(bl)));
	startbody();
	(t, r) := begin(exprs, el);
	resetbody();
	if (t == 0)
		return (0, r);
	pick c := r {
	Continuation =>
		res := ref Cell.Continuation(c.exp, el);
		return (1, res);
	* =>
		return (0, r);
	}
}

letrec(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	el: list of ref Env;

	if(args == nil || cell->isnil(args)) {
		cell->error("too few arguments to let*\n");
		return (0, nil);
	}
	binds := cell->lcar(args);
	exprs := cell->lcdr(args);
	if(binds == nil || cell->isnil(binds)) {
		startbody();
		r := begin(exprs, env);
		resetbody();
		return r;
	}
	bl := binds;
	el = env;
	do {
		b := cell->lcar(bl);
		if(b == nil || cell->isnil(b))
			break;
		pick var := cell->lcar(b) {
		Symbol =>
			if(var.sym == "")
				cell->error("empty name for define in letrec\n");
			(nil, el) = cell->ldefine(var.sym, ref Cell.Link(nil), el);
		}
		bl = cell->lcdr(bl);
	} while(bl != nil && !(cell->isnil(bl)));
	bl = binds;
	do {
		b := cell->lcar(bl);
		if(b == nil || cell->isnil(b))
			break;
		pick var := cell->lcar(b) {
		Symbol =>
			s := cell->lookupsym(var.sym, el);
			if(s == nil)
				cell->error(lsys->sprint("internal error: looking %s failed\n", var.sym));
			else {
				exp := cell->lcdr(b);
				(nil, y) := lbegin(exp, el);
				s.val = y;
			}
		}
		bl = cell->lcdr(bl);
	} while(bl != nil && !(cell->isnil(bl)));
	startbody();
	(t, r) := begin(exprs, el);
	resetbody();
	if (t == 0)
		return (0, r);
	pick c := r {
	Continuation =>
		res := ref Cell.Continuation(c.exp, el);
		return (1, res);
	* =>
		return (0, r);
	}
}

lor(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	c: ref Cell;
	e: list of ref Env;

	if(args == nil)
		return (0, nil);
	if(cell->isnil(args))
		return (0, ref Cell.Boolean(0));
	p := cell->lcar(args);
	if (p == nil || cell->isnil(p))
		return (0, ref Cell.Boolean(0));
	l := cell->lcdr(args);
	e = env;
	while(l != nil && !(cell->isnil(l))) {
		(c, e) = eval(p, e);
		if (c == nil)
			continue;
		pick cn := c {
		Boolean =>
			if(cn.b == 1)
				return (0, c);
		* =>
			return (0, c);
		}
		p = cell->lcar(l);
		l = cell->lcdr(l);
	}
	return (1, ref Cell.Continuation(p, e));
}

lqquote(expr: ref Cell, level: int, env: list of ref Env): (int, ref Cell)
{
	if(expr == nil || cell->isnil(expr))
		return (0, expr);
	pick y := expr {
	Link =>
		if(y.next == nil || y.next.car == nil)
			return (0, expr);
		pick z := y.next.car {
		Symbol =>
			if(z.sym == "unquote") {
				if(level == 1) {
					(nil, q) := unquote(y.next.cdr, env);
					return (0, q);
				}
				else {
					(nil, c) := lqquote(y.next.cdr, level - 1, env);
					return (0, ref Cell.Link(ref Pair(z, c)));
				}
			}
			if(z.sym == "unquote-splicing") {
				if(level == 1) {
					(nil, q) := unquote(y.next.cdr, env);
					return (1, q);
				}
				else {
					(nil, c) := lqquote(y.next.cdr, level - 1, env);
					return (0, ref Cell.Link(ref Pair(z, c)));
				}
			}
			if(z.sym == "quasiquote") {
				(nil, c) := lqquote(y.next.cdr, level + 1, env);
				return (0, ref Cell.Link(ref Pair(z, c)));
			}
		}
		(n, ca) := lqquote(y.next.car, level, env);
		(nil, cd) := lqquote(y.next.cdr, level, env);
		if(n == 1)
			return (0, cell->lappend(ca, cd));
		else
			return (0, ref Cell.Link(ref Pair(ca, cd)));
	Vector =>
		n := len y.v;
		nl: list of ref Cell;
		nl = nil;
		for(i := 0; i < n; ++i) {
			(qqs, c) := lqquote(y.v[i], level, env);
			if(qqs == 0) {
				nl = c :: nl;
			}
			else {
				p := c;
				while(1) {
					if(p == nil || cell->isnil(p))
						break;
					nl = cell->lcar(p) :: nl;
					p = cell->lcdr(p);
				}
			}
		}
		nv := array[len nl] of ref Cell;
		for(i = len nl - 1; i >= 0; --i) {
			nv[i] = hd nl;
			nl = tl nl;
		}
		return (0, ref Cell.Vector(nv));
	* =>
		return (0, expr);
	}
}

qquote(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	if(args == nil || cell->isnil(args)) {
		cell->error("wrong number of arguments to quasiquote\n");
		return (0, nil);
	}
	(nil, c) := lqquote(cell->lcar(args), 1, env);
	return (0, c);
}

quote(args: ref Cell, nil: list of ref Env): (int, ref Cell)
{
	if(args == nil || cell->isnil(args))
		return (0, nil);
	return (0, cell->lcar(args));
}

setbang(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	if(args == nil || cell->isnil(args))
		return (0, nil);
	p := cell->lcar(args);
	if(p == nil || cell->isnil(p))
		return (0, nil);
	l := cell->lcdr(args);
	if(l == nil || cell->isnil(l))
		return (0, nil);
	pick y := p {
	Symbol =>
		e := cell->lookupsym(y.sym, env);
		if(e == nil) {
			cell->error("Cannot set unbound variable\n");
			return (0, nil);
		}
		(e.val, nil) = eval(cell->lcar(l), env);
	}
	return (0, p);
}


unquote(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to unquote\n");
		return (0, nil);
	}
	(r, nil) := eval(x, env);
	return (0, r);
}

unquotesplice(args: ref Cell, env: list of ref Env): (int, ref Cell)
{
	x := cell->lcar(args);
	if(x == nil) {
		cell->error("wrong number of arguments to unquote-splicing\n");
		return (0, nil);
	}
	(c, nil) := eval(x, env);
	if(c == nil || cell->isnil(c)) {
		cell->error("invalid expression in unquote-splicing\n");
		return (0, nil);
	}
	pick y := c {
	Link =>
		return (0, y.next.car);
	* =>
		cell->error("invalid expression in unquote-splicing\n");
	}
	return (0, nil);
}

SForm: module
{
	PATH: con "/dis/scheme/sform.dis";

	init: fn(s: Sys, sch: Scheme, c: SCell);
	startbody: fn();
	resetbody: fn();
};

(define ≤ <=)
(define ≥ >=)
(define C≡ char=?)
(define C< char<?)
(define C≤ char<=?)
(define C> char>?)
(define C≥ char>=?)
(define S≡ string=?)
(define S< string<?)
(define S≤ string<=?)
(define S> string>?)
(define S≥ string>=?)
(define SΣ string-append)
(define √ sqrt)
(define ¬ not)
(define ∧ and)
(define ⋀ and)
(define ∨ or)
(define ⋁ or)
(define ∑ +)
(define ∏ *)
(define ÷ /)
(define · *)
(define × *)
;(define ≡ eqv?)
(define ∅ null?)
(define ℤ integer?)
(define ℚ rational?)
(define ℝ real?)
(define ℂ complex?)
(define ⇐ <-=)
(define ⇒ =<-)
;(define ⊨ #t)
(define ¶ define)
(define ≔ define)
(≔ λ lambda)
(≔ ≠ (λ (x y) (¬ (= x y))))

(display "Simple factorial test: answers 120  and 2432902008176640000\n")
(define fact (lambda (n) (if (= n 0) 1 (* n (fact (- n 1))))))
(write (fact 5))
(newline)
(write (fact 20))
(newline)

(display "Quote tests\n")
(display "ans: a   ")
(write (quote a))
(newline)
(display "ans: #(a b c)   ")
(write (quote #(a b c)))
(newline)
(display "ans: (+ 1 2)   ")
(write (quote (+ 1 2))) (newline)
(display "ans: a   ") (write 'a) (newline)
(display "ans: #(a b c))   ") (write '#(a b c)) (newline)
(display "ans: ()   ") (write '()) (newline)
(display "ans: (+ 1 2)   ") (write '(+ 1 2)) (newline)
(display "ans: (quote a)   ") (write '(quote a)) (newline)
(display "ans: (quote a)   ") (write ''a) (newline)
(display "ans: \"abc\"   ") (write '"abc") (newline)
(display "ans: \"abc\"   ") (write "abc") (newline)
(display "ans: 145932   ") (write '145932) (newline)
(display "ans: 145932   ") (write 145932) (newline)
(display "ans: #t   ") (write '#t) (newline)
(display "ans: #t   ") (write #t) (newline)

(display "\n\nSimple procedure call\n")
(display "ans: 7   ") (write (+ 3 4)) (newline)
(display "Operator expression: ((if #f + *) 3 4)\n")
(display "ans: 12   ") (write ((if #f + *) 3 4)) (newline)

(display "\n\nLambda expressions:\n")
(display "ans: 8   ") (write ((lambda (x) (+ x x)) 4)) (newline)
(display "ans: 3   ")
(define reverse-subtract (lambda (x y) (- y x)))
(write (reverse-subtract 7 10)) (newline)
(display "ans: 10   ")
(define add4 (let ((x 4)) (lambda (y) (+ x y))))
(write (add4 6)) (newline)
(display "ans: (3 4 5 6)   ")
(write ((lambda x x) 3 4 5 6)) (newline)
(display "ans: (5 6)   ")
(write ((lambda (x y . z) z) 3 4 5 6)) (newline)

(display "\n\nif tests:\n")
(display "ans: yes   ") (write (if (> 3 2) 'yes 'no)) (newline)
(display "ans: no   ") (write (if (> 2 3) 'yes 'no)) (newline)
(display "ans: 1   ") (write (if (> 3 2) (- 3 2) (+ 3 2))) (newline)

(display "\n\nset!:\n")
(display "ans: 3   ")
(define x 2) (write (+ x 1)) (newline)
(display "ans: 5   ")
(set! x 4) (write (+ x 1)) (newline)

(display "\n\ncond:\n")
(display "ans: greater   ")
(write (cond ((> 3 2) ' greater) ((< 3 2) 'less))) (newline)
(display "ans: equal   ")
(write (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) (newline)
(display "ans: 2   ")
(write (cond ((assv 'b '((a 2) (b 2))) => cadr) (else #f))) (newline)

(display "\n\ncase:\n")
(display "ans: composite   ")
(write (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) (newline)
(display "ans: uspecifiecified   ")
(write (case (car '(c d)) ((a) 'a) ((b) 'b))) (newline)
(display "ans: consonant   ")
(write (case (car '(c d)) ((a e i o u) 'vowel) ((w y) 'semivowel) (else 'consonant)))
(newline)

(display "\n\nand:\n")
(display "ans: #t   ") (write (and (= 2 2) (> 2 1))) (newline)
(display "ans: #f   ") (write (and (= 2 2) (< 2 1))) (newline)
(display "ans: (f g)   ") (write (and 1 2 'c '(f g))) (newline)
(display "ans: #t   ") (write (and)) (newline)

(display "\n\nor:\n")
(display "ans: #t   ") (write (or (= 2 2) (> 2 1))) (newline)
(display "ans: #t   ") (write (or (= 2 2) (< 2 1))) (newline)
(display "ans: #f   ") (write (or #f #f #f)) (newline)
(display "ans: (b c)   ") (write (or (memq 'b '(a b c)) (/ 3 0))) (newline)

(display "\n\nlet, let*, letrec:\n")
(display "ans: 6   ") (write (let ((x 2) (y 3)) (* x y))) (newline)
(display "ans: 35   ")
(write (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
(newline)
(display "ans: 70   ")
(write (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
(newline)
(display "ans: #t   ")
(write
(letrec ((even?
              (lambda (n)
                (if (zero? n) #t (odd? (- n 1)))))
            (odd?
              (lambda (n)
                (if (zero? n) #f (even? (- n 1))))))
  (even? 88))) (newline)

(display "\n\nbegin:\n")
(display "ans: 6   ")
(define x 0)
(write (begin (set! x 5) (+ x 1))) (newline)
(display "ans: unspecified and outputs \"4 plus 1 equals 5\"\n")
(write (begin (display "4 plus one equal ") (display (+ 4 1)))) (newline)

(display "\n\ndo:\n")
(display "ans: #(0 1 2 3 4)   ")
(write
  (do ((vec (make-vector 5))
      (i 0 (+ i 1)))
    ((= i 5) vec)
  (vector-set! vec i i))
) (newline)
(display "ans: 25   ")
(write
  (let ((x '(1 3 5 7 9)))
    (do ((x x (cdr x))
      (sum 0 (+ sum (car x))))
      ((null? x) sum)))
) (newline)

(display "\n\nnamed let:\n")
(display "ans: ((6 1 3) (-5 -2))   ")
(write
  (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '()))
    (cond ((null? numbers) (list nonneg neg))
             ((>= (car numbers) 0)
              (loop (cdr numbers) (cons (car numbers) nonneg) neg))
             ((< (car numbers) 0)
              (loop (cdr numbers) nonneg (cons (car numbers) neg)))))
) (newline)

(display "\n\nquasiquote:\n")
(display "ans: (list 3 4)   ") (write `(list ,(+ 1 2) 4)) (newline)
(display "ans: (a 3 4 5 6 b)   ")
(write `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) (newline)
(display "ans: ((foo 7) . cons)   ")
(write `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) (newline)
(display "ans: #(10 5 2 4 3 8)   ")
(write `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)) (newline)
(display "ans: (a `(b ,(+ 1 2) ,(foo 4 d) e) f)   ")
(write `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) (newline)
(display "ans: (a `(b ,x ,'y d) e)   ")
(write (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
(newline)
(display "ans: (list 3 4)   ")
(write (quasiquote (list (unquote (+ 1 2)) 4))) (newline)
(display "ans: `(list ,(+ 1 2) 4)   ")
(write '(quasiquote (list (unquote (+ 1 2)) 4))) (newline)

(display "\n\nTop level definitions:\n")
(display "ans: 6   ")
(define add3 (lambda (x) (+ x 3)))
(write (add3 3)) (newline)
(display "ans: 1   ")
(define first car)
(write (first '(1 2))) (newline)

(display "\n\nInternal definitions:\n")
(display "ans: 45   ")
(write
  (let ((x 5))
    (define foo (lambda (y) (bar x y)))
    (define bar (lambda (a b) (+ (* a b) a)))
    (foo (+ x 3))))
(newline)
(display "ans: 45   ")
(write
  (let ((x 5))
    (letrec ((foo (lambda (y) (bar x y)))
                (bar (lambda (a b) (+ (* a b) a))))
      (foo (+ x 3)))))
(newline)

(display "\n\nEquivalence predicates:\n")
(display "eqv?\n")
(display "ans: #t   ") (write (eqv? 'a 'a)) (newline)
(display "ans: #f   ") (write (eqv? 'a 'b)) (newline)
(display "ans: #t   ") (write (eqv? 2 2)) (newline)
(display "ans: #t   ") (write (eqv? '() '())) (newline)
(display "ans: #t   ") (write (eqv? 100000000 100000000)) (newline)
(display "ans: #f   ") (write (eqv? (cons 1 2) (cons 1 2))) (newline)
(display "ans: #f   ")
(write (eqv? (lambda () 1) (lambda () 2))) (newline)
(display "ans: #f   ") (write (eqv? #f 'nil)) (newline)
(display "ans: #t   ")
(write (let ((p (lambda (x) x))) (eqv? p p))) (newline)
(display "ans: unspecified   ")
(write (eqv? "" "")) (newline)
(display "ans: unspecified   ") (write (eqv? '#() '#())) (newline)
(display "ans: unspecified   ")
(write (eqv? (lambda (x) x) (lambda (x) x))) (newline)
(display "ans: unspecified   ")
(write (eqv? (lambda (x) x) (lambda (y) y))) (newline)
(display "ans: #t   ")
(define gen-counter
  (lambda ()
    (let ((n 0))
      (lambda () (set! n (+ n 1)) n))))
(write (let ((g (gen-counter))) (eqv? g g))) (newline)
(display "ans: #f   ")
(write (eqv? (gen-counter) (gen-counter))) (newline)
(display "ans: #t   ")
(define gen-loser
  (lambda ()
    (let ((n 0))
      (lambda () (set! n (+ n 1)) 27))))
(write (let ((g (gen-loser))) (eqv? g g))) (newline)
(display "ans: unspecified   ")
(write (eqv? (gen-loser) (gen-loser))) (newline)
(display "ans: unspecified   ")
(write (letrec ((f (lambda () (if (eqv? f g) 'both 'f)))
                      (g (lambda () (if (eqv? f g) 'both 'g))))
   (eqv? f g))) (newline)
(display "ans: #f   ")
(write (letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
                      (g (lambda () (if (eqv? f g) 'g 'both))))
    (eqv? f g))) (newline)
(display "ans: unspecified   ")
(write (eqv? '(a) '(a))) (newline)
(display "ans: unspecified   ")
(write (eqv? "a" "a")) (newline)
(display "ans: unspecified   ")
(write (eqv? '(b) (cdr '(a b)))) (newline)
(display "ans: #t   ")
(write (let ((x '(a))) (eqv? x x))) (newline)

(display "eq?\n")
(display "ans: #t   ") (write (eq? 'a 'a)) (newline)
(display "ans: unspecified   ") (write (eq? '(a) '(a))) (newline)
(display "ans: #f   ") (write (eq? (list 'a) (list 'a))) (newline)
(display "ans: unspecified   ") (write (eq? "a" "a")) (newline)
(display "ans: unspecified   ") (write (eq? "" "")) (newline)
(display "ans: #t   ") (write (eq? '() '())) (newline)
(display "ans: unspecified   ") (write (eq? 2 2)) (newline)
(display "ans: unspecified   ") (write (eq? #\A #\A)) (newline)
(display "ans: #t   ") (write (eq? car car)) (newline)
(display "ans: unspecified ") (write (let ((n (+ 2 3))) (eq? n n))) (newline)
(display "ans: #t   ") (write (let ((x '(a))) (eq? x x))) (newline)
(display "ans: #t   ") (write (let ((x '#())) (eq? x x))) (newline)
(display "ans: #t   ") (write (let ((p (lambda (x) x))) (eq? p p))) (newline)

(display "equal?\n")
(display "ans: #t   ") (write (equal? 'a 'a)) (newline)
(display "ans: #t   ") (write (equal? '(a) '(a))) (newline)
(display "ans: #t   ") (write (equal? '(a (b) c) '(a (b) c))) (newline)
(display "ans: #t   ") (write (equal? "abc" "abc")) (newline)
(display "ans: #t   ") (write (equal? 2 2)) (newline)
(display "ans: #t   ") (write (equal? (make-vector 5 'a) (make-vector 5 'a)))
(newline)
(display "ans: unspecified   ")
(write (equal? (lambda (x) x) (lambda (y) y))) (newline)

(display "\n\nNumerical operations:\n")
(display "classification predicates\n")
(display "ans: #t   ") (write (complex? 3)) (newline)
(display "ans: #t   ") (write (real? 3)) (newline)
(display "ans: #t   ") (write (real? #e1e10)) (newline)
(display "ans: #t   ") (write (rational? 6/10)) (newline)
(display "ans: #t   ") (write (rational? 6/3)) (newline)
(display "ans: #t   ") (write (integer? 3.0)) (newline)
(display "ans: #t   ") (write (integer? 8/4)) (newline)

(display "max\n")
(display "ans: 4   ") (write (max 3 4)) (newline)
(display "ans: 4.0   ") (write (max 3.9 4)) (newline)

(display "basic arithmetic\n")
(display "ans: 7   ") (write (+ 3 4)) (newline)
(display "ans: 3   ") (write (+ 3)) (newline)
(display "ans: 0   ") (write (+)) (newline)
(display "ans: 4   ") (write (* 4)) (newline)
(display "ans: 1   ") (write (*)) (newline)
(display "ans: -1   ") (write (- 3 4)) (newline)
(display "ans: -6   ") (write (- 3 4 5)) (newline)
(display "ans: -3   ") (write (- 3)) (newline)
(display "ans: 3/20   ") (write (/ 3 4 5)) (newline)
(display "ans: 1/3   ") (write (/ 3)) (newline)

(display "integer division, remainder,modulo\n")
(display "ans: 1   ") (write (modulo 13 4)) (newline)
(display "ans: 1   ") (write (remainder 13 4)) (newline)
(display "ans: 3   ") (write (modulo -13 4)) (newline)
(display "ans: -1   ") (write (remainder -13 4)) (newline)
(display "ans: -3   ") (write (modulo 13 -4)) (newline)
(display "ans: 1   ") (write (remainder 13 -4)) (newline)
(display "ans: -1   ") (write (modulo -13 -4)) (newline)
(display "ans: -1   ") (write (remainder -13 -4)) (newline)
(display "ans: -1.0   ") (write (remainder -13 -4.0)) (newline)

(display "gcd, lcm\n")
(display "ans: 4   ") (write (gcd 32 -36)) (newline)
(display "ans: 0   ") (write (gcd)) (newline)
(display "ans: 288   ") (write (lcm 32 -36)) (newline)
(display "ans: 288.0   ") (write (lcm 32.0 -36)) (newline)
(display "ans: 1   ") (write (lcm)) (newline)

(display "numerator, denominator\n")
(display "ans: 3   ") (write (numerator (/ 6 4))) (newline)
(display "ans: 2   ") (write (denominator (/ 6 4))) (newline)
(display "ans: 2.0   ")
(write (denominator (exact->inexact (/ 6 4)))) (newline)

(display "floor, ceiling, truncate, round\n")
(display "ans: -5.0   ") (write (floor -4.3)) (newline)
(display "ans: -4.0   ") (write (ceiling -4.3)) (newline)
(display "ans: -4.0   ") (write (truncate -4.3)) (newline)
(display "ans: -4.0   ") (write (round -4.3)) (newline)
(display "ans: 3.0   ") (write (floor 3.5)) (newline)
(display "ans: 4.0   ") (write (ceiling 3.5)) (newline)
(display "ans: 3.0   ") (write (truncate 3.5)) (newline)
(display "ans: 4.0 (inexact)   ") (write (round 3.5)) (newline)
(display "ans: 4 (exact)   ") (write (round 7/2)) (newline)
(display "ans: 7   ") (write (round 7)) (newline)

(display "\n\nrationalize:\n")
(display "ans: 1/3 (exact)   ")
(write (rationalize (inexact->exact .3) 1/10)) (newline)
(display "ans: #i1/3 (inexact)   ")
(write (rationalize .3 1/10)) (newline)

(display "\n\nstring->number\n")
(display "ans: 100   ") (write (string->number "100")) (newline)
(display "ans: 256   ") (write (string->number "100" 16)) (newline)
(display "ans: 100.0   ") (write (string->number "1e2")) (newline)

(display "\n\nBoolean operations:\n")
(display "ans: #t   ") (write #t) (newline)
(display "ans: #f   ") (write #f) (newline)
(display "ans: #f   ") (write '#f) (newline)
(display "ans: #f   ") (write (not #t)) (newline)
(display "ans: #f   ") (write (not 3)) (newline)
(display "ans: #f   ") (write (not (list 3))) (newline)
(display "ans: #t   ") (write (not #f)) (newline)
(display "ans: #f   ") (write (not '())) (newline)
(display "ans: #f   ") (write (not (list))) (newline)
(display "ans: #f   ") (write (not 'nil)) (newline)
(display "ans: #t   ") (write (boolean? #f)) (newline)
(display "ans: #f   ") (write (boolean? 0)) (newline)
(display "ans: #f   ") (write (boolean? '())) (newline)

(display "\n\nList operations:\n")
(display "define/set:\n")
(display "ans: (a b c)   ")
(define x (list 'a 'b 'c))
(define y x)
(write y) (newline)
(display "ans: #t   ") (write (list? y)) (newline)
(display "ans: unspecified   ") (write (set-cdr! x 4)) (newline)
(display "ans: (a . 4)   ") (write x) (newline)
(display "ans: #t   ") (write (eqv? x y)) (newline)
(display "ans: (a . 4)   ") (write y) (newline)
(display "ans: #f   ") (write (list? y)) (newline)
;(display "ans: unspecified   ") (write (set-cdr! x x)) (newline)
;(display "ans: #f   ") (write (list? x)) (newline)

(display "predicates:\n")
(display "ans: #t   ") (write (pair? '(a . b))) (newline)
(display "ans: #t   ") (write (pair? '(a b c))) (newline)
(display "ans: #f   ") (write (pair? '())) (newline)
(display "ans: #f   ") (write (pair? '#(a b))) (newline)

(display "cons, car, cdr\n")
(display "ans: (a)   ") (write (cons 'a '())) (newline)
(display "ans: ((a) b c d)   ") (write (cons '(a) '(b c d))) (newline)
(display "ans: (\"a\" b c)   ") (write (cons "a" '(b c))) (newline)
(display "ans: (a . 3)   ") (write (cons 'a 3)) (newline)
(display "ans: ((a b) . c)   ") (write (cons '(a b) 'c)) (newline)
(display "ans: a   ") (write (car '(a b c))) (newline)
(display "ans: (a)   ") (write (car '((a) b c))) (newline)
(display "ans: 1   ") (write (car '(1 . 2))) (newline)
(display "ans: error   ") (write (car '())) (newline)
(display "ans: (b c d)   ") (write (cdr '((a) b c d))) (newline)
(display "ans: 2   ") (write (cdr '(1 . 2))) (newline)
(display "ans: error   ") (write (cdr '())) (newline)

(display "set-car!\n")
(display "ans: unspecified   ")
(define (f) (list 'not-a-constant-list))
(define (g) '(constant-list))
(write (set-car! (f) 3)) (newline)
(display "ans: error   ")
(write (set-car! (g) 3)) (newline)

(display "list?\n")
(display "ans: #t   ") (write (list? '(a b c))) (newline)
(display "ans: #t   ") (write (list? '())) (newline)
(display "ans: #f   ") (write (list? '(a . b))) (newline)
(display "ans: #f   ")
(write (let ((x (list 'a))) (set-cdr! x x) (list? x))) (newline)

(display "list\n")
(display "ans: (a 7 c)   ") (write (list 'a (+ 3 4) 'c)) (newline)
(display "ans: ()   ") (write (list)) (newline)

(display "length\n")
(display "ans: 3   ") (write (length '(a b c))) (newline)
(display "ans: 3   ") (write (length '(a (b) (c d e)))) (newline)
(display "ans: 0   ") (write (length '())) (newline)

(display "append\n")
(display "ans: (x y)   ") (write (append '(x) '(y))) (newline)
(display "ans: (a b c d)   ") (write (append '(a) '(b c d))) (newline)
(display "ans: (a (b) (c))   ") (write (append '(a (b)) '((c)))) (newline)
(display "ans: (a b c . d)   ") (write (append '(a b) '(c . d))) (newline)
(display "ans: a   ") (write (append '() 'a)) (newline)

(display "reverse\n")
(display "ans: (c b a)   ") (write (reverse '(a b c))) (newline)
(display "ans: ((e (f)) d (b c) a)   ") (write (reverse '(a (b c) d (e (f))))) (newline)

(display "list-ref\n")
(display "ans: c   ") (write (list-ref '(a b c d) 2)) (newline)
(display "ans: c   ")
(write (list-ref '(a b c d) (inexact->exact (round 1.8)))) (newline)

(display "memq, memv, member\n")
(display "ans: (a b c)   ") (write (memq 'a '(a b c))) (newline)
(display "ans: (b c)   ") (write (memq 'b '(a b c))) (newline)
(display "ans: #f   ") (write (memq 'a '(b c d))) (newline)
(display "ans: #f   ") (write (memq (list 'a) '(b (a) c))) (newline)
(display "ans: ((a) c)   ") (write (member (list 'a) '(b (a) c))) (newline)
(display "ans: unspecified   ") (write (memq 101 '(100 101 102))) (newline)
(display "ans; (101 102)   ") (write (memv 101 '(100 101 102))) (newline)

(display "assq, assv, assoc\n")
(display "ans: (a 1)   ")
(define e '((a 1) (b 2) (c 3)))
(write (assq 'a e)) (newline)
(display "ans: (b 2)   ") (write (assq 'b e)) (newline)
(display "ans: #f   ") (write (assq 'd e))  (newline)
(display "ans: #f   ")
(write (assq (list 'a) '(((a)) ((b)) ((c))))) (newline)
(display "ans: ((a))   ")
(write (assoc (list 'a) '(((a)) ((b)) ((c))))) (newline)
(display "ans: unspecified   ")
(write (assq 5 '((2 3) (5 7) (11 13)))) (newline)
(display "ans: (5 7)   ")
(write (assv 5 '((2 3) (5 7) (11 13)))) (newline)

(display "\n\nSymbols:\n")
(display "symbol?\n")
(display "ans: #t   ") (write (symbol? 'foo)) (newline)
(display "ans: #t   ") (write (symbol? (car '(a b)))) (newline)
(display "ans: #f   ") (write (symbol? "bar")) (newline)
(display "ans: #t   ") (write (symbol? 'nil)) (newline)
(display "ans: #f   ") (write (symbol? '())) (newline)
(display "ans: #f   ") (write (symbol? #f)) (newline)

(display "symbol->string\n")
(display "ans: \"flying-fish\"   ")
(write (symbol->string 'flying-fish)) (newline)
(display "ans: \"martin\"   ")
(write (symbol->string 'Martin)) (newline)
(display "ans: \"Malvina\"   ")
(write (symbol->string (string->symbol "Malvina"))) (newline)

(display "string->symbol\n")
(display "ans: mISSISSIppi   ")
(write (string->symbol "mISSISSIppi")) (newline)
(display "ans: #f   ")
(write (eq? 'bitBlt (string->symbol "bitBlt"))) (newline)
(display "ans: #t   ")
(write (eq? 'JollyWog (string->symbol (symbol->string 'JollyWog))))
(newline)
(display "ans: #t   ")
(write (string=? "K. Harper, M.D."
                        (symbol->string (string->symbol "K. Harper, M.D."))))
(newline)

(display "\n\nCharacters:\n")
(display "ans: #t   ") (write (char-ci=? #\A #\a)) (newline)

(display "\n\nStrings:\n")
(display "ans: unspecified   ")
(define (f) (make-string 3 #\*))
(define (g) "***")
(write (string-set! (f) 0 #\?)) (newline)
(display "ans: error   ")
(write (string-set! (g) 0 #\?)) (newline)
(display "ans: error   ")
(write (string-set! (symbol->string 'immutable) 0 #\?)) (newline)

(display "\n\nVectors:\n")
(display "ans: #(a b c)   ") (write (vector 'a 'b 'c)) (newline)
(display "ans: 8   ") (write (vector-ref '#(1 1 2 3 5 8 13 21) 5)) (newline)
(display "ans: 13   ")
(write (vector-ref '#(1 1 2 3 5 8 13 21)
                           (let ((i (round (* 2 (acos -1)))))
                             (if (inexact? i)
                                 (inexact->exact i) i)))) (newline)
(display "ans: #(0 (\"Sue\" \"Sue\") \"Anna\")   ")
(write (let ((vec (vector 0 '(2 2 2 2) "Anna")))
                (vector-set! vec 1 '("Sue" "Sue")) vec)) (newline)
(display "ans: error   ") (write (vector-set! '#(0 1 2) 1 "doe")) (newline)
(display "ans: (dah dah didah)   ")
(write (vector->list '#(dah dah didah))) (newline)
(display "ans: #(dididit dah)   ")
(write (list->vector '(dididit dah))) (newline)

(display "\n\nControl features:\n")
(display "procedure?\n")
(display "ans: #t   ") (write (procedure? car)) (newline)
(display "ans: #f   ") (write (procedure? 'car)) (newline)
(display "ans: #t   ") (write (procedure? (lambda (x) (* x x)))) (newline)
(display "ans: #f   ") (write (procedure? '(lambda (x) (* x x)))) (newline)

(display "apply\n")
(display "ans: 7   ") (write (apply + (list 3 4))) (newline)
(display "ans: 30   ")
(define compose (lambda (f g) (lambda args (f (apply g args)))))
(write ((compose sqrt *) 12 75)) (newline)

(display "map\n")
(display "ans: (b e h)   ")
(write (map cadr '((a b) (d e) (g h)))) (newline)
(display "ans: (1 4 27 256 3125)   ")
(write (map (lambda (n) (expt n n)) '(1 2 3 4 5))) (newline)
(display "ans: (5 7 9)   ") (write (map + '(1 2 3) '(4 5 6))) (newline)
(display "ans: (1 2) or (2 1)   ")
(write (let ((count 0))
                (map (lambda (ignored) (set! count (+ count 1)) count)
                        '(a b)))) (newline)

(display "for-each\n")
(display "ans: #(0 1 4 9 16)   ")
(write (let ((v (make-vector 5)))
                (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v))
(newline)

(display "delay/force\n")
(display "ans: 3   ")
(write (force (delay (+ 1 2)))) (newline)
(display "ans: (3 3)   ")
(write
  (let ((p (delay (+ 1 2))))
    (list (force p) (force p)))
) (newline)
(display "ans: 2   ")
  (define a-stream
    (letrec ((next
            (lambda (n)
              (cons n (delay (next (+ n 1)))))))
    (next 0)))
  (define head car)
  (define tail
    (lambda (stream) (force (cdr stream))))
(write
      (head (tail (tail a-stream)))
) (newline)

(define count 0)
(define p
  (delay (begin (set! count (+ count 1))
                (if (> count x)
                    count
                    (force p)))))
(define x 5)

(display "ans: [promise]   ")
(write p) (newline)
(display "ans: 6   ")
(write (force p)) (newline)
(display "ans: [promise]   ")
(write p) (newline)
(display "ans: 6   ")
(write (begin (set! x 100) (force p))) (newline)

services/httpd/root
services/ppp
src
tmp
usr/inferno/charon
usr/inferno/keyring
usr/inferno/tmp
dis/scheme