atom *apply (afun *fn, acons *args, nspace *n) {
nspace *x = fn->n;
if (args)
if (*(fn->args) == tsym)
x = define(x, csym(fn->args), evallist(args, n));
else
{
atom *fargs = fn->args;
while (fargs && *fargs == tcons && args)
{
x = define(x, csym(ccons(fargs)->car), eval(args->car, n));
args = ccons(args->cdr);
fargs = ccons(fargs)->cdr;
}
if (fargs && *fargs == tcons)
printf("too few arguments\n");
else if (fargs)
x = define(x, csym(fargs), evallist(args, n));
else if (args)
printf("too many arguments\n");
}
if (*catom(fn) == tfun)
return begin(fn->body, x);
return begin(fn->body, n);
}
/* eval helpers 44a */
static Valuelist evallist(Explist el, Valenv globals, Funenv functions, Valenv
formals, Valenv locals) {
if (el == NULL) {
return NULL;
} else {
Value v = eval(el->hd, globals, functions, formals, locals);
return mkVL(v, evallist(el->tl, globals, functions, formals, locals));
}
}
/* 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 */
}
}
CELLP eval(CELLP form, CELLP env)
{
//static int e = 0;
//static char tabs[100];
CELLP cp, apply(), atomvalue(), evallist();
ATOMP func;
//tabs[e] = ' ';
//tabs[++e] = '\0';
//printf("\n%s%d: form=", tabs, e);
//printf("省略");
//print_s(form, ESCON);
//printf("\n");
//if(e>150){
//printf(", env=");
//print_s(env, ESCON);
//printf("\n");
//}
switch(form->id) {
case _ATOM:
cp = atomvalue((ATOMP)form, env);
break;
case _FIX:
case _FLT:
//printf("\n%s%d: result=(NUM)", tabs, e);
//print_s(form,ESCON);
//printf("\n");
//tabs[--e] = '\0';
return form;
case _CELL:
// stackcheck;
//スタックポインタを進める
*++sp = (CELLP)nil; stackcheck;
//printf("=%d= ", __LINE__);
func = (ATOMP)form->car;
//printf("=%d= ", __LINE__);
{//N//
int q = on(&form);
on(&env);
//on(sp);//N//
on((CELLP*)&func);//N//
//printf("=%d= ", __LINE__);
if(eval_arg_p(func)) {
//スタックに引き数を評価した結果を保存する(このバックグラウンドでspは--されている)
//printf("eval form=");
//print_s(form, ESCOFF);
//printf("=%d= ", __LINE__);
*sp = evallist(form->cdr, env);
//printf("=%d= ", __LINE__);
//off(q);//N//
if(err){//N//
off(q);//N//
//printf("=%d= ", __LINE__);
break;//N//
}//N//
}
else {
//printf("=%d= ", __LINE__);
*sp = form->cdr;
}
// printf("\nEVAL: Current *SP is ");
// print_s(*sp, ESCON);
// printf("\n");
//printf("=%d= ", __LINE__);
cp = apply((CELLP)func, *sp, env);
//printf("=%d= ", __LINE__);
off(q);
}//N//
sp--;
break;
default:
//printf("\n%s%d: result=EORROR", tabs, e);
//tabs[--e] = '\0';
error(ULO);
}
if(err == ERR) {
pri_err(form);
//printf("\n%s%d: result=EORROR", tabs, e);
//tabs[--e] = '\0';
return NULL;
}
//printf("\n%s%d: result=", tabs, e);
//printf("省略");
//print_s(cp, ESCON);
//tabs[--e] = '\0';
//if(e == 0) printf("\n");
//printf("=%d= ", __LINE__);
return cp;
}
/*
* As in Impcore, the evaluator is still a [[switch]]:
* <eval.c>=
*/
Value eval(Exp e, Env env) {
checkoverflow(1000000 * sizeof(char *)); /* OMIT */
switch (e->alt) {
case LITERAL:
/*
* <evaluate [[e->u.literal]] and return the result>=
*/
return e->u.literal;
case VAR:
/*
* Variables
*
* Variable lookup and assignment are simpler than in
* Impcore, because we have only one rule each. We
* implement rho(x) by find(x, rho), we implement sigma
* (l) by [[*]]l, and we update sigma(l) by assigning to
* [[*]]l. [*]
* <evaluate [[e->u.var]] and return the result>=
*/
if (find(e->u.var, env) == NULL)
error("variable %n not found", e->u.var);
return *find(e->u.var, env);
case SET:
/*
* [*] [*]
* <evaluate [[e->u.set]] and return the result>=
*/
if (find(e->u.set.name, env) == NULL)
error("set unbound variable %n", e->u.set.name);
return *find(e->u.set.name, env) = eval(e->u.set.exp, env);
case IFX:
/*
* Conditional, iteration, and sequence
*
* The implementations of the control-flow operations
* are very much as in Impcore. We don't bother
* repeating the operational semantics.
* <evaluate [[e->u.ifx]] and return the result>=
*/
if (istrue(eval(e->u.ifx.cond, env)))
return eval(e->u.ifx.true, env);
else
return eval(e->u.ifx.false, env);
case WHILEX:
/*
* <evaluate [[e->u.whilex]] and return the result>=
*/
while (istrue(eval(e->u.whilex.cond, env)))
eval(e->u.whilex.body, env);
return falsev;
case BEGIN:
/*
* <evaluate [[e->u.begin]] and return the result>=
*/
{
Explist el;
Value v = falsev;
for (el = e->u.begin; el; el = el->tl)
v = eval(el->hd, env);
return v;
}
case APPLY:
/*
* We handle application of primitives separately from
* application of closures.
*
* <evaluate [[e->u.apply]] and return the result>=
*/
{
Value f = eval (e->u.apply.fn, env);
Valuelist vl = evallist(e->u.apply.actuals, env);
switch (f.alt) {
case PRIMITIVE:
/*
* Applying a primitive is simpler than in our Impcore
* interpreter because we represent primitives by
* function pointers and tags. The tag is passed to the
* function, along with the arguments ([[vl]]), plus the
* abstract syntax [[e]], which is used in error
* messages.
* <apply [[f.u.primitive]] to [[vl]] and return the result>=
*/
return f.u.primitive.function(e, f.u.primitive.tag, vl);
case CLOSURE:
/*
* To apply a closure, we extend the closure's
* environment (rho_c in the operational semantics) with
* the bindings for the formal variables and then
* evaluate the body in that environment.
* <apply [[f.u.closure]] to [[vl]] and return the result>=
*/
{
Namelist nl = f.u.closure.lambda.formals;
checkargc(e, lengthNL(nl), lengthVL(vl));
return eval(f.u.closure.lambda.body,
bindalloclist(nl, vl, f.u.closure.env));
}
default:
error("%e evaluates to non-function %v in %e", e->u.apply.fn, f,
e);
}
}
case LETX:
/*
* Let, let*, and letrec
*
* Each expression in the [[let]] family uses its
* internal names and expressions to create a new
* environment, then evaluates the body in that
* environment. The rules for creating the environment
* depend on the keyword.
* <evaluate [[e->u.letx]] and return the result>=
*/
switch (e->u.letx.let) {
case LET:
/*
* <if [[e->u.letx.nl]] contains a duplicate, complain of error in
[[let]]>=
*/
if (duplicatename(e->u.letx.nl) != NULL)
error("bound name %n appears twice in let", duplicatename(e->
u.letx.nl));
/*
* A \xlet expression evaluates the expressions to be
* bound, then binds them all at once. The functions
* [[evallist]] and [[bindalloclist]] do all the work.
* <extend [[env]] by simultaneously binding [[el]] to [[nl]]>=
*/
env = bindalloclist(e->u.letx.nl, evallist(e->u.letx.el, env), env);
break;
case LETSTAR:
/*
* A \xletstar expression binds a new name as each
* expression is evaluated.
*
* <extend [[env]] by sequentially binding [[el]] to [[nl]]>=
*/
{
Namelist nl;
Explist el;
for (nl = e->u.letx.nl, el = e->u.letx.el;
nl && el;
nl = nl->tl, el = el->tl)
env = bindalloc(nl->hd, eval(el->hd, env), env);
assert(nl == NULL && el == NULL);
}
break;
case LETREC:
/*
* <if [[e->u.letx.nl]] contains a duplicate, complain of error in
[[letrec]]>=
*/
if (duplicatename(e->u.letx.nl) != NULL)
error("bound name %n appears twice in letrec", duplicatename(e->
u.letx.nl));
/*
* Finally, \xletrec must bind each name to a location
* before evaluating any of the expressions. The initial
* contents of the new locations are unspecified. To be
* faithful to the semantics, we compute all the values
* before storing any of them.
* <extend [[env]] by recursively binding [[el]] to [[nl]]>=
*/
{
Namelist nl;
Valuelist vl;
for (nl = e->u.letx.nl; nl; nl = nl->tl)
env = bindalloc(nl->hd, unspecified(), env);
vl = evallist(e->u.letx.el, env);
for (nl = e->u.letx.nl;
nl && vl;
nl = nl->tl, vl = vl->tl)
*find(nl->hd, env) = vl->hd;
}
break;
default:
assert(0);
}
return eval(e->u.letx.body, env);
case LAMBDAX:
/*
* Closures and function application
*
* Wrapping a closure is simple; we need only to check
* for duplicate names.
* <evaluate [[e->u.lambdax]] and return the result>=
*/
/*
* Error checking
*
* Here are a few bits of error checking that were
* omitted from Chapter [->].
* <if [[e->u.lambdax.formals]] contains a duplicate, call [[error]]>=
*/
if (duplicatename(e->u.lambdax.formals) != NULL)
error("formal parameter %n appears twice in lambda",
duplicatename(e->u.lambdax.formals));
return mkClosure(e->u.lambdax, env);
}
/* eval.c 143a */
Value eval(Exp e, Env env) {
checkoverflow(1000000 * sizeof(char *)); /* OMIT */
switch (e->alt) {
case LITERAL:
/* evaluate [[e->u.literal]] and return the result 143b */
return e->u.literal;
case VAR:
/* evaluate [[e->u.var]] and return the result 143c */
if (find(e->u.var, env) == NULL)
error("variable %n not found", e->u.var);
return *find(e->u.var, env);
case SET:
/* evaluate [[e->u.set]] and return the result 143d */
if (find(e->u.set.name, env) == NULL)
error("set unbound variable %n", e->u.set.name);
return *find(e->u.set.name, env) = eval(e->u.set.exp, env);
case IFX:
/* evaluate [[e->u.ifx]] and return the result 147a */
if (istrue(eval(e->u.ifx.cond, env)))
return eval(e->u.ifx.true, env);
else
return eval(e->u.ifx.false, env);
case WHILEX:
/* evaluate [[e->u.whilex]] and return the result 147b */
while (istrue(eval(e->u.whilex.cond, env)))
eval(e->u.whilex.body, env);
return falsev;
case BEGIN:
/* evaluate [[e->u.begin]] and return the result 147c */
{
Explist el;
Value v = falsev;
for (el = e->u.begin; el; el = el->tl)
v = eval(el->hd, env);
return v;
}
case APPLY:
/* evaluate [[e->u.apply]] and return the result 144b */
{
Value f = eval (e->u.apply.fn, env);
Valuelist vl = evallist(e->u.apply.actuals, env);
switch (f.alt) {
case PRIMITIVE:
/* apply [[f.u.primitive]] to [[vl]] and return the result 144d */
return f.u.primitive.function(e, f.u.primitive.tag, vl);
case CLOSURE:
/* apply [[f.u.closure]] to [[vl]] and return the result 144e */
{
Namelist nl = f.u.closure.lambda.formals;
checkargc(e, lengthNL(nl), lengthVL(vl));
return eval(f.u.closure.lambda.body,
bindalloclist(nl, vl, f.u.closure.env));
}
default:
error("%e evaluates to non-function %v in %e", e->u.apply.fn, f,
e);
}
}
case LETX:
/* evaluate [[e->u.letx]] and return the result 145c */
switch (e->u.letx.let) {
case LET:
/* if [[e->u.letx.nl]] contains a duplicate, complain of error in [[let]] 715b */
if (duplicatename(e->u.letx.nl) != NULL)
error("bound name %n appears twice in let", duplicatename(e->
u.letx.nl));
/* extend [[env]] by simultaneously binding [[el]] to [[nl]] 145d */
env = bindalloclist(e->u.letx.nl, evallist(e->u.letx.el, env), env);
break;
case LETSTAR:
/* extend [[env]] by sequentially binding [[el]] to [[nl]] 146a */
{
Namelist nl;
Explist el;
for (nl = e->u.letx.nl, el = e->u.letx.el;
nl && el;
nl = nl->tl, el = el->tl)
env = bindalloc(nl->hd, eval(el->hd, env), env);
assert(nl == NULL && el == NULL);
}
break;
case LETREC:
/* if [[e->u.letx.nl]] contains a duplicate, complain of error in [[letrec]] 715c */
if (duplicatename(e->u.letx.nl) != NULL)
error("bound name %n appears twice in letrec", duplicatename(e->
u.letx.nl));
/* extend [[env]] by recursively binding [[el]] to [[nl]] 146b */
{
Namelist nl;
Valuelist vl;
for (nl = e->u.letx.nl; nl; nl = nl->tl)
env = bindalloc(nl->hd, unspecified(), env);
vl = evallist(e->u.letx.el, env);
for (nl = e->u.letx.nl;
nl && vl;
nl = nl->tl, vl = vl->tl)
*find(nl->hd, env) = vl->hd;
}
break;
default:
assert(0);
}
return eval(e->u.letx.body, env);
case LAMBDAX:
/* evaluate [[e->u.lambdax]] and return the result 144a */
/* if [[e->u.lambdax.formals]] contains a duplicate, call [[error]] 715a */
if (duplicatename(e->u.lambdax.formals) != NULL)
error("formal parameter %n appears twice in lambda",
duplicatename(e->u.lambdax.formals));
return mkClosure(e->u.lambdax, env);
}
LISP eval (LISP expr, LISP *ctxp)
{
LISP ctx = ctxp ? *ctxp : NIL;
LISP func;
again:
if (expr == NIL)
return (NIL);
/* Если это символ, берем его значение */
if (istype (expr, TSYMBOL)) {
/* Поиск значения по контексту */
LISP pair = findatom (expr, ctx);
if (pair == NIL) {
fprintf (stderr, "unbound symbol: `%s'\n", symname (expr));
return (NIL);
}
return (cdr (pair));
}
/* Все, что не атом и не список, не вычисляется */
if (! istype (expr, TPAIR))
return (expr);
/* Перебираем специальные формы.
* quote define set! begin lambda let let* letrec if
* and or cond else => quasiquote unquote unquote-splicing
*/
/* Зарезервированные имена:
* delay do case
*/
func = car (expr);
if (istype (func, TSYMBOL)) {
char *funcname = symname (func);
if (!strcmp (funcname, "quote")) {
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
return (car (expr));
}
if (!strcmp (funcname, "define")) {
LISP value, atom, pair, arg;
int lambda;
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
lambda = istype (atom = car (expr), TPAIR);
if (lambda) {
/* define, совмещенный с lambda */
arg = cdr (atom);
atom = car (atom);
}
if (! istype (atom, TSYMBOL) ||
! istype (expr = cdr (expr), TPAIR))
return (NIL);
pair = findatom (atom, ctx);
if (pair == NIL) {
/* Расширяем контекст */
pair = cons (atom, NIL);
if (ctxp)
/* локальный контекст */
*ctxp = ctx = cons (pair, ctx);
else
/* контекст верхнего уровня */
ENV = cons (pair, ENV);
}
if (lambda)
value = closure (cons (arg, expr), ctx);
else
value = evalblock (expr, ctx);
setcdr (pair, value);
return (value);
}
if (!strcmp (funcname, "set!")) {
LISP value = NIL;
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
if (istype (cdr (expr), TPAIR))
value = evalblock (cdr (expr), ctx);
setatom (car (expr), value, ctx);
return (value);
}
if (!strcmp (funcname, "begin"))
return (evalblock (cdr (expr), ctx));
if (!strcmp (funcname, "lambda")) {
LISP arg = NIL;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
return (closure (cons (arg, expr), ctx));
}
if (!strcmp (funcname, "let")) {
LISP arg = NIL, oldctx = ctx;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
/* Расширяем контекст новыми переменными */
while (istype (arg, TPAIR)) {
LISP var = car (arg);
arg = cdr (arg);
/* Значения вычисляем в старом контексте */
if (istype (var, TPAIR))
ctx = cons (cons (car (var),
evalblock (cdr (var), oldctx)),
ctx);
else if (istype (var, TSYMBOL))
ctx = cons (cons (var, NIL), ctx);
}
return (evalblock (expr, ctx));
}
if (!strcmp (funcname, "let*")) {
LISP arg = NIL;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
/* Расширяем контекст новыми переменными */
while (istype (arg, TPAIR)) {
LISP var = car (arg);
arg = cdr (arg);
/* Значения вычисляем в текущем контексте */
if (istype (var, TPAIR))
ctx = cons (cons (car (var),
evalblock (cdr (var), ctx)),
ctx);
else if (istype (var, TSYMBOL))
ctx = cons (cons (var, NIL), ctx);
}
return (evalblock (expr, ctx));
}
if (!strcmp (funcname, "letrec")) {
LISP arg = NIL, a;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
/* Расширяем контекст новыми переменными с пустыми значениями */
for (a=arg; istype (a, TPAIR); a=cdr(a)) {
LISP var = car (a);
if (istype (var, TPAIR))
ctx = cons (cons (car (var), NIL), ctx);
else if (istype (var, TSYMBOL))
ctx = cons (cons (var, NIL), ctx);
}
/* Вычисляем значения в новом контексте */
for (a=arg; istype (a, TPAIR); a=cdr(a)) {
LISP var = car (a);
if (istype (var, TPAIR))
setatom (car (var),
evalblock (cdr (var), ctx),
ctx);
}
return (evalblock (expr, ctx));
}
if (!strcmp (funcname, "if")) {
LISP iftrue = NIL, iffalse = NIL, test;
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
test = car (expr);
if (istype (expr = cdr (expr), TPAIR)) {
iftrue = car (expr);
iffalse = cdr (expr);
}
if (eval (test, &ctx) != NIL)
return (eval (iftrue, &ctx));
return (evalblock (iffalse, ctx));
}
if (!strcmp (funcname, "and")) {
while (istype (expr = cdr (expr), TPAIR))
if (eval (car (expr), &ctx) == NIL)
return (NIL);
return (T);
}
if (!strcmp (funcname, "or")) {
while (istype (expr = cdr (expr), TPAIR))
if (eval (car (expr), &ctx) == NIL)
return (T);
return (NIL);
}
if (!strcmp (funcname, "cond")) {
LISP oldctx = ctx, test, clause;
while (istype (expr = cdr (expr), TPAIR)) {
if (! istype (clause = car (expr), TPAIR))
continue;
ctx = oldctx;
if (istype (car (clause), TSYMBOL) &&
! strcmp (symname (car (clause)), "else"))
return (evalblock (cdr (clause), ctx));
test = eval (car (clause), &ctx);
if (test == NIL ||
! istype (clause = cdr (clause), TPAIR))
continue;
if (istype (car (clause), TSYMBOL) &&
! strcmp (symname (car (clause)), "=>")) {
clause = evalblock (cdr (clause), ctx);
if (istype (clause, THARDW))
return ((*hardwval (clause)) (cons (test, NIL), ctx));
if (istype (clause, TCLOSURE))
return (evalclosure (clause, cons (test, NIL)));
return (NIL);
}
return (evalblock (clause, ctx));
}
return (NIL);
}
if (!strcmp (funcname, "quasiquote")) {
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
return (quasiquote (car (expr), ctx, 0));
}
if (!strcmp (funcname, "unquote") ||
!strcmp (funcname, "unquote-splicing")) {
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
expr = car (expr);
goto again;
}
}
/* Вычисляем все аргументы */
expr = evallist (expr, ctx);
return (evalfunc (car (expr), cdr (expr), ctxp ? *ctxp : TOPLEVEL));
}
atom *evallist (acons *list, nspace *n) {
if (!list)
return NULL;
return newcons(eval(list->car, n), evallist(ccons(list->cdr), n));
}