2006-08-12 15:00:13 -04:00
|
|
|
//----------------------------------------------------------------------
|
|
|
|
// 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;
|
2008-06-17 19:00:34 -04:00
|
|
|
intptr_t flag = 0;
|
2006-08-12 15:00:13 -04:00
|
|
|
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); \
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i (r_cont); \
|
2006-08-12 15:00:13 -04:00
|
|
|
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:
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (r_cont);
|
2006-08-12 15:00:13 -04:00
|
|
|
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);
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (macro_subst); // continuation
|
2006-08-12 15:00:13 -04:00
|
|
|
}
|
|
|
|
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.");
|
|
|
|
}
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i (r_cont);
|
2006-08-12 15:00:13 -04:00
|
|
|
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()));
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i(ev_time1); // cont
|
2006-08-12 15:00:13 -04:00
|
|
|
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)
|
|
|
|
{
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i(r_cont);
|
2006-08-12 15:00:13 -04:00
|
|
|
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);
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i(r_cont);
|
2006-08-12 15:00:13 -04:00
|
|
|
|
|
|
|
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 ())
|
|
|
|
{
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i(r_cont);
|
2006-08-12 15:00:13 -04:00
|
|
|
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 ())
|
|
|
|
{
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i (r_cont);
|
2006-08-12 15:00:13 -04:00
|
|
|
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);
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i (r_cont);
|
2006-08-12 15:00:13 -04:00
|
|
|
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);
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (ev_do_step);
|
2006-08-12 15:00:13 -04:00
|
|
|
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)
|
|
|
|
{
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (1);
|
2006-08-12 15:00:13 -04:00
|
|
|
r_unev = vector_to_list (this, cons (r_unev, nil)); // yyy
|
|
|
|
}
|
|
|
|
else
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (0);
|
2006-08-12 15:00:13 -04:00
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (ev_qq_finish);
|
2006-08-12 15:00:13 -04:00
|
|
|
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);
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (ev_qq1);
|
2006-08-12 15:00:13 -04:00
|
|
|
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;
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (ev_unq_spl2);
|
2006-08-12 15:00:13 -04:00
|
|
|
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))
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (ev_qq2); // new continuation
|
2006-08-12 15:00:13 -04:00
|
|
|
r_unev = r_exp;
|
|
|
|
GOTO (ev_qq0);
|
|
|
|
case ev_qq2:
|
|
|
|
restore (r_unev);
|
|
|
|
save (r_val);
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (ev_qq3);
|
2006-08-12 15:00:13 -04:00
|
|
|
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
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i(r_cont);
|
2006-08-12 15:00:13 -04:00
|
|
|
GOTO (r_cont);
|
|
|
|
|
|
|
|
case ev_qq_finish: // finished. reconvert to
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i(flag); // vector form if necessary.
|
2006-08-12 15:00:13 -04:00
|
|
|
if (flag)
|
|
|
|
r_val = vector_from_list (this, r_val);
|
|
|
|
--r_qq;
|
2008-06-17 19:00:34 -04:00
|
|
|
restore_i(r_cont);
|
2006-08-12 15:00:13 -04:00
|
|
|
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);
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i (ev_qqd_1);
|
2006-08-12 15:00:13 -04:00
|
|
|
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);
|
2008-06-17 19:00:34 -04:00
|
|
|
save_i(ev_foreach2);
|
2006-08-12 15:00:13 -04:00
|
|
|
GOTO (apply_dispatch2);
|
|
|
|
case ev_foreach2:
|
|
|
|
restore (r_proc);
|
|
|
|
restore (r_unev);
|
|
|
|
|