static void
env_link_add_flat_var (SCM env_link, SCM var, SCM pos)
{
SCM vars = env_link_vars (env_link);
if (scm_is_false (scm_assq (var, vars)))
scm_set_cdr_x (env_link, scm_acons (var, pos, vars));
}
SCM
scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
{
if (!SCM_UNBNDP (filename))
{
SCM old_alist = alist;
/*
have to extract the acons, and operate on that, for
thread safety.
*/
SCM last_acons = SCM_CDR (scm_last_alist_filename);
if (scm_is_null (old_alist)
&& scm_is_eq (SCM_CDAR (last_acons), filename))
{
alist = last_acons;
}
else
{
alist = scm_acons (scm_sym_filename, filename, alist);
if (scm_is_null (old_alist))
scm_set_cdr_x (scm_last_alist_filename, alist);
}
}
SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
SRCPROPMAKPOS (line, col),
SCM_UNPACK (copy),
SCM_UNPACK (alist));
}
static SCM
eval (SCM x, SCM env)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
unsigned int argc;
loop:
SCM_TICK;
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_I_INUM (SCM_CAR (x)))
{
case SCM_M_SEQ:
eval (CAR (mx), env);
x = CDR (mx);
goto loop;
case SCM_M_IF:
if (scm_is_true (EVAL1 (CAR (mx), env)))
x = CADR (mx);
else
x = CDDR (mx);
goto loop;
case SCM_M_LET:
{
SCM inits = CAR (mx);
SCM new_env;
int i;
new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
for (i = 0; i < VECTOR_LENGTH (inits); i++)
env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_LAMBDA:
RETURN_BOOT_CLOSURE (mx, env);
case SCM_M_CAPTURE_ENV:
{
SCM locs = CAR (mx);
SCM new_env;
int i;
new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
for (i = 0; i < VECTOR_LENGTH (locs); i++)
{
SCM loc = VECTOR_REF (locs, i);
int depth, width;
depth = SCM_I_INUM (CAR (loc));
width = SCM_I_INUM (CDR (loc));
env_set (new_env, 0, i, env_ref (env, depth, width));
}
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_QUOTE:
return mx;
case SCM_M_CAPTURE_MODULE:
return eval (mx, scm_current_module ());
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
/* Evaluate the argument holding the list of arguments */
args = EVAL1 (CADR (mx), env);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
}
else
return scm_apply_0 (proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
argc = scm_ilength (CDR (mx));
mx = CDR (mx);
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
}
else
{
SCM *argv;
unsigned int i;
argv = alloca (argc * sizeof (SCM));
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = EVAL1 (CAR (mx), env);
return scm_call_n (proc, argv, argc);
}
case SCM_M_CONT:
return scm_i_call_with_current_continuation (EVAL1 (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
SCM producer;
SCM v;
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
v = scm_call_0 (producer);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
args = scm_list_1 (v);
goto apply_proc;
}
case SCM_M_LEXICAL_REF:
{
SCM pos;
int depth, width;
pos = mx;
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
return env_ref (env, depth, width);
}
case SCM_M_LEXICAL_SET:
{
SCM pos;
int depth, width;
SCM val = EVAL1 (CDR (mx), env);
pos = CAR (mx);
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
env_set (env, depth, width, val);
return SCM_UNSPECIFIED;
}
case SCM_M_BOX_REF:
{
SCM box = mx;
return scm_variable_ref (EVAL1 (box, env));
}
case SCM_M_BOX_SET:
{
SCM box = CAR (mx), val = CDR (mx);
return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
}
case SCM_M_RESOLVE:
if (SCM_VARIABLEP (mx))
return mx;
else
{
SCM var;
var = scm_sys_resolve_variable (mx, env_tail (env));
scm_set_cdr_x (x, var);
return var;
}
case SCM_M_CALL_WITH_PROMPT:
{
struct scm_vm *vp;
SCM k, handler, res;
scm_i_jmp_buf registers;
scm_t_ptrdiff saved_stack_depth;
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
vp = scm_the_vm ();
saved_stack_depth = vp->stack_top - vp->sp;
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
k,
vp->stack_top - vp->fp,
saved_stack_depth,
vp->ip,
®isters);
if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
scm_gc_after_nonlocal_exit ();
proc = handler;
args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);
goto apply_proc;
}
res = scm_call_0 (eval (CADR (mx), env));
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
default:
abort ();
}
}
