femtolisp/tiny/eval1

value_t eval_sexpr(value_t e, value_t *penv)
{
    value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
    value_t *rest;
    cons_t *c;
    symbol_t *sym;
    u_int32_t saveSP;
    int i, nargs, noeval=0;
    number_t s, n;

    if (issymbol(e)) {
        sym = (symbol_t*)ptr(e);
        if (sym->constant != UNBOUND) return sym->constant;
        v = *penv;
        while (iscons(v)) {
            bind = car_(v);
            if (iscons(bind) && car_(bind) == e)
                return cdr_(bind);
            v = cdr_(v);
        }
        if ((v = sym->binding) == UNBOUND)
            lerror("eval: error: variable %s has no value\n", sym->name);
        return v;
    }
    if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
        lerror("eval: error: stack overflow\n");
    saveSP = SP;
    PUSH(e);
    f = eval(car_(e), penv);
    if (isbuiltin(f)) {
        // handle builtin function
        if (!isspecial(f)) {
            // evaluate argument list, placing arguments on stack
            v = Stack[saveSP] = cdr_(Stack[saveSP]);
            while (iscons(v)) {
                v = eval(car_(v), penv);
                PUSH(v);
                v = Stack[saveSP] = cdr_(Stack[saveSP]);
            }
        }
    apply_builtin:
        nargs = SP - saveSP - 1;
        switch (intval(f)) {
        // special forms
        case F_QUOTE:
            v = cdr_(Stack[saveSP]);
            if (!iscons(v))
                lerror("quote: error: expected argument\n");
            v = car_(v);
            break;
        case F_MACRO:
        case F_LAMBDA:
            v = Stack[saveSP];
            if (*penv != NIL) {
                // build a closure (lambda args body . env)
                v = cdr_(v);
                PUSH(car(v));
                argsyms = &Stack[SP-1];
                PUSH(car(cdr_(v)));
                body = &Stack[SP-1];
                v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
                          cons(argsyms, cons(body, penv)));
            }
            break;
        case F_LABEL:
            v = Stack[saveSP];
            if (*penv != NIL) {
                v = cdr_(v);
                PUSH(car(v));        // name
                pv = &Stack[SP-1];
                PUSH(car(cdr_(v)));  // function
                body = &Stack[SP-1];
                *body = eval(*body, penv);  // evaluate lambda
                v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
            }
            break;
        case F_IF:
            v = car(cdr_(Stack[saveSP]));
            if (eval(v, penv) != NIL)
                v = car(cdr_(cdr_(Stack[saveSP])));
            else
                v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
            v = eval(v, penv);
            break;
        case F_COND:
            Stack[saveSP] = cdr_(Stack[saveSP]);
            pv = &Stack[saveSP]; v = NIL;
            while (iscons(*pv)) {
                c = tocons(car_(*pv), "cond");
                if ((v=eval(c->car, penv)) != NIL) {
                    *pv = cdr_(car_(*pv));
                    // evaluate body forms
                    while (iscons(*pv)) {
                        v = eval(car_(*pv), penv);
                        *pv = cdr_(*pv);
                    }
                    break;
                }
                *pv = cdr_(*pv);
            }
            break;
        case F_AND:
            Stack[saveSP] = cdr_(Stack[saveSP]);
            pv = &Stack[saveSP]; v = T;
            while (iscons(*pv)) {
                if ((v=eval(car_(*pv), penv)) == NIL)
                    break;
                *pv = cdr_(*pv);
            }
            break;
        case F_OR:
            Stack[saveSP] = cdr_(Stack[saveSP]);
            pv = &Stack[saveSP]; v = NIL;
            while (iscons(*pv)) {
                if ((v=eval(car_(*pv), penv)) != NIL)
                    break;
                *pv = cdr_(*pv);
            }
            break;
        case F_WHILE:
            PUSH(car(cdr(cdr_(Stack[saveSP]))));
            body = &Stack[SP-1];
            Stack[saveSP] = car_(cdr_(Stack[saveSP]));
            value_t *cond = &Stack[saveSP];
            PUSH(NIL); pv = &Stack[SP-1];
            while (eval(*cond, penv) != NIL)
                *pv = eval(*body, penv);
            v = *pv;
            break;
        case F_PROGN:
            // return last arg
            Stack[saveSP] = cdr_(Stack[saveSP]);
            pv = &Stack[saveSP]; v = NIL;
            while (iscons(*pv)) {
                v = eval(car_(*pv), penv);
                *pv = cdr_(*pv);
            }
            break;

        // ordinary functions
        case F_SET:
            argcount("set", nargs, 2);
            e = Stack[SP-2];
            v = *penv;
            while (iscons(v)) {
                bind = car_(v);
                if (iscons(bind) && car_(bind) == e) {
                    cdr_(bind) = (v=Stack[SP-1]);
                    SP=saveSP; return v;
                }
                v = cdr_(v);
            }
            tosymbol(e, "set")->binding = (v=Stack[SP-1]);
            break;
        case F_BOUNDP:
            argcount("boundp", nargs, 1);
            if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
                v = NIL;
            else
                v = T;
            break;
        case F_EQ:
            argcount("eq", nargs, 2);
            v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
            break;
        case F_CONS:
            argcount("cons", nargs, 2);
            v = mk_cons();