vx-scheme/src/interp.cpp

1628 lines
40 KiB
C++
Raw Normal View History

//----------------------------------------------------------------------
// vx-scheme : Scheme interpreter.
// Copyright (c) 2002,2003,2006 and onwards Colin Smith.
//
// You may distribute under the terms of the Artistic License,
// as specified in the LICENSE file.
//
// interp.cpp : SICP-style R4Rs-compliant Scheme interpreter
#include "vx-scheme.h"
// --------------------------------------------------------------------------
// Populate the symbol table with builtins.
//
INTERN_SYM (s_and, "and");
INTERN_SYM (s_apply, "apply");
INTERN_SYM (s_begin, "begin");
INTERN_SYM (s_callcc, "call-with-current-continuation");
INTERN_SYM (s_callwif, "call-with-input-file");
INTERN_SYM (s_callwof, "call-with-output-file");
INTERN_SYM (s_case, "case");
INTERN_SYM (s_cond, "cond");
INTERN_SYM (s_define, "define");
INTERN_SYM (s_defmacro, "defmacro");
INTERN_SYM (s_delay, "delay");
INTERN_SYM (s_do, "do");
INTERN_SYM (s_else, "else");
INTERN_SYM (s_eval, "eval");
INTERN_SYM (s_force, "force");
INTERN_SYM (s_foreach, "for-each");
INTERN_SYM (s_if, "if");
INTERN_SYM (s_lambda, "lambda");
INTERN_SYM (s_let, "let");
INTERN_SYM (s_letrec, "letrec");
INTERN_SYM (s_letstar, "let*");
INTERN_SYM (s_load, "load");
INTERN_SYM (s_map, "map");
INTERN_SYM (s_or, "or");
INTERN_SYM (s_passto, "=>");
INTERN_SYM (s_set, "set!");
INTERN_SYM (s_time, "time");
INTERN_SYM (s_withinput, "with-input-from-file");
INTERN_SYM (s_withoutput, "with-output-to-file");
// --------------------------------------------------------------------------
// Unsafe Accessors
//
// These are versions of car and cdr that do not check to ensure that
// they are applied to conses. The program can crash if this precondition
// is not meant. They are only safe to use when the implementation can
// guarantee that they are applied to conses (and so we only use them
// on lists that we manage explicitly).
#define CAR(c) ((c)->ca.p)
#define CDR(c) ((c)->cd.p)
void Context::bind (Cell * env, Cell * c, Cell * value)
{
cellvector * vec = car (env)->VectorValue ();
psymbol s = c->SymbolValue ();
if (c->flag (Cell::QUICK) && c->e_skip() == 0)
{
// We have a quick binding, and, as we expect,
// it's within this frame. We can establish
// it without searching.
int b_skip = c->b_skip();
int sz = vec->size ();
if (b_skip == sz)
{
r_nu = cons (c, value);
vec->push (r_nu);
}
else if (b_skip < 0 || b_skip > sz)
error ("internal error: invalid lexical address: ",
c->SymbolValue ()->key);
else
Cell::setcdr (vec->get (b_skip), value);
}
else
{
for (int ix = 0; ix < vec->size (); ++ix)
{
Cell * c = vec->get (ix);
if (car (c)->SymbolValue () == s)
{
Cell::setcdr (c, value);
return;
}
}
// construct new binding element (being carful that
// intermediate material is reachable from the register
// set.
r_nu = make_symbol (s);
r_nu = cons (r_nu, value);
vec->push (r_nu);
}
}
// This is a list of "states" the evaluator can be in. The names
// were chosen to harmonize with those chosen in SICP.
enum {
eval_dispatch,
eval_complete,
ev_application, ev_application2,
ev_args1, ev_args2,
ev_sequence,
ev_sequence_continue,
apply_dispatch, apply_dispatch2,
ev_if,
ev_if_decide,
ev_finish,
ev_define,
ev_define_1,
ev_eval,
ev_eval1,
ev_set,
ev_set_1,
ev_or, ev_or2,
ev_and, ev_and2,
macro_subst,
ev_let,
ev_let_init,
let_accumulate_binding,
ev_letstar,
ev_letstar_init,
ev_letstar_bind,
ev_do,
ev_do_init,
ev_do_bind,
ev_do_test,
ev_after_test,
ev_do_step,
ev_step_1,
ev_step_bind,
ev_step_finish,
ev_do_step_2,
ev_cond,
ev_cond_test,
ev_apply,
ev_apply2,
ev_apply3,
macro_subst2,
ev_cond_passto,
ev_quasiquote, ev_unquote, ev_qq0, ev_qq1, ev_qq2, ev_qq3,
ev_qq_decrease, ev_qqd_1, ev_qq_finish,
ev_apply4,
ev_unq_spl,
ev_unq_spl2,
ev_letrec, ev_letrec1, ev_letrec2,
ev_case, ev_case2,
ev_foreach, ev_foreach1, ev_foreach2, ev_foreach3, ev_foreach4,
ev_force, ev_force2,
ev_map, ev_map1, ev_map2, ev_map3,
ev_withinput, ev_withinput1, ev_withinput2,
ev_withoutput, ev_withoutput1, ev_withoutput2,
ev_load, ev_load2, ev_callwof, ev_callwof2, ev_time, ev_time1,
};
// These are the above states in string form. This is only used
// for debugging, to dump the evaluator's state transitions.
static const char * state_name [] =
{
"eval_dispatch",
"eval_complete",
"ev_application", "ev_application2",
"ev_args1", "ev_args2",
"ev_sequence",
"ev_sequence_continue",
"apply_dispatch", "apply_dispatch2",
"ev_eval", "ev_eval1",
"ev_if",
"ev_if_decide",
"ev_finish",
"ev_define",
"ev_define_1",
"ev_set",
"ev_set_1",
"ev_or", "ev_or2",
"ev_and", "ev_and2",
"macro_subst",
"ev_let",
"ev_let_init",
"let_accumulate_binding",
"ev_letstar",
"ev_letstar_init",
"ev_letstar_bind",
"ev_do",
"ev_do_init",
"ev_do_bind",
"ev_do_test",
"ev_after_test",
"ev_do_step",
"ev_step_1",
"ev_step_bind",
"ev_step_finish",
"ev_do_step_2",
"ev_cond",
"ev_cond_test",
"ev_apply",
"ev_apply2",
"ev_apply3",
"macro_subst2",
"ev_cond_passto",
"ev_quasiquote", "ev_unquote", "ev_qq0", "ev_qq1", "ev_qq2", "ev_qq3",
"ev_qq_decrease", "ev_qqd_1", "ev_qq_finish",
"ev_apply4",
"ev_unq_spl",
"ev_unq_spl2",
"ev_letrec", "ev_letrec1", "ev_letrec2",
"ev_case", "ev_case2",
"ev_foreach", "ev_foreach1", "ev_foreach2", "ev_foreach3", "ev_foreach4",
"ev_force", "ev_force2",
"ev_map", "ev_map1", "ev_map2", "ev_map3",
"ev_withinput", "ev_withinput2", "ev_withoutput", "ev_withoutput2",
"ev_load", "ev_load2", "ev_callwof", "ev_callwof2", "ev_time", "ev_time1",
};
// Here it is: a >1000 line function that consists of a giant switch
// statement, and it's peppered with goto's!
//
// This would be inexcusable, except it has to do its job (evaulation
// Scheme expressions) without using the C stack as a resource. This
// could be thought of as a sort of microcode, using a set of virtual
// machine registers (r_exp, r_unev, etc.: the uses of these registers
// is described in SICP).
//
// I've followed this approach because I wanted to be able to capture
// continuations and collect garbage without having to know any details
// about how the C stack operates. This evaluator is somewhat more
// complicated than the one described in SICP since it supports many
// language features not discussed in that chapter.
//
// For these reasons, eval should not be recursed into by anyone,
// including itself.
Cell* Context::interp_evaluator(Cell * form)
{
psymbol s;
Cell::Type t;
Cell::Procedure lambda;
intptr_t flag = 0;
double t1;
bool trace;
psymbol p;
sstring read_sstr;
init_machine ();
state = eval_dispatch;
r_cont = eval_complete;
r_exp = form;
r_qq = 0;
trace = OS::flag (TRACE_EVAL);
#define GOTO(x) do { \
state = x; \
goto TOP; \
} while (0)
#define EVAL_DISPATCH() do { \
if (r_exp == nil) \
{ \
r_val = nil; \
GOTO (r_cont); \
} \
Cell::Type __t = (r_exp)->type(); \
if (__t == Cell::Cons) \
GOTO (ev_application); \
if (__t == Cell::Symbol) \
r_val = get (r_env, r_exp); \
else \
r_val = r_exp; \
GOTO (r_cont); \
} while (0)
#define RETURN_VALUE(v) do { \
r_val = (v); \
restore_i (r_cont); \
GOTO (r_cont); \
} while (0)
// If the exp is self-evaluating or a variable, handle it
// immediately. Else call eval_dispatch in a context
// where r_env end r_unev are saved/restored.
#define CALL_EVAL(label) \
t = (r_exp)->type(); \
if (t == Cell::Symbol) \
{ \
r_val = get (r_env, r_exp); \
goto label##__2; \
} \
else if (t != Cell::Cons) \
{ \
r_val = r_exp; \
goto label##__2; \
} \
else \
{ \
save (r_env); \
save (r_unev); \
r_cont = label; \
GOTO (eval_dispatch); \
} \
case label: \
restore (r_unev); \
restore (r_env); \
label##__2:
TOP:
if (trace)
print_vm_state ();
switch (state)
{
case eval_dispatch:
if (r_exp == nil)
{
r_val = nil;
GOTO (r_cont);
}
switch (r_exp->type ())
{
case Cell::Symbol:
r_val = get (r_env, r_exp);
GOTO (r_cont);
case Cell::Cons:
GOTO (ev_application);
default: // self-evaluating
r_val = r_exp;
GOTO (r_cont);
}
case eval_complete:
return r_val;
case ev_application:
save_i (r_cont);
r_unev = cdr (r_exp);
r_exp = car (r_exp);
CALL_EVAL (ev_application2);
r_proc = r_val;
case apply_dispatch:
if (!r_proc->flag (Cell::MACRO))
{
// It's not a special form: evaluate all the arguments
// in unev and collect them into r_argl.
clear (r_argl);
save (r_proc);
case ev_args1:
if (r_unev == nil)
{
restore (r_proc);
GOTO (apply_dispatch2);
}
save (r_argl);
r_exp = car (r_unev);
r_unev = cdr (r_unev);
CALL_EVAL (ev_args2);
restore (r_argl);
l_append (r_argl, r_val);
GOTO (ev_args1);
}
case apply_dispatch2:
switch (r_proc->type ())
{
case Cell::Builtin:
// =================================================
// THE BUILTIN SPECIAL FORMS
// =================================================
s = r_proc->BuiltinValue ();
if (s == s_if) GOTO (ev_if);
else if (s == s_define) GOTO (ev_define);
else if (s == s_begin) GOTO (ev_sequence);
else if (s == s_set) GOTO (ev_set);
else if (s == s_let) GOTO (ev_let);
else if (s == s_letstar) GOTO (ev_letstar);
else if (s == s_letrec) GOTO (ev_letrec);
else if (s == s_do) GOTO (ev_do);
else if (s == s_cond) GOTO (ev_cond);
else if (s == s_case) GOTO (ev_case);
else if (s == s_eval) GOTO (ev_eval);
else if (s == s_foreach) GOTO (ev_foreach);
else if (s == s_load) GOTO (ev_load);
else if (s == s_map) GOTO (ev_map);
else if (s == s_apply) GOTO (ev_apply);
else if (s == s_force) GOTO (ev_force);
else if (s == s_quote) r_val = car (r_unev);
else if (s == s_or) { r_val = &Cell::Bool_F;
GOTO (ev_or); }
else if (s == s_and) { r_val = &Cell::Bool_T;
GOTO (ev_and); }
else if (s == s_delay) r_val = make_promise (r_env,
r_unev);
else if (s == s_quasiquote) { r_unev = car (r_unev);
GOTO (ev_quasiquote); }
else if (s == s_lambda) r_val = make_procedure
(r_env, cdr (r_unev),
car (r_unev));
else if (s == s_defmacro) { r_proc = make_macro (r_env,
cdr (r_unev),
cdar (r_unev));
bind (r_env, caar (r_unev),
r_proc);
r_val = unspecified; }
else if (s == s_time) GOTO (ev_time);
else if (s == s_withinput) GOTO (ev_withinput);
else if (s == s_withoutput) GOTO (ev_withoutput);
else if (s == s_callwof) GOTO (ev_callwof);
else if (s == s_callwif)
{
r_proc = Cell::cadar (&r_argl);
r_tmp = make_iport (Cell::caar (&r_argl)->StringValue ());
r_tmp = cons (r_tmp, nil);
Cell::setcar (&r_argl, r_tmp);
GOTO (apply_dispatch2);
}
else if (s == s_callcc)
{
r_proc = Cell::caar (&r_argl);
r_tmp = make_continuation ();
r_tmp = cons (r_tmp, nil);
Cell::setcar (&r_argl, r_tmp);
GOTO (apply_dispatch2);
}
else
error ("unimplemented builtin ", s->key);
break;
case Cell::Subr:
r_val = r_proc->SubrValue ()->subr (this,
Cell::car (&r_argl));
break;
case Cell::Lambda:
lambda = r_proc->LambdaValue ();
if (r_proc->flag (Cell::MACRO))
{
save (r_env);
r_env = extend (lambda.envt);
bind_arguments (r_env, lambda.arglist, r_unev);
save_i (macro_subst); // continuation
}
else
{
r_env = extend (lambda.envt);
bind_arguments (r_env, lambda.arglist,
Cell::car (&r_argl));
}
r_unev = lambda.body;
GOTO (ev_sequence);
case Cell::Cont:
r_val = Cell::caar(&r_argl);
load_continuation (r_proc);
break;
case Cell::Cproc:
if (vm_execute) {
(this->*vm_execute) (r_proc, Cell::car (&r_argl));
} else {
error ("VM not loaded: can't dispatch a compiled procedure");
}
break;
default:
r_proc->dump (stdout);
error ("can't dispatch one of those.");
}
restore_i (r_cont);
GOTO (r_cont);
case ev_eval:
// The eval special form. (Can't let eval recurse, so
// we take care of it here in the VM).
r_exp = Cell::caar (&r_argl);
save (r_env);
r_env = root_envt;
CALL_EVAL (ev_eval1);
restore (r_env);
RETURN_VALUE (r_val);
case ev_time:
// Call the supplied procedure while timing it.
// Return a cons of the elapsed time and the proc's
// value.
r_proc = Cell::caar(&r_argl);
clear(r_argl);
save(make_real(OS::get_time()));
save_i(ev_time1); // cont
GOTO(apply_dispatch2);
case ev_time1:
t1 = OS::get_time();
restore(r_tmp);
r_tmp = make_real(t1 - r_tmp->RealValue());
RETURN_VALUE (cons (r_tmp, r_val));
case ev_sequence:
r_exp = car (r_unev);
if (r_exp == nil)
RETURN_VALUE (unspecified);
if (cdr (r_unev) == nil)
{
restore_i(r_cont);
EVAL_DISPATCH ();
}
CALL_EVAL (ev_sequence_continue);
r_unev = cdr (r_unev);
GOTO (ev_sequence);
// ev_if, etc., is a deviation from the presentation in SICP.
// In brief we are not dispatched by syntax analysis, but by
// finding a Builtin in the functor position. We get here via
// apply dispatch. Our job is to compute `r_val', pop the
// continuation and branch there.
//
// Had we followed SICP strictly, then special forms like
// "if" would have no visible definition at all, and could
// never be redefined. Most Scheme interpretations do allow
// for the redefinition of builtin symbols. Hence we use
// builtins as a sort of "flag" that invokes the internal
// sytnax-directed implementation to proceed.
case ev_if:
r_exp = car (r_unev);
r_unev = cdr (r_unev);
CALL_EVAL (ev_if_decide);
restore_i(r_cont);
if (r_val->istrue ())
{
r_exp = car (r_unev);
EVAL_DISPATCH ();
}
else
{
if ((r_exp = cdr (r_unev)) != nil)
{
r_exp = car (r_exp);
EVAL_DISPATCH ();
}
else
{
r_val = unspecified;
GOTO (r_cont);
}
}
case ev_define:
r_tmp = car (r_unev);
if (r_tmp->type () == Cell::Symbol)
{
save (r_env);
save (r_unev);
r_exp = cadr (r_unev);
r_cont = ev_define_1;
EVAL_DISPATCH ();
}
else
{
r_proc = make_procedure (r_env, cdr (r_unev), cdr (r_tmp));
bind (r_env, car (r_tmp), r_proc);
RETURN_VALUE (unspecified);
}
case ev_define_1:
restore (r_unev);
restore (r_env);
bind (r_env, car (r_unev), r_val);
RETURN_VALUE (unspecified);
case ev_set:
r_exp = cadr (r_unev);
CALL_EVAL (ev_set_1);
set (r_env, car (r_unev), r_val);
RETURN_VALUE (unspecified);
case ev_or:
if (r_unev == nil || r_val->istrue ())
{
restore_i(r_cont);
GOTO (r_cont);
}
r_exp = car (r_unev);
CALL_EVAL (ev_or2);
r_unev = cdr (r_unev);
GOTO (ev_or);
case ev_and:
if (r_unev == nil || !r_val->istrue ())
{
restore_i (r_cont);
GOTO (r_cont);
}
r_exp = car (r_unev);
CALL_EVAL (ev_and2);
r_unev = cdr (r_unev);
GOTO (ev_and);
case macro_subst:
// The macro has been expanded. One more trip through
// eval, please.
restore (r_env);
restore_i (r_cont);
r_exp = r_val;
EVAL_DISPATCH ();
case ev_let:
// (let [name?] ((v e) ...) x...)
// The plan is to accumulate the list of variables (v) in
// r_varl, and the list of initializers (e) in r_argl.
if (car (r_unev)->type () == Cell::Symbol)
{
r_proc = car (r_unev); // named let: stash in r_proc
r_unev = cdr (r_unev);
}
else
r_proc = nil;
clear (r_argl);
clear (r_varl);
if (car (r_unev) == nil)
{
r_unev = cdr (r_unev); // (let () x...)
r_env = extend (r_env);
goto let_noargs;
}
save (r_proc);
save (cdr (r_unev));
r_unev = car (r_unev); // fall through
case ev_let_init:
save (r_argl);
save (r_varl);
r_exp = cadar (r_unev);
CALL_EVAL (let_accumulate_binding);
restore (r_varl);
restore (r_argl);
l_append (r_varl, caar (r_unev));
l_append (r_argl, r_val);
r_unev = cdr (r_unev);
if (r_unev == nil)
{
restore (r_unev);
restore (r_proc);
let_noargs:
if (r_proc != nil)
{
r_env = extend (r_env);
r_tmp = make_procedure (r_env,
r_unev,
Cell::car (&r_varl));
bind (r_env, r_proc, r_tmp);
}
r_env = extend (r_env);
bind_arguments (r_env,
Cell::car (&r_varl),
Cell::car (&r_argl));
GOTO (ev_sequence);
}
GOTO (ev_let_init);
case ev_letstar:
// (let* ((v e) ...) x1 ...)
// We unpack, bind, and extend in a loop, until we're
// ready for the sequence.
if (car (r_unev) == nil)
{
r_env = extend (r_env);
r_unev = cdr (r_unev);
GOTO (ev_sequence);
}
save (cdr (r_unev));
r_unev = car (r_unev);
/* fall thru */
case ev_letstar_init:
save (r_env);
save (r_unev);
r_exp = cadar (r_unev);
r_cont = ev_letstar_bind;
EVAL_DISPATCH ();
case ev_letstar_bind:
restore (r_unev);
restore (r_env);
r_env = extend (r_env);
bind (r_env, caar (r_unev), r_val);
r_unev = cdr (r_unev);
if (r_unev == nil)
{
restore (r_unev);
GOTO (ev_sequence);
}
GOTO (ev_letstar_init);
case ev_letrec:
// we have: (((v1 i1) (v2 i2)...) x1 x2...)
clear (r_varl);
clear (r_argl);
save (cdr (r_unev));
r_env = extend (r_env);
for (r_exp = car (r_unev); r_exp != nil; r_exp = cdr (r_exp))
{
l_append (r_varl, caar (r_exp));
bind (r_env, caar (r_exp), &Cell::Error);
}
save (r_varl);
r_unev = car (r_unev);
case ev_letrec1:
if (r_unev != nil)
{
r_exp = cadar (r_unev);
save (r_argl);
CALL_EVAL (ev_letrec2);
restore (r_argl);
l_append (r_argl, r_val);
r_unev = cdr (r_unev);
GOTO (ev_letrec1);
}
restore (r_varl);
restore (r_unev);
bind_arguments (r_env, Cell::car (&r_varl), Cell::car (&r_argl));
GOTO (ev_sequence);
case ev_do:
// (do ((var init step)...) (test x...) y...)
// Like let, accumulate variables (v) and
// initializers (i) into r_varl and r_argl.
save (r_unev); // (((var init step)...) (test x...) y...)
r_unev = car (r_unev); // ((var init step)...)
clear (r_argl);
clear (r_varl);
/* fall through */
case ev_do_init:
save (r_argl);
save (r_varl);
save (r_env);
save (r_unev);
r_exp = cadar (r_unev);
r_cont = ev_do_bind;
EVAL_DISPATCH ();
case ev_do_bind:
restore (r_unev);
restore (r_env);
restore (r_varl);
restore (r_argl);
l_append (r_varl, caar (r_unev));
l_append (r_argl, r_val);
r_unev = cdr (r_unev);
if (r_unev == nil)
{
// All done with inits. Create environment and start testing.
r_env = extend (r_env);
bind_arguments (r_env,
Cell::car (&r_varl),
Cell::car (&r_argl));
restore (r_unev); // (((var init step)...) (test x...) y...)
GOTO (ev_do_test);
}
GOTO (ev_do_init);
case ev_do_test:
r_exp = caadr (r_unev);
CALL_EVAL (ev_after_test);
if (r_val->istrue ())
{
// test passed: end iteration. Evaulate
// `x' expressions as a sequence.
r_unev = cdadr (r_unev);
if (r_unev == nil) // no consequent expressions?
RETURN_VALUE (unspecified);
GOTO (ev_sequence);
}
// otherwise, evaluate the y expressions for effect, if there
// are any
if (cddr (r_unev) == nil)
GOTO (ev_do_step_2);
save (r_unev);
save (r_env);
r_unev = cddr (r_unev);
save_i (ev_do_step);
GOTO (ev_sequence);
case ev_do_step:
// then use the step expressions (if any) to rebind the
// variables, and retest.
restore (r_env);
restore (r_unev); // (((var init step)...) (test x...) y...)
case ev_do_step_2:
save (r_unev);
r_unev = car (r_unev); // ((var init step) ...)
clear (r_argl);
clear (r_varl);
/* fall through */
case ev_step_1:
if (r_unev == nil)
{
// all done.
GOTO (ev_step_finish);
}
r_tmp = cddar (r_unev);
if (r_tmp == nil)
{
r_unev = cdr (r_unev);
GOTO (ev_step_1);
}
save (r_argl);
save (r_varl);
r_exp = caddar (r_unev);
CALL_EVAL (ev_step_bind);
restore (r_varl);
restore (r_argl);
l_append (r_varl, caar (r_unev));
l_append (r_argl, r_val);
r_unev = cdr (r_unev);
GOTO (ev_step_1);
case ev_step_finish:
bind_arguments (r_env, Cell::car (&r_varl), Cell::car (&r_argl));
restore (r_unev);
GOTO (ev_do_test);
case ev_cond:
if (r_unev == nil)
RETURN_VALUE (unspecified);
r_exp = caar (r_unev); // t1
if (r_exp->is_symbol (s_else))
r_val = &Cell::Bool_T;
else
{
r_cont = ev_cond_test;
CALL_EVAL (ev_cond_test);
}
if (r_val->istrue ())
{
r_unev = cdar (r_unev);
r_tmp = car (r_unev);
// Check for "=> r_proc" syntax
if (r_tmp->is_symbol (s_passto))
{
// We already have the argument. Now, evaluate
// r_proc, so we can apply it.
save (r_val);
r_unev = cdr (r_unev);
r_exp = car (r_unev);
CALL_EVAL (ev_cond_passto);
r_proc = r_val;
restore (r_val);
Cell::setcar (&r_argl, cons (r_val, nil));
GOTO (apply_dispatch2);
}
GOTO (ev_sequence);
}
r_unev = cdr (r_unev);
GOTO (ev_cond);
case ev_apply:
// we have, e.g., (apply + 1 2 '(3 4))
// and we want (+ 1 2 3 4).
r_proc = Cell::caar(&r_argl); // peel off r_proc
r_tmp = Cell::cdar(&r_argl);
clear (r_argl);
for (; r_tmp != nil; r_tmp = cdr (r_tmp))
if (cdr (r_tmp) == nil) // fold the list
l_appendtail (r_argl, car (r_tmp));
else
l_append (r_argl, car (r_tmp));
GOTO (apply_dispatch2);
case ev_quasiquote:
// If it's a vector, convert it to a list and
// save a flag.
++r_qq;
t = r_unev->type ();
if (t == Cell::Vec)
{
save_i (1);
r_unev = vector_to_list (this, cons (r_unev, nil)); // yyy
}
else
save_i (0);
save_i (ev_qq_finish);
r_val = nil;
case ev_qq0:
t = r_unev->type ();
if (t == Cell::Cons)
{
r_exp = car (r_unev);
if (r_exp->type () == Cell::Symbol)
{
p = r_exp->SymbolValue ();
if (p == s_unquote) // unquote: evaluate sequel.
{
if (r_qq == 1)
{
r_exp = cadr (r_unev);
--r_qq;
CALL_EVAL (ev_unquote);
++r_qq;
}
else
{
r_tmp = make_symbol (s_unquote);
save (r_tmp);
GOTO (ev_qq_decrease);
}
}
else if (p == s_quasiquote) // increase QQ level.
{
r_unev = cdr (r_unev);
save_i (ev_qq1);
GOTO (ev_quasiquote);
case ev_qq1:
r_tmp = make_symbol (s_quasiquote);
r_val = cons (r_tmp, r_val);
}
else
goto QQCONS;
}
else if (r_exp->type () == Cell::Cons &&
car (r_exp)->is_symbol (s_unquote_splicing))
{
if (r_qq == 1)
{
// unquote_splicing: generate list, and splice it
// in. First evaluate to get the list.
r_exp = cadr (r_exp);
r_unev = cdr (r_unev);
CALL_EVAL (ev_unq_spl);
// r_val holds the list. Install it into r_argl
// (tracking head and tail). Then evaluate
// what follows.
r_tmp = r_val;
while (cdr (r_tmp) != nil)
r_tmp = cdr (r_tmp);
Cell::setcar(&r_argl, r_val);
Cell::setcdr(&r_argl, r_tmp);
save (r_argl);
r_exp = r_unev;
save_i (ev_unq_spl2);
GOTO (ev_qq0);
}
else
{
r_tmp = make_symbol (s_unquote_splicing);
save (r_tmp);
GOTO (ev_qq_decrease);
}
case ev_unq_spl2:
restore (r_argl);
l_appendtail (r_argl, r_val);
r_val = Cell::car(&r_argl);
}
else if (r_unev == nil)
r_val = nil;
else
{
QQCONS: // "move quasiquotation inward"
save (cdr (r_unev)); // cons (qq (car), qq (cdr))
save_i (ev_qq2); // new continuation
r_unev = r_exp;
GOTO (ev_qq0);
case ev_qq2:
restore (r_unev);
save (r_val);
save_i (ev_qq3);
GOTO (ev_qq0);
case ev_qq3:
restore (r_exp);
r_val = cons (r_exp, r_val);
}
}
else
r_val = r_unev; // atoms are self-evaluating
restore_i(r_cont);
GOTO (r_cont);
case ev_qq_finish: // finished. reconvert to
restore_i(flag); // vector form if necessary.
if (flag)
r_val = vector_from_list (this, r_val);
--r_qq;
restore_i(r_cont);
GOTO (r_cont);
case ev_qq_decrease:
// we get here because we saw unquote or unquote_splicing,
// and we want to proceed with a decreased qq level instead
// of evaluating it (because the qq level was too high
// when we encountered the form).
--r_qq;
r_unev = cdr (r_unev);
save_i (ev_qqd_1);
GOTO (ev_qq0);
case ev_qqd_1:
restore (r_exp); // recover head symbol
++r_qq;
RETURN_VALUE (cons (r_exp, r_val));
case ev_case:
// (key ((d1 d2...) x1 x2...) ((d3 d4...) x3 x4...))
// evaluate key, and shift it away.
r_exp = car (r_unev);
r_unev = cdr (r_unev);
CALL_EVAL (ev_case2);
for (; r_unev != nil; r_unev = cdr (r_unev))
{
r_exp = car (r_unev);
r_tmp = car (r_exp);
if (r_tmp->is_symbol (s_else))
{
r_unev = cdr (r_exp);
GOTO (ev_sequence);
}
for (; r_tmp != nil; r_tmp = cdr (r_tmp))
{
if (r_val->eq (car (r_tmp)))
{
r_unev = cdr (r_exp);
GOTO (ev_sequence);
}
}
}
RETURN_VALUE (unspecified);
case ev_foreach:
r_proc = Cell::caar(&r_argl); // (r_proc list...)
r_unev = Cell::cdar(&r_argl);
case ev_foreach1:
if (car (r_unev) == nil)
RETURN_VALUE (unspecified);
clear (r_argl);
for (r_tmp = r_unev; r_tmp != nil; r_tmp = cdr (r_tmp))
{
l_append (r_argl, caar (r_tmp));
Cell::setcar (r_tmp, cdar (r_tmp));
}
save (r_unev);
save (r_proc);
save_i(ev_foreach2);
GOTO (apply_dispatch2);
case ev_foreach2:
restore (r_proc);
restore (r_unev);