conservatory
/
vx-scheme
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
vx-scheme/src/interp.cpp

1628 lines
40 KiB
C++
Raw Permalink Blame 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);
GOTO (ev_foreach1);
case ev_map:
r_proc = Cell::caar (&r_argl);
// copy r_argl to r_unev (less the first elt., which was the r_proc)
r_unev = Cell::cdar (&r_argl);
clear (r_varl);
case ev_map1:
if (car (r_unev) == nil) // no more arguments
GOTO (ev_map3);
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_varl);
save (r_unev);
save (r_proc);
save_i(ev_map2);
GOTO (apply_dispatch2);
case ev_map2:
restore (r_proc);
restore (r_unev);
restore (r_varl);
l_append (r_varl, r_val);
GOTO (ev_map1);
case ev_map3:
RETURN_VALUE (Cell::car (&r_varl));
case ev_force:
r_exp = Cell::caar (&r_argl);
if (r_exp->flag (Cell::FORCED))
r_val = r_exp->cd.cv->get (0); // return memoized value
else
{
// If we haven't forced the promise yet, then the cdr
// is pointing to a unit vector containing the
// procedure we must evaluate to get the value, which
// we then memoize.
clear (r_argl);
r_proc = r_exp->cd.cv->get (0);
save (r_exp);
save_i(ev_force2);
GOTO (apply_dispatch2);
case ev_force2:
// Now, it can happen that the procedure we're
// invoking can force its own value. If we find that
// the FORCED flag has magically become set as a
// result of forcing, then we must accept that earlier
// computation (we are "higher" on the evaluation
// stack)...
restore (r_exp);
if (r_exp->flag (Cell::FORCED))
r_val = r_exp->cd.cv->get (0);
else
{
r_exp->cd.cv->set (0, r_val);
r_exp->flag (Cell::FORCED, true);
}
}
restore_i(r_cont);
GOTO (r_cont);
case ev_withinput:
// (filename proc)
with_input (Cell::caar (&r_argl)->StringValue ());
r_proc = Cell::cadar (&r_argl);
clear (r_argl);
save_i(ev_withinput2); // continuation
GOTO (apply_dispatch2);
case ev_withinput2:
without_input ();
restore_i(r_cont);
GOTO (r_cont);
case ev_withoutput:
with_output (Cell::caar (&r_argl)->StringValue ());
r_proc = Cell::cadar (&r_argl);
clear (r_argl);
save_i(ev_withoutput2); // continuation
GOTO (apply_dispatch2);
case ev_withoutput2:
without_output ();
restore_i(r_cont);
GOTO (r_cont);
case ev_load:
r_unev = make_iport (Cell::caar (&r_argl)->StringValue ());
save (r_unev); // let r_unev hold input stream
save (r_env);
case ev_load2:
restore (r_env);
restore (r_unev);
r_exp = read (r_unev->IportValue ());
if (r_exp)
{
save (r_unev);
save (r_env);
r_env = root_envt; // read files into global scope
r_cont = ev_load2; // loop
EVAL_DISPATCH ();
}
r_exp = nil;
RETURN_VALUE (r_val);
case ev_callwof:
r_proc = Cell::cadar (&r_argl);
r_unev = make_oport (Cell::caar (&r_argl)->StringValue ());
Cell::setcar (&r_argl, cons (r_unev, nil));
save (r_unev);
save_i(ev_callwof2); // cont
GOTO (apply_dispatch2);
case ev_callwof2:
restore (r_unev);
fflush (r_unev->OportValue ());
RETURN_VALUE (r_val);
default:
printf ("IC = %x\n", state);
error ("internal: invalid continuation");
}
return unimplemented;
}
void Context::print_vm_state ()
{
printf ("%d %s exp=", m_stack.size (), state_name [state]);
r_exp->write (stdout);
printf (" unev=");
r_unev->write (stdout);
printf (" proc=");
r_proc->write (stdout);
printf (" val=");
r_val->write (stdout);
printf (" argl=");
Cell::car (&r_argl)->write (stdout);
printf (" varl=");
Cell::car (&r_varl)->write (stdout);
printf (" env=");
if (r_env == root_envt)
printf ("#<root>");
else
Cell::car (r_env)->write (stdout);
printf (" cont=%s q%d\n", state_name [r_cont], r_qq);
}
void Context::bind_arguments (Cell * env, Cell * variables, Cell * values)
{
Cell * var;
Cell * val;
if (variables->type () == Cell::Cons)
{
for (var = variables, val = values;
var != nil;
var = cdr (var), val = cdr (val))
{
bind (env, car (var), car (val));
if (cdr (var)->type () == Cell::Symbol)
{
// Implement "dotted tail" procedure call. If
// the cdr of var is another symbol, then this
// was to the right of the "dot"; put all the rest
// of the arguments in there. [SICP 2ed. p. 104, 183n;
// R5RS 4.1.4]
bind (env, cdr (var), cdr (val));
break;
}
}
}
else
{
// "varargs" version: (lambda args body...)
bind (env, variables, values);
}
}
Cell * Context::get (Cell * env, Cell * c)
{
c->typecheck (Cell::Symbol);
Cell * pResult = find (env, c);
if (! pResult || ! CDR (pResult))
error ("unbound variable ", c->SymbolValue ()->key);
Cell * res = CDR (pResult);
if (res->type () == Cell::Magic)
return res->cd.m->get_f (this, res->cd.vp);
else
return res;
}
void Context::set (Cell * env, Cell * var, Cell * value)
{
Cell * target = find (env, var);
Cell * d;
psymbol s = var->SymbolValue ();
if (! target)
error ("unbound variable ", s->key);
if ((d = cdr (target)) && d->type () == Cell::Magic)
d->cd.m->set_f (this, d->cd.vp, value);
else
Cell::setcdr (target, value);
}
Cell * Context::find (Cell * env, Cell * c)
{
int e_count = 0;
int b_count = 0;
psymbol s = c->SymbolValue ();
Cell * e = env;
Cell * val;
if (c->flag (Cell::QUICK))
{
int e_skip = c->e_skip ();
int b_skip = c->b_skip ();
if (e_skip == Cell::GLOBAL_ENV)
{
// Target environment is root envt.
e = root_envt;
e_count = e_skip;
}
else
{
// Skip the indicated number of environments.
for (e_count = 0; (e != nil) && (e_count < e_skip); ++e_count)
e = CDR (e);
}
cellvector * v = CAR (e)->VectorValue ();
if ( b_skip < 0
|| b_skip >= v->size ()
|| e_skip != e_count
)
{
printf ("b=%d, e=%d, ec=%d, vs=%d\n", b_skip, e_skip, e_count,
v->size ());
error ("internal error: invalid lexical address: ", s->key);
}
// Go directly to the binding.
return v->get (b_skip);
}
// Consider each environment in the enclosure chain
// in turn, counting them as we go.
for (e_count = 0; e != nil; ++e_count, e = CDR (e))
{
cellvector * v = CAR (e)->VectorValue ();
// Check the current environment.
for (b_count = 0; b_count < v->size (); ++b_count)
if (CAR (v->get (b_count))->SymbolValue () == s)
{
if (e == root_envt)
{
// Top-level environment. Due to nested defines,
// this turns out to be a special case.
e_count = -1;
}
quicken (c, e_count, b_count);
return v->get (b_count);
}
}
// Can the OS magically supply a value??
if ((val = OS::undef (this, s->truename)))
{
// Yes! The OS has produced a value. We cache
// it in the outermost environment, as if it
// had been established there with (define).
Cell * os_binding = cons (c, val);
car (root_envt)->VectorValue ()->push (os_binding);
return os_binding;
}
// Failure.
return 0;
}
void Context::quicken (Cell * c, int e_count, int b_count)
{
// For global symbols, we have 16 bits of b_skip to work with;
// only 8 if the symbol is not in the global environment.
// XXX: these are magic numbers and should be coordinated with
// the .h file.
if (e_count >= 0)
{
if (e_count > 254 || b_count > 254)
return;
}
else if (b_count > 65534)
return;
c->set_lexaddr (e_count, b_count);
}
Cell * Context::make_procedure (Cell * e, Cell * body, Cell * arglist)
{
Cell * c = alloc (Cell::Lambda);
// XXX cellvector * cv = new cellvector (3);
cellvector* cv = cellvector::alloc(3);
c->cd.cv = cv;
c->flag (Cell::VREF, true);
cv->set (0, e);
cv->set (1, body);
cv->set (2, arglist);
return c;
}
Cell * Context::make_macro (Cell * e, Cell * body, Cell * arglist)
{
Cell * c = make_procedure (e, body, arglist);
c->flag (Cell::MACRO, true);
return c;
}
Cell * Context::make_promise (Cell * e, Cell * body)
{
Cell * c = alloc (Cell::Promise);
cellvector *cv = cellvector::alloc(1);
// Now it may seem odd to allocate a vector of one element to
// store the content of the promise. But, our garbage collector
// only knows how to traverse two kinds of entities: (1) conses,
// consisting of a car and cdr and (2) vectors. Since we're not a
// cons, but contain a reference to either the procedure that will
// compute the promise or that procedure's memoized value, we must
// store that thing in a unit vector.
c->cd.cv = cv;
c->flag (Cell::VREF, true);
gc_protect (c);
cv->set (0, make_procedure (e, body, nil));
gc_unprotect ();
return c;
}
Cell * Context::make_list1 (Cell * e1)
{
return cons (e1, nil);
}
Cell * Context::make_list2 (Cell * e1, Cell * e2)
{
return cons (e1, make_list1 (e2));
}
Cell * Context::make_list3 (Cell * e1, Cell * e2, Cell * e3)
{
return cons (e1, make_list2 (e2, e3));
}
Cell * Context::make_continuation ()
{
Cell * c = alloc (Cell::Cont);
// Allocate a cellvector to hold the continutation (saved
// machine stack).
int msize = m_stack.size ();
cellvector* cv = cellvector::alloc(msize);
c->flag (Cell::VREF, true);
c->cd.cv = cv;
for (int ix = 0; ix < msize; ++ix)
cv->set (ix, m_stack [ix]);
return c;
}
void Context::load_continuation (Cell * cont)
{
cont->typecheck (Cell::Cont);
cellvector * cv = cont->cd.cv;
int msize = cv->size ();
m_stack.clear();
for (int ix = 0; ix < msize; ++ix)
save (cv->get (ix));
}
class InterpreterExt : SchemeExtension
{
public:
InterpreterExt () {
Register (this);
}
virtual void Install (Context * ctx, Cell * envt) {
// Hook in the function pointer to the interpreter's evaluation loop.
ctx->interp_eval = &Context::interp_evaluator;
// Builtin Procedures (treated directly by `eval')
static struct
{
const char * name; // name of procedure or form.
bool macro; // macro arguments are left unevaluated.
} builtin [] = {
{ "and", true },
{ "apply", false },
{ "begin", true },
{ "call-with-current-continuation", false },
{ "call-with-input-file", false },
{ "call-with-output-file", false },
{ "case", true },
{ "cond", true },
{ "define", true },
{ "defmacro", true },
{ "delay", true },
{ "do", true },
{ "eval", false },
{ "for-each", false },
{ "force", false },
{ "if", true },
{ "lambda", true },
{ "let", true },
{ "let*", true },
{ "letrec", true },
{ "load", false },
{ "map", false },
{ "or", true },
{ "quasiquote", true },
{ "quote", true },
{ "set!", true },
{ "time", false },
{ "with-input-from-file", false },
{ "with-output-to-file", false },
};
for (unsigned int ix = 0; ix < sizeof (builtin) / sizeof (*builtin); ++ix)
{
psymbol ps = intern (builtin [ix].name);
Cell * b = ctx->make_builtin (ps);
ctx->set_var (envt, ps, b);
if (builtin [ix].macro)
b->flag (Cell::MACRO, true);
}
}
};
static InterpreterExt interpreter_ext;
Reference in New Issue View Git Blame Copy Permalink