Esempio n. 1
0
/* 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;
    }
}
/* evaldef.c 147e */
Env evaldef(Def d, Env env, Echo echo) {
    switch (d->alt) {
    case VAL:
        /* evaluate [[val]] binding and return new environment 148a */
        {
            Value v;

            if (find(d->u.val.name, env) == NULL)
                env = bindalloc(d->u.val.name, unspecified(), env);
            v = eval(d->u.val.exp, env);
            *find(d->u.val.name, env) = v;
            if (echo == ECHOING) {
                if (d->u.val.exp->alt == LAMBDAX)
                    print("%n\n", d->u.val.name);
                else
                    print("%v\n", v);
            }
            return env;
        }
    case EXP:

/* evaluate expression, store the result in [[it]], and return new environment 148b */
        {
            Value v = eval(d->u.exp, env);
            Value *itloc = find(strtoname("it"), env);
            if (echo == ECHOING)
                print("%v\n", v);
            if (itloc == NULL) {
                return bindalloc(strtoname("it"), v, env);
            } else {
                *itloc = v;
                return env;
            }
        }
    case DEFINE:
        /* evaluate function definition and return new environment 148c */

/* if [[d->u.define.lambda.formals]] contains a duplicate, call [[error]] 715d */
        if (duplicatename(d->u.define.lambda.formals) != NULL)
            error(
               "formal parameter %n appears twice in definition of function %n",
                  duplicatename(d->u.define.lambda.formals), d->u.define.name);
        return evaldef(mkVal(d->u.define.name, mkLambdax(d->u.define.lambda)),
                       env, echo);
    }
    assert(0);
    return NULL;
}
/*
 * Access to the desired size of the heap
 * 
 * To control the size of the heap, we might want to use
 * the micro-Scheme variable [[ --- gamma-desired]], as
 * described in Exercises [->] and [->]. This routine
 * gets the value of that variable. [*]
 * <loc.c>=
 */
int gammadesired(int defaultval, int minimum) {
    Value *gloc;

    assert(roots.globals != NULL);
    gloc = find(strtoname("&gamma-desired"), *roots.globals);
    if (gloc && gloc->alt == NUM)
        return gloc->u.num > minimum ? gloc->u.num : minimum;
    else
        return defaultval;
}
Esempio n. 4
0
/*
 * Other supporting code
 * 
 * To control the size of the heap, we might want to use
 * the micro-Scheme variable [[ --- gamma-desired]], as
 * described in Exercises [->] and [->]. This routine
 * gets the value of that variable. [*]
 * <loc.c>=
 */
