/* parse.c 724b */
Value parsesx(Par p) {
switch (p->alt) {
case ATOM:
{
Name n = p->u.atom;
const char *s = nametostr(n);
long l; /* value of digits in s, if any */
char *t; /* first nondigit in s */
l = strtol(s, &t, 10);
if (*t == '\0' && *s != '\0') /* s is all digits */
return mkNum(l);
else if (strcmp(s, "#t") == 0)
return truev;
else if (strcmp(s, "#f") == 0)
return falsev;
else if (strcmp(s, ".") == 0)
error("this interpreter cannot handle . in quoted S-expressions"
);
else
return mkSym(n);
}
case LIST:
/* parsesx [[LIST]] and return 724c */
if (p->u.list == NULL)
return mkNil();
else
return mkPair(allocate(parsesx(p->u.list->hd)),
allocate(parsesx(mkList(p->u.list->tl))));
}
assert(0);
return falsev;
}
/* parse.c 612d */
static Exp parseexp(Par p) {
switch (p->alt) {
case ATOM:
/* parseexp [[atom]] and return the result 612e */
{
const char *s = nametostr(p->u.atom);
char *t;
long l = strtol(s, &t, 10);
if (*t == '\0') /* the number is the whole string */
return mkLiteral(l);
else
return mkVar(p->u.atom);
}
case LIST:
/* parseexp [[list]] and return the result 613a */
{
Parlist pl;
Name first;
Explist argl;
pl = p->u.list;
if (pl == NULL)
error("%p: empty list in input", p);
if (pl->hd->alt != ATOM)
error("%p: first item of list not name", p);
first = pl->hd->u.atom;
argl = parselist(pl->tl);
if (first == strtoname("begin")) {
/* parseexp [[begin]] and return the result 613b */
return mkBegin(argl);
} else if (first == strtoname("if")) {
/* parseexp [[if]] and return the result 613c */
if (lengthEL(argl) != 3)
error("%p: usage: (if cond true false)", p);
return mkIfx(nthEL(argl, 0), nthEL(argl, 1), nthEL(argl, 2));
} else if (first == strtoname("set")) {
/* parseexp [[set]] and return the result 613e */
if (lengthEL(argl) != 2)
error("%p: usage: (set var exp)", p);
if (nthEL(argl, 0)->alt != VAR)
error("%p: set needs variable as first param", p);
return mkSet(nthEL(argl, 0)->u.var, nthEL(argl, 1));
} else if (first == strtoname("while")) {
/* parseexp [[while]] and return the result 613d */
if (lengthEL(argl) != 2)
error("%p: usage: (while cond body)", p);
return mkWhilex(nthEL(argl, 0), nthEL(argl, 1));
} else {
/* parseexp function application and return the result 614a */
return mkApply(first, argl);
}
}
default:
assert(0);
return NULL;
}
}
/*
* Function [[readevalprint]] evaluates definitions,
* updates the environment [[*envp]], and remembers unit
* tests. [*]
* <evaldef.c>=
*/
void readevalprint(XDefreader reader, Env *envp, Echo echo) {
XDef d;
UnitTestlist unit_tests = NULL;
while ((d = readxdef(reader)))
switch (d->alt) {
case DEF:
*envp = evaldef(d->u.def, *envp, echo);
break;
case USE:
/*
* Reading a file is as in Impcore, except that
* in micro-Scheme, we cannot mutate an environment.
* We therefore pass [[readevalprint]] a pointer to the
* environment [[env]], and when [[readevalprint]]
* evaluates a definition, it writes a new environment
* in place of the old one.
* <read in a file and update [[*envp]]>=
*/
{
const char *filename = nametostr(d->u.use);
FILE *fin = fopen(filename, "r");
if (fin == NULL)
error("cannot open file \"%s\"", filename);
readevalprint(xdefreader(filereader(filename, fin), NO_PROMPTS),
envp, ECHOING);
fclose(fin);
}
break;
case TEST:
unit_tests = mkUL(d->u.test, unit_tests);
break;
default:
assert(0);
}
set_error_mode(TESTING);
/*
* <run the remembered [[unit_tests]], last one first>=
*/
{ int npassed = tests_passed(unit_tests, *envp);
int ntests = lengthUL(unit_tests);
report_test_results(npassed, ntests);
}
set_error_mode(NORMAL);
}
/* evaldef.c 149b */
void readevalprint(XDefreader reader, Env *envp, Echo echo) {
XDef d;
UnitTestlist unit_tests = NULL;
while ((d = readxdef(reader)))
switch (d->alt) {
case DEF:
*envp = evaldef(d->u.def, *envp, echo);
break;
case USE:
/* read in a file and update [[*envp]] 149a */
{
const char *filename = nametostr(d->u.use);
FILE *fin = fopen(filename, "r");
if (fin == NULL)
error("cannot open file \"%s\"", filename);
readevalprint(xdefreader(filereader(filename, fin), NO_PROMPTS),
envp, ECHOING);
fclose(fin);
}
break;
case TEST:
unit_tests = mkUL(d->u.test, unit_tests);
break;
default:
assert(0);
}
set_error_mode(TESTING);
/* run the remembered [[unit_tests]], last one first 712d */
{ int npassed = tests_passed(unit_tests, *envp);
int ntests = lengthUL(unit_tests);
report_test_results(npassed, ntests);
}
set_error_mode(NORMAL);
}
/* eval.c 40b */
Value eval(Exp e, Valenv globals, Funenv functions, Valenv formals, Valenv locals) {
checkoverflow(1000000 * sizeof(char *)); /* OMIT */
switch (e->alt) {
case LITERAL:
/* evaluate [[e->u.literal]] and return the result 40c */
return e->u.literal;
case VAR:
/* evaluate [[e->u.var]] and return the result 41a */
if (isvalbound(e->u.var, locals))
return fetchval(e->u.var, locals);
else if (isvalbound(e->u.var, formals))
return fetchval(e->u.var, formals);
else if (isvalbound(e->u.var, globals))
return fetchval(e->u.var, globals);
else
error("unbound variable %n", e->u.var);
assert(0); /* not reached */
return 0;
case SET:
/* evaluate [[e->u.set]] and return the result 41b */
{
Value v = eval(e->u.set.exp, globals, functions, formals, locals);
if (isvalbound(e->u.set.name, locals))
bindval(e->u.set.name, v, locals);
else if (isvalbound(e->u.set.name, formals))
bindval(e->u.set.name, v, formals);
else if (isvalbound(e->u.set.name, globals))
bindval(e->u.set.name, v, globals);
else
error("set: unbound variable %n", e->u.set.name);
return v;
}
case IFX:
/* evaluate [[e->u.ifx]] and return the result 42a */
if (eval(e->u.ifx.cond, globals, functions, formals, locals) != 0)
return eval(e->u.ifx.true, globals, functions, formals, locals);
else
return eval(e->u.ifx.false, globals, functions, formals, locals);
case WHILEX:
/* evaluate [[e->u.whilex]] and return the result 42b */
while (eval(e->u.whilex.cond, globals, functions, formals, locals) != 0)
eval(e->u.whilex.exp, globals, functions, formals, locals);
return 0;
case BEGIN:
/* evaluate [[e->u.begin]] and return the result 43a */
{
Explist el;
Value v = 0;
for (el=e->u.begin; el; el=el->tl)
v = eval(el->hd, globals, functions, formals, locals);
return v;
}
case APPLY:
/* evaluate [[e->u.apply]] and return the result 43b */
{
Fun f;
/* make [[f]] the function denoted by [[e->u.apply.name]], or call [[error]] 43c */
if (!isfunbound(e->u.apply.name, functions))
error("call to undefined function %n", e->u.apply.name);
f = fetchfun(e->u.apply.name, functions);
switch (f.alt) {
case USERDEF:
/* apply [[f.u.userdef]] and return the result 44b */
{
Namelist locn = f.u.userdef.locals;
Valuelist locv = NULL;
int i = 0;
Namelist nl = f.u.userdef.formals;
Valuelist vl = evallist(e->u.apply.actuals, globals,
functions, formals, locals);
checkargc(e, lengthNL(nl), lengthVL(vl));
/* Setting the local values to 0 */
while (i < lengthNL(locn)) {
locv = mkVL(0, locv);
i = lengthVL(locv);
}
/* make sure the number of names is equal to the number of values*/
checkargc(e, lengthNL(locn), lengthVL(locv));
return eval(f.u.userdef.body, globals, functions, mkValenv(nl, vl), mkValenv(locn, locv));
}
case PRIMITIVE:
/* apply [[f.u.primitive]] and return the result 45a */
{
Valuelist vl = evallist(e->u.apply.actuals, globals,
functions, formals, locals);
if (f.u.primitive == strtoname("print"))
/* apply [[print]] to [[vl]] and return 45b */
{
Value v;
checkargc(e, 1, lengthVL(vl));
v = nthVL(vl, 0);
print("%v\n", v);
return v;
}
else
/* apply arithmetic primitive to [[vl]] and return 46 */
{
const char *s;
Value v, w;
checkargc(e, 2, lengthVL(vl));
v = nthVL(vl, 0);
w = nthVL(vl, 1);
s = nametostr(f.u.primitive);
assert(strlen(s) == 1);
switch (s[0]) {
case '<':
return v < w;
case '>':
return v > w;
case '=':
return v == w;
case '+':
return v + w;
case '-':
return v - w;
case '*':
return v * w;
case '/':
if (w == 0)
error("division by zero in %e", e);
return v / w;
default:
assert(0);
return 0; /* not reached */
}
}
}
}
assert(0);
return 0; /* not reached */
}
}
/* parse.c 720f */
Exp parseexp(Par p) {
switch (p->alt) {
case ATOM:
/* parseexp [[ATOM]] and return 721 */
{
Name n = p->u.atom;
const char *s; /* string form of n */
char *t; /* nondigits in s, if any */
long l; /* number represented by s, if any */
if (n == strtoname("#t"))
return mkLiteral(truev);
else if (n == strtoname("#f"))
return mkLiteral(falsev);
s = nametostr(n);
l = strtol(s, &t, 10);
if (*t == '\0' && *s != '\0')
/* all the characters in s are digits base 10 */
return mkLiteral(mkNum(l));
else
return mkVar(n);
}
case LIST:
/* parseexp [[LIST]] and return 722a */
{
Parlist pl; /* parenthesized list we are parsing */
Name first;
/* first element, as a name (or NULL if not name) */
Explist el; /* remaining elements, as expressions */
Exp rv; /* result of parsing */
pl = p->u.list;
if (pl == NULL)
error("%p: empty list in input", p);
first = pl->hd->alt == ATOM ? pl->hd->u.atom : NULL;
if (first == strtoname("lambda")) {
/* parseexp [[lambda]] and put the result in [[rv]] 722b */
Par q;
if (lengthPL(pl->tl) != 2)
error("%p: usage: (lambda (formals) exp)", p);
q = nthPL(pl->tl, 0);
if (q->alt != LIST)
error("%p: usage: (lambda (formals) exp)", p);
rv = mkLambdax(mkLambda(getnamelist(p, q->u.list), parseexp(
nthPL(pl->tl, 1))));
} else if (first == strtoname("let")
|| first == strtoname("let*")
|| first == strtoname("letrec")) {
/* parseexp let and put the result in [[rv]] 723a */
Letkeyword letword;
Par letbindings;
if (first == strtoname("let"))
letword = LET;
else if (first == strtoname("let*"))
letword = LETSTAR;
else if (first == strtoname("letrec"))
letword = LETREC;
else
assert(0);
if (lengthPL(pl->tl) != 2)
error("%p: usage: (%n (letlist) exp)", p, first);
letbindings = nthPL(pl->tl, 0);
if (letbindings->alt != LIST)
error("%p: usage: (%n (letlist) exp)", p, first);
rv = mkLetx(letword, NULL, NULL, parseexp(nthPL(pl->tl, 1)));
parseletbindings(p, letbindings->u.list, rv);
} else if (first == strtoname("quote")) {
/* parseexp [[quote]] and put the result in [[rv]] 723d */
{
if (lengthPL(pl) != 2)
error("%p: quote needs exactly one argument", p);
rv = mkLiteral(parsesx(nthPL(pl, 1)));
}
} else {
el = parselist(pl->tl);
if (first == strtoname("begin")) {
/* parseexp [[begin]] and put the result in [[rv]] 724e */
rv = mkBegin(el);
} else if (first == strtoname("if")) {
/* parseexp [[if]] and put the result in [[rv]] 724f */
if (lengthEL(el) != 3)
error("%p: usage: (if cond true false)", p);
rv = mkIfx(nthEL(el, 0), nthEL(el, 1), nthEL(el, 2));
} else if (first == strtoname("set")) {
/* parseexp [[set]] and put the result in [[rv]] 725b */
if (lengthEL(el) != 2)
error("%p: usage: (set var exp)", p);
if (nthEL(el, 0)->alt != VAR)
error("%p: set needs variable as first param", p);
rv = mkSet(nthEL(el, 0)->u.var, nthEL(el, 1));
} else if (first == strtoname("while")) {
/* parseexp [[while]] and put the result in [[rv]] 725a */
if (lengthEL(el) != 2)
error("%p: usage: (while cond body)", p);
rv = mkWhilex(nthEL(el, 0), nthEL(el, 1));
/* [[RBR else LBR]] possibly parse expressions that are in \uschemeplus 723e */
/* nothing happens */
} else {
/* parseexp application and put the result in [[rv]] 724d */
rv = mkApply(parseexp(pl->hd), el);
}
}
return rv;
}
default:
assert(0);
return NULL;
}
}
/*
* <parse.c>=
*/
static Exp parseexp(Par p) {
switch (p->alt) {
case ATOM:
/*
* If we have a name, it must be either a literal value
* or a variable.
* <parseexp [[atom]] and return the result>=
*/
{
const char *s = nametostr(p->u.atom);
char *t;
long l = strtol(s, &t, 10);
if (*t == '\0') /* the number is the whole string */
return mkLiteral(l);
else
return mkVar(p->u.atom);
}
case LIST:
/*
* If we have a list, we need to look at the first
* element, which must be a name.
* <parseexp [[list]] and return the result>=
*/
{
Parlist pl;
Name first;
Explist argl;
pl = p->u.list;
if (pl == NULL)
error("%p: empty list in input", p);
if (pl->hd->alt != ATOM)
error("%p: first item of list not name", p);
first = pl->hd->u.atom;
argl = parselist(pl->tl);
if (first == strtoname("begin")) {
/*
* A [[begin]] expression can have any number of
* parameters.
* <parseexp [[begin]] and return the result>=
*/
return mkBegin(argl);
} else if (first == strtoname("if")) {
/*
* An [[if]] expression needs three parameters.
* <parseexp [[if]] and return the result>=
*/
if (lengthEL(argl) != 3)
error("%p: usage: (if cond true false)", p);
return mkIfx(nthEL(argl, 0), nthEL(argl, 1), nthEL(argl, 2));
} else if (first == strtoname("set")) {
/*
* A [[set]] expression requires a variable and a value.
* <parseexp [[set]] and return the result>=
*/
if (lengthEL(argl) != 2)
error("%p: usage: (set var exp)", p);
if (nthEL(argl, 0)->alt != VAR)
error("%p: set needs variable as first param", p);
return mkSet(nthEL(argl, 0)->u.var, nthEL(argl, 1));
} else if (first == strtoname("while")) {
/*
* A [[while]] loop needs two.
* <parseexp [[while]] and return the result>=
*/
if (lengthEL(argl) != 2)
error("%p: usage: (while cond body)", p);
return mkWhilex(nthEL(argl, 0), nthEL(argl, 1));
} else {
/*
* Anything else must be a function application. We
* can't check the number of parameters here, because
* the function definition might change before
* evaluation, or might not be present yet (as occurs,
* for example, when defining recursive functions).
* <parseexp function application and return the result>=
*/
return mkApply(first, argl);
}
}
default:
assert(0);
return NULL;
}
}
int main(int argc, char *argv[]) {
Env env = NULL;
int doprompt = (argc <= 1) || (strcmp(argv[1], "-q") != 0);
initvalue();
initallocate();
/*
* We have many printers.
* <install printers>=
*/
installprinter('c', printclosure);
installprinter('d', printdecimal);
installprinter('e', printexp);
installprinter('E', printexplist);
installprinter('\\', printlambda);
installprinter('n', printname);
installprinter('N', printnamelist);
installprinter('p', printpar);
installprinter('P', printparlist);
installprinter('r', printenv);
installprinter('s', printstring);
installprinter('t', printdef);
installprinter('v', printvalue);
installprinter('V', printvaluelist);
installprinter('%', printpercent);
/*
* <install printers>=
*/
installprinter('S', printstack);
installprinter('F', printoneframe);
installprinter('R', printnoenv);
roots.globals = &env;
roots.stack = emptystack();
addprimitives(&env);
/*
* Standard input should be read after the initial
* basis, but because reading is done on a stack, we
* push it on before the basis.
* <initialize [[roots.sources]] to read first the initial basis, then
[[stdin]]>=
*/
roots.sources =
mkSL(mkSource(xdefreader(filereader("standard input", stdin), doprompt),
stdin, ECHOING),
NULL);
{ /*
* <C representation of initial basis for {\uscheme}>=
*/
const char *basis=
"(define caar (xs) (car (car xs)))\n"
"(define cadr (xs) (car (cdr xs)))\n"
"(define cdar (xs) (cdr (car xs)))\n"
"(define list1 (x) (cons x '()))\n"
"(define list2 (x y) (cons x (list1 y)))\n"
"(define list3 (x y z) (cons x (list2 y z)))\n"
"(define length (xs)\n"
" (if (null? xs) 0\n"
" (+ 1 (length (cdr xs)))))\n"
"(define and (b c) (if b c b))\n"
"(define or (b c) (if b b c))\n"
"(define not (b) (if b #f #t))\n"
"(define atom? (x) (or (number? x) (or (symbol? x) (or (boolean? x) (null? x)))))\n"
"(define equal? (s1 s2)\n"
" (if (or (atom? s1) (atom? s2))\n"
" (= s1 s2)\n"
" (and (equal? (car s1) (car s2)) (equal? (cdr s1) (cdr s2)))))\n"
"(define append (xs ys)\n"
" (if (null? xs)\n"
" ys\n"
" (cons (car xs) (append (cdr xs) ys))))\n"
"(define revapp (xs ys)\n"
" (if (null? xs)\n"
" ys\n"
" (revapp (cdr xs) (cons (car xs) ys))))\n"
"(define reverse (xs) (revapp xs '()))\n"
"(define mk-alist-pair (k a) (list2 k a))\n"
"(define alist-pair-key (pair) (car pair))\n"
"(define alist-pair-attribute (pair) (cadr pair))\n"
"(define alist-first-key (alist) (alist-pair-key (car alist)))\n"
"(define alist-first-attribute (alist) (alist-pair-attribute (car alist)))\n"
"(define bind (k a alist)\n"
" (if (null? alist)\n"
" (list1 (mk-alist-pair k a))\n"
" (if (equal? k (alist-first-key alist))\n"
" (cons (mk-alist-pair k a) (cdr alist))\n"
" (cons (car alist) (bind k a (cdr alist))))))\n"
"(define find (k alist)\n"
" (if (null? alist) '()\n"
" (if (equal? k (alist-first-key alist))\n"
" (alist-first-attribute alist)\n"
" (find k (cdr alist)))))\n"
"(define o (f g) (lambda (x) (f (g x))))\n"
"(define curry (f) (lambda (x) (lambda (y) (f x y))))\n"
"(define uncurry (f) (lambda (x y) ((f x) y)))\n"
"(define filter (p? xs)\n"
" (if (null? xs)\n"
" '()\n"
" (if (p? (car xs))\n"
" (cons (car xs) (filter p? (cdr xs)))\n"
" (filter p? (cdr xs)))))\n"
"(define map (f xs)\n"
" (if (null? xs)\n"
" '()\n"
" (cons (f (car xs)) (map f (cdr xs)))))\n"
"(define exists? (p? xs)\n"
" (if (null? xs)\n"
" #f\n"
" (if (p? (car xs)) \n"
" #t\n"
" (exists? p? (cdr xs)))))\n"
"(define all? (p? xs)\n"
" (if (null? xs)\n"
" #t\n"
" (if (p? (car xs))\n"
" (all? p? (cdr xs))\n"
" #f)))\n"
"(define foldr (op zero xs)\n"
" (if (null? xs)\n"
" zero\n"
" (op (car xs) (foldr op zero (cdr xs)))))\n"
"(define foldl (op zero xs)\n"
" (if (null? xs)\n"
" zero\n"
" (foldl op (op (car xs) zero) (cdr xs))))\n"
"(define <= (x y) (not (> x y)))\n"
"(define >= (x y) (not (< x y)))\n"
"(define != (x y) (not (= x y)))\n"
"(define max (x y) (if (> x y) x y))\n"
"(define min (x y) (if (< x y) x y))\n"
"(define mod (m n) (- m (* n (/ m n))))\n"
"(define gcd (m n) (if (= n 0) m (gcd n (mod m n))))\n"
"(define lcm (m n) (if (= m 0) 0 (* m (/ n (gcd m n)))))\n"
"(define caar (sx) (car (car sx)))\n"
"(define cdar (sx) (cdr (car sx)))\n"
"(define cadr (sx) (car (cdr sx)))\n"
"(define cddr (sx) (cdr (cdr sx)))\n"
"(define caaar (sx) (car (caar sx)))\n"
"(define cdaar (sx) (cdr (caar sx)))\n"
"(define caadr (sx) (car (cadr sx)))\n"
"(define cdadr (sx) (cdr (cadr sx)))\n"
"(define cadar (sx) (car (cdar sx)))\n"
"(define cddar (sx) (cdr (cdar sx)))\n"
"(define caddr (sx) (car (cddr sx)))\n"
"(define cdddr (sx) (cdr (cddr sx)))\n"
"(define list1 (x) (cons x '()))\n"
"(define list2 (x y) (cons x (list1 y)))\n"
"(define list3 (x y z) (cons x (list2 y z)))\n"
"(define list4 (x y z a) (cons x (list3 y z a)))\n"
"(define list5 (x y z a b) (cons x (list4 y z a b)))\n"
"(define list6 (x y z a b c) (cons x (list5 y z a b c)))\n"
"(define list7 (x y z a b c d) (cons x (list6 y z a b c d)))\n"
"(define list8 (x y z a b c d e) (cons x (list7 y z a b c d e)))\n";
roots.sources =
mkSL(mkSource(xdefreader(stringreader("initial basis", basis), 0),
NULL, SILENT),
roots.sources);
}
/*
* The loop looks a bit like the body of the old
* [[readevalprint]]. This version is more resilient to
* errors that occur when a file is read.
* <read definitions until [[roots.sources]] is exhausted>=
*/
while (roots.sources != NULL) {
XDef d;
Source *cursource = &roots.sources->hd;
Source newsource; /* initialized when we hit USE */
while (setjmp(errorjmp))
;
d = readxdef(cursource->xdefs);
if (d == NULL) {
if (cursource->sourcefile != NULL)
fclose(cursource->sourcefile);
/*
* <using error mode [[TESTING]], run unit tests from
[[cursource->tests]], last test first>=
*/
set_error_mode(TESTING);
{ int npassed = tests_passed(cursource->tests, *roots.globals);
int ntests = lengthUL(cursource->tests);
report_test_results(npassed, ntests);
}
set_error_mode(NORMAL);
roots.sources = popSL(roots.sources);
} else switch (d->alt) {
case USE:
/*
* File [[fin]] is closed above, after [[readxdef
* (cursource->xdefs)]] returns [[NULL]].
* <set [[newsource]] to a definition reader for [[d->u.use]]>=
*/
{
const char *filename = nametostr(d->u.use);
FILE *fin = fopen(filename, "r");
if (fin == NULL)
error("cannot open file \"%s\"", filename);
newsource = mkSource(xdefreader(filereader(filename, fin), 0
), fin, ECHOING);
}
roots.sources = mkSL(newsource, roots.sources);
break;
case TEST:
cursource->tests = mkUL(d->u.test, cursource->tests);
break;
case DEF:
env = evaldef(d->u.def, env, cursource->echo);
break;
default:
assert(0);
}
}
return 0;
}
