408 lines
13 KiB
Plaintext
408 lines
13 KiB
Plaintext
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();
|
|
car_(v) = Stack[SP-2];
|
|
cdr_(v) = Stack[SP-1];
|
|
break;
|
|
case F_CAR:
|
|
argcount("car", nargs, 1);
|
|
v = car(Stack[SP-1]);
|
|
break;
|
|
case F_CDR:
|
|
argcount("cdr", nargs, 1);
|
|
v = cdr(Stack[SP-1]);
|
|
break;
|
|
case F_RPLACA:
|
|
argcount("rplaca", nargs, 2);
|
|
car(v=Stack[SP-2]) = Stack[SP-1];
|
|
break;
|
|
case F_RPLACD:
|
|
argcount("rplacd", nargs, 2);
|
|
cdr(v=Stack[SP-2]) = Stack[SP-1];
|
|
break;
|
|
case F_ATOM:
|
|
argcount("atom", nargs, 1);
|
|
v = ((!iscons(Stack[SP-1])) ? T : NIL);
|
|
break;
|
|
case F_CONSP:
|
|
argcount("consp", nargs, 1);
|
|
v = (iscons(Stack[SP-1]) ? T : NIL);
|
|
break;
|
|
case F_SYMBOLP:
|
|
argcount("symbolp", nargs, 1);
|
|
v = ((issymbol(Stack[SP-1])) ? T : NIL);
|
|
break;
|
|
case F_NUMBERP:
|
|
argcount("numberp", nargs, 1);
|
|
v = ((isnumber(Stack[SP-1])) ? T : NIL);
|
|
break;
|
|
case F_ADD:
|
|
s = 0;
|
|
for (i=saveSP+1; i < (int)SP; i++) {
|
|
n = tonumber(Stack[i], "+");
|
|
s += n;
|
|
}
|
|
v = number(s);
|
|
break;
|
|
case F_SUB:
|
|
if (nargs < 1)
|
|
lerror("-: error: too few arguments\n");
|
|
i = saveSP+1;
|
|
s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
|
|
for (; i < (int)SP; i++) {
|
|
n = tonumber(Stack[i], "-");
|
|
s -= n;
|
|
}
|
|
v = number(s);
|
|
break;
|
|
case F_MUL:
|
|
s = 1;
|
|
for (i=saveSP+1; i < (int)SP; i++) {
|
|
n = tonumber(Stack[i], "*");
|
|
s *= n;
|
|
}
|
|
v = number(s);
|
|
break;
|
|
case F_DIV:
|
|
if (nargs < 1)
|
|
lerror("/: error: too few arguments\n");
|
|
i = saveSP+1;
|
|
s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
|
|
for (; i < (int)SP; i++) {
|
|
n = tonumber(Stack[i], "/");
|
|
if (n == 0)
|
|
lerror("/: error: division by zero\n");
|
|
s /= n;
|
|
}
|
|
v = number(s);
|
|
break;
|
|
case F_LT:
|
|
argcount("<", nargs, 2);
|
|
if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
|
|
v = T;
|
|
else
|
|
v = NIL;
|
|
break;
|
|
case F_NOT:
|
|
argcount("not", nargs, 1);
|
|
v = ((Stack[SP-1] == NIL) ? T : NIL);
|
|
break;
|
|
case F_EVAL:
|
|
argcount("eval", nargs, 1);
|
|
v = eval(Stack[SP-1], &NIL);
|
|
break;
|
|
case F_PRINT:
|
|
for (i=saveSP+1; i < (int)SP; i++)
|
|
print(stdout, v=Stack[i], 0);
|
|
fprintf(stdout, "\n");
|
|
break;
|
|
case F_PRINC:
|
|
for (i=saveSP+1; i < (int)SP; i++)
|
|
print(stdout, v=Stack[i], 1);
|
|
break;
|
|
case F_READ:
|
|
argcount("read", nargs, 0);
|
|
v = read_sexpr(stdin);
|
|
break;
|
|
case F_LOAD:
|
|
argcount("load", nargs, 1);
|
|
v = load_file(tosymbol(Stack[SP-1], "load")->name);
|
|
break;
|
|
case F_EXIT:
|
|
exit(0);
|
|
break;
|
|
case F_ERROR:
|
|
for (i=saveSP+1; i < (int)SP; i++)
|
|
print(stderr, Stack[i], 1);
|
|
lerror("\n");
|
|
break;
|
|
case F_PROG1:
|
|
// return first arg
|
|
if (nargs < 1)
|
|
lerror("prog1: error: too few arguments\n");
|
|
v = Stack[saveSP+1];
|
|
break;
|
|
case F_APPLY:
|
|
// unpack a list onto the stack
|
|
argcount("apply", nargs, 2);
|
|
v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
|
|
f = Stack[SP-2]; // first arg is new function
|
|
POPN(2); // pop apply's args
|
|
if (isbuiltin(f)) {
|
|
if (isspecial(f))
|
|
lerror("apply: error: cannot apply special operator "
|
|
"%s\n", builtin_names[intval(f)]);
|
|
while (iscons(v)) {
|
|
PUSH(car_(v));
|
|
v = cdr_(v);
|
|
}
|
|
goto apply_builtin;
|
|
}
|
|
noeval = 1;
|
|
goto apply_lambda;
|
|
}
|
|
SP = saveSP;
|
|
return v;
|
|
}
|
|
else {
|
|
v = Stack[saveSP] = cdr_(Stack[saveSP]);
|
|
}
|
|
apply_lambda:
|
|
if (iscons(f)) {
|
|
headsym = car_(f);
|
|
if (headsym == LABEL) {
|
|
// (label name (lambda ...)) behaves the same as the lambda
|
|
// alone, except with name bound to the whole label expression
|
|
labl = f;
|
|
f = car(cdr(cdr_(labl)));
|
|
headsym = car(f);
|
|
}
|
|
// apply lambda or macro expression
|
|
PUSH(cdr(cdr(cdr_(f))));
|
|
lenv = &Stack[SP-1];
|
|
PUSH(car_(cdr_(f)));
|
|
argsyms = &Stack[SP-1];
|
|
PUSH(car_(cdr_(cdr_(f))));
|
|
body = &Stack[SP-1];
|
|
if (labl) {
|
|
// add label binding to environment
|
|
PUSH(labl);
|
|
PUSH(car_(cdr_(labl)));
|
|
*lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
|
|
POPN(3);
|
|
v = Stack[saveSP]; // refetch arglist
|
|
}
|
|
if (headsym == MACRO)
|
|
noeval = 1;
|
|
else if (headsym != LAMBDA)
|
|
lerror("apply: error: head must be lambda, macro, or label\n");
|
|
// build a calling environment for the lambda
|
|
// the environment is the argument binds on top of the captured
|
|
// environment
|
|
while (iscons(v)) {
|
|
// bind args
|
|
if (!iscons(*argsyms)) {
|
|
if (*argsyms == NIL)
|
|
lerror("apply: error: too many arguments\n");
|
|
break;
|
|
}
|
|
asym = car_(*argsyms);
|
|
if (!issymbol(asym))
|
|
lerror("apply: error: formal argument not a symbol\n");
|
|
v = car_(v);
|
|
if (!noeval) v = eval(v, penv);
|
|
PUSH(v);
|
|
*lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
|
|
POPN(2);
|
|
*argsyms = cdr_(*argsyms);
|
|
v = Stack[saveSP] = cdr_(Stack[saveSP]);
|
|
}
|
|
if (*argsyms != NIL) {
|
|
if (issymbol(*argsyms)) {
|
|
if (noeval) {
|
|
*lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
|
|
}
|
|
else {
|
|
PUSH(NIL);
|
|
PUSH(NIL);
|
|
rest = &Stack[SP-1];
|
|
// build list of rest arguments
|
|
// we have to build it forwards, which is tricky
|
|
while (iscons(v)) {
|
|
v = eval(car_(v), penv);
|
|
PUSH(v);
|
|
v = cons_(&Stack[SP-1], &NIL);
|
|
POP();
|
|
if (iscons(*rest))
|
|
cdr_(*rest) = v;
|
|
else
|
|
Stack[SP-2] = v;
|
|
*rest = v;
|
|
v = Stack[saveSP] = cdr_(Stack[saveSP]);
|
|
}
|
|
*lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
|
|
}
|
|
}
|
|
else if (iscons(*argsyms)) {
|
|
lerror("apply: error: too few arguments\n");
|
|
}
|
|
}
|
|
SP = saveSP; // free temporary stack space
|
|
PUSH(*lenv); // preserve environment on stack
|
|
lenv = &Stack[SP-1];
|
|
v = eval(*body, lenv);
|
|
POP();
|
|
// macro: evaluate expansion in the calling environment
|
|
if (headsym == MACRO)
|
|
return eval(v, penv);
|
|
return v;
|
|
}
|
|
type_error("apply", "function", f);
|
|
return NIL;
|
|
}
|