int gammadesired(int defaultval, int minimum) {
    Value *gloc;

    assert(rootstacksize > 0 && rootstack[0].alt == ENVROOT);
    gloc = find(strtoname("&gamma-desired"), *rootstack[0].u.envroot);
    if (gloc && gloc->alt == NUM)
        return gloc->u.num > minimum ? gloc->u.num : minimum;
    else
        return defaultval;
}
int main(int argc, char *argv[]) {
    Funenv functions = mkFunenv(NULL, NULL);
    Valenv globals   = mkValenv(NULL, NULL);
    int doprompt = (argc <= 1) || (strcmp(argv[1], "-q") != 0);
    Prompts prompts = doprompt ? STD_PROMPTS : NO_PROMPTS;
    XDefreader input = xdefreader(filereader("standard input", stdin), prompts);
    /* install conversion specifications in print module 50c */
    installprinter('d', printdecimal);
    installprinter('e', printexp);
    installprinter('E', printexplist);
    installprinter('f', printfun);
    installprinter('n', printname);
    installprinter('N', printnamelist);
    installprinter('p', printpar);
    installprinter('P', printparlist);
    installprinter('s', printstring);
    installprinter('t', printdef);
    installprinter('v', printvalue);
    installprinter('V', printvaluelist);
    /* install the initial basis in [[functions]] 51a */
    {
        static char *prims[] = { "+", "-", "*", "/", "<", ">", "=", "print", 0 }
                                                                               ;
        char **p;
        for (p=prims; *p; p++) {
            Name n = strtoname(*p);
            bindfun(n, mkPrimitive(n), functions);
        }
    }
    /* install the initial basis in [[functions]] 51c */
    {

  /* C representation of initial basis for {\impcore} (generated by a script) */
      /*Adding empty local evironment to the functions in the initial basis => "()" */
        const char *basis=
          "(define and (b c) () (if b c b))\n"
          "(define or  (b c) () (if b b c))\n"
          "(define not (b)   () (if b 0 1))\n"
          "(define <= (x y) () (not (> x y)))\n"
          "(define >= (x y) () (not (< x y)))\n"
          "(define != (x y) () (not (= x y)))\n"
          "(define mod (m n) () (- m (* n (/ m n))))\n";
        if (setjmp(errorjmp))
            assert(0); /* fail if error in basis */
        readevalprint(xdefreader(stringreader("initial basis", basis),
                                                                    NO_PROMPTS),
                      globals, functions, SILENT);
    }
    while (setjmp(errorjmp))
        ;
    readevalprint(input, globals, functions, ECHOING);
    return 0;
}
/* 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 718b */
XDef parse(Par p) {
    switch (p->alt) {
    case ATOM:
        /* parse ATOM and return 718c */
        return mkDef(mkExp(parseexp(p)));
    case LIST:
        /* parse LIST and return 718d */
        {
            Parlist pl = p->u.list;

            if (pl == NULL)
                error("%p: empty list", p);
            if (nthPL(pl, 0)->alt == ATOM) {
                Name first = nthPL(pl, 0)->u.atom;
                if (first == strtoname("define")) {
                    /* parse define and return 719a */
                    Name name;
                    Lambda l;

                    if (lengthPL(pl) != 4 || nthPL(pl, 1)->alt != ATOM || nthPL(
                                                            pl, 2)->alt != LIST)
                        error("%p: usage: (define fun (args) body)", p);

                    name      = nthPL(pl, 1)->u.atom;
                    l.formals = getnamelist(p, nthPL(pl, 2)->u.list);
                    l.body    = parseexp(nthPL(pl, 3));
                    return      mkDef(mkDefine(name, l));
                }
                if (first == strtoname("val")) {
                    /* parse val and return 719b */
                    Exp var, exp;

                    if (lengthPL(pl) != 3)
                        error("%p: usage: (val var exp)", p);

                    var = parseexp(nthPL(pl, 1));
                    if (var->alt != VAR)
                        error("%p: usage: (val var exp) (bad variable)", p);

                    exp = parseexp(nthPL(pl, 2));
                    return mkDef(mkVal(var->u.var, exp));
                }
                if (first == strtoname("use")) {
                    /* parse use and return 719c */
                    if (lengthPL(pl) != 2 || nthPL(pl, 1)->alt != ATOM)
                        error("%p: usage: (use filename)", p);

                    return mkUse(nthPL(pl, 1)->u.atom);
                }
                if (first == strtoname("check-expect")) {
                    /* parse check-expect and return 719d */
                    {
                    Exp check, expect;

                    if (lengthPL(pl) != 3)
                        error("%p: usage: (check-expect exp exp)", p);

                    check  = parseexp(nthPL(pl, 1));
                    expect = parseexp(nthPL(pl, 2));
                    return mkTest(mkCheckExpect(check, expect));
                    }
                }
                if (first == strtoname("check-error")) {
                    /* parse check-error and return 719e */
                    {
                    Exp check;

                    if (lengthPL(pl) != 2)
                        error("%p: usage: (check-error exp)", p);

                    check  = parseexp(nthPL(pl, 1));
                    return mkTest(mkCheckError(check));
                    }
                }
            }

            return mkDef(mkExp(parseexp(p)));
        }
    }
    assert(0);
    return NULL;
}
/* 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;
    }
}
Esempio n. 9
0
/*
 * The parser needs to take concrete syntax, check to
 * see that it is well formed, and produce abstract
 * syntax. It provides the [[readtop]] function.
 * 
 * At the top level, parsing amounts to looking for top
 * level constructs and passing the rest of the work to
 * [[parseexp]], which parses the input into [[Exp]]s.
 * <parse.c>=
 */
static Def parse(Par p) {
    switch (p->alt) {
    case ATOM:
        /*
         * If we have a name, we treat it as an expression.
         * <parse [[atom]] and return the result>=
         */
        return mkExp(parseexp(p));
    case LIST:
        /*
         * If we have a list, we need to look for [[define]],
         * [[val]], and [[use]].
         * <parse [[list]] and return the result>=
         */
        {
            Name first;
            Parlist pl = p->u.list;
            if (pl == NULL)
                error("%p: empty list", p);
            if (nthPL(pl, 0)->alt != ATOM)
                error("%p: first item of list not name", p);

            first = nthPL(pl, 0)->u.atom;
            if (first == strtoname("define")) {
                /*
                 * Parsing the top-level expressions requires checking
                 * the argument counts and then parsing the subpieces.
                 * For function definitions, we could check that formal
                 * parameters have distinct names, but that check is
                 * part of the operational semantics for function
                 * definition.
                 * <parse [[define]] and return the result>=
                 */
                if (lengthPL(pl) != 4 || nthPL(pl, 1)->alt != ATOM || nthPL(pl,
                                                                2)->alt != LIST)
                    error("%p: usage: (define fun (formals) body)", p);

                {
                  Name     name    = nthPL(pl, 1)->u.atom;
                  Namelist formals = getnamelist(name, p, nthPL(pl, 2)->u.list);
                  Exp      body    = parseexp(nthPL(pl, 3));
                  return mkDefine(name, mkUserfun(formals, body));
                }
            }
            if (first == strtoname("val")) {
                /*
                 * <parse [[val]] and return the result>=
                 */
                Exp var, exp;

                if (lengthPL(pl) != 3)
                    error("%p: usage: (val var exp)", p);

                var = parseexp(nthPL(pl, 1));
                if (var->alt != VAR)
                    error("%p: usage: (val var exp) (bad variable)", p);

                exp = parseexp(nthPL(pl, 2));
                return mkVal(var->u.var, exp);
            }
            if (first == strtoname("use")) {
                /*
                 * <parse [[use]] and return the result>=
                 */
                if (lengthPL(pl) != 2 || nthPL(pl, 1)->alt != ATOM)
                    error("%p: usage: (use filename)", p);

                return mkUse(nthPL(pl, 1)->u.atom);
            }
            return mkExp(parseexp(p));
        }
    }
    assert(0);
    return NULL;
}
Esempio n. 10
0
/*
 * <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;
    }
}
/* parse.c 694a */
static XDef parse(Par p) {
    switch (p->alt) {
    case ATOM:
        /* parse [[atom]] and return the result 694b */
        return mkDef(mkExp(parseexp(p)));
    case LIST:
        /* parse [[list]] and return the result 694c */
        {
            Name first;
            Parlist pl = p->u.list;
            if (pl == NULL)
                error("%p: empty list", p);
            if (nthPL(pl, 0)->alt != ATOM)
                error("%p: first item of list not name", p);

            first = nthPL(pl, 0)->u.atom;
             if (first == strtoname("define")) {
                 /* parse [[define]] and return the result */
                 if (lengthPL(pl) != 5 || nthPL(pl, 1)->alt != ATOM || 
                     nthPL(pl, 2)->alt != LIST || nthPL(pl, 3)->alt != LIST)
                     error("%p: usage: (define fun (formals) (locals) body)", p);
               {
                 Name     name    = nthPL(pl, 1)->u.atom;
                 Namelist formals = getnamelist(name, p, nthPL(pl, 2)->u.list);
                 Namelist locals  = getnamelist(name, p, nthPL(pl, 3)->u.list);
                 Exp      body    = parseexp(nthPL(pl, 4));
                 return   mkDef(mkDefine(name, mkUserfun(formals, locals, body)));
               }
             }

            if (first == strtoname("val")) {
                /* parse [[val]] and return the result 695c */
                Exp var, exp;

                if (lengthPL(pl) != 3)
                    error("%p: usage: (val var exp)", p);

                var = parseexp(nthPL(pl, 1));
                if (var->alt != VAR)
                    error("%p: usage: (val var exp) (bad variable)", p);

                exp = parseexp(nthPL(pl, 2));
                return mkDef(mkVal(var->u.var, exp));
            }
            if (first == strtoname("use")) {
                /* parse [[use]] and return the result 695d */
                if (lengthPL(pl) != 2 || nthPL(pl, 1)->alt != ATOM)
                    error("%p: usage: (use filename)", p);

                return mkUse(nthPL(pl, 1)->u.atom);
            }
            if (first == strtoname("check-expect")) {
                /* parse [[check-expect]] and return the result 695e */
                Exp check, expect;

                if (lengthPL(pl) != 3)
                    error("%p: usage: (check-expect exp exp)", p);

                check  = parseexp(nthPL(pl, 1));
                expect = parseexp(nthPL(pl, 2));
                return mkTest(mkCheckExpect(check, expect));
            }
            if (first == strtoname("check-error")) {
                /* parse [[check-error]] and return the result 696a */
                Exp check;

                if (lengthPL(pl) != 2)
                    error("%p: usage: (check-error exp)", p);

                check  = parseexp(nthPL(pl, 1));
                return mkTest(mkCheckError(check));
            }
            return mkDef(mkExp(parseexp(p)));
        }
    }
    assert(0);
    return NULL;
}
/*
 * <evaldef.c>=
 */
Env evaldef(Def d, Env env, Echo echo) {
    switch (d->alt) {
    case VAL:
        /*
         * According to the operational semantics, the
         * right-hand side of a [[val]] binding must be
         * evaluated in an environment in which the name [[d->
         * u.val.name]] is bound. If the binding is not already
         * present, we bind the name to an unspecified value.
         * <evaluate [[val]] binding and return new environment>=
         */
        {
            Value v;

            if (find(d->u.val.name, env) == NULL)
                env = bindalloc(d->u.val.name, unspecified(), env);
            v = eval(d->u.val.exp, env);
            *find(d->u.val.name, env) = v;
            if (echo == ECHOING) {
                if (d->u.val.exp->alt == LAMBDAX)
                    print("%n\n", d->u.val.name);
                else
                    print("%v\n", v);
            }
            return env;
        }
    case EXP:
        /*
         * As in Impcore, evaluating a top-level expression has
         * the same effect on the environment as evaluating a
         * definition of [[it]], except that the interpreter
         * always prints the value, never the name ``it.''
         * <evaluate expression, store the result in [[it]], and return new
                                                                   environment>=
         */
        {
            Value v = eval(d->u.exp, env);
            Value *itloc = find(strtoname("it"), env);
            if (echo == ECHOING)
                print("%v\n", v);
            if (itloc == NULL) {
                return bindalloc(strtoname("it"), v, env);
            } else {
                *itloc = v;
                return env;
            }
        }
    case DEFINE:
        /*
         * We rewrite \xdefine to \xval.
         * <evaluate function definition and return new environment>=
         */
        /*
         * <if [[d->u.define.lambda.formals]] contains a duplicate, call
                                                                     [[error]]>=
         */
        if (duplicatename(d->u.define.lambda.formals) != NULL)
            error(
               "formal parameter %n appears twice in definition of function %n",
                  duplicatename(d->u.define.lambda.formals), d->u.define.name);
        return evaldef(mkVal(d->u.define.name, mkLambdax(d->u.define.lambda)),
                       env, echo);
    }
    assert(0);
    return NULL;
}