static const scm_t_uint32*
get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest)
{
if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
return SUBR_STUB_CODE (nreq, nopt, rest);
}
static inline scm_t_bits *
push_dynstack_entry (scm_t_dynstack *dynstack,
scm_t_dynstack_item_type type,
scm_t_bits flags, size_t len)
{
if (SCM_UNLIKELY (!SCM_DYNSTACK_HAS_SPACE (dynstack, len)))
dynstack_ensure_space (dynstack, len);
return push_dynstack_entry_unchecked (dynstack, type, flags, len);
}
void
scm_dynstack_push_dynamic_state (scm_t_dynstack *dynstack, SCM state,
scm_t_dynamic_state *dynamic_state)
{
scm_t_bits *words;
SCM state_box;
if (SCM_UNLIKELY (scm_is_false (scm_dynamic_state_p (state))))
scm_wrong_type_arg ("with-dynamic-state", 0, state);
state_box = scm_make_variable (scm_set_current_dynamic_state (state));
words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNAMIC_STATE, 0,
DYNAMIC_STATE_WORDS);
words[0] = SCM_UNPACK (state_box);
}
static inline scm_t_bits
dynstack_pop (scm_t_dynstack *dynstack, scm_t_bits **words)
{
scm_t_bits *prev = SCM_DYNSTACK_PREV (dynstack->top);
scm_t_bits tag;
if (SCM_UNLIKELY (!prev))
abort ();
SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, 0);
dynstack->top = prev;
tag = SCM_DYNSTACK_TAG (dynstack->top);
SCM_DYNSTACK_SET_TAG (dynstack->top, 0);
*words = dynstack->top;
return tag;
}
/* The fluid is stored on the stack, but the value has to be stored on the heap,
so that all continuations that capture this dynamic scope capture the same
binding. */
void
scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value,
scm_t_dynamic_state *dynamic_state)
{
scm_t_bits *words;
SCM value_box;
if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)))
scm_wrong_type_arg ("with-fluid*", 0, fluid);
value_box = scm_make_variable (value);
words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_WITH_FLUID, 0,
WITH_FLUID_WORDS);
words[0] = SCM_UNPACK (fluid);
words[1] = SCM_UNPACK (value_box);
/* Go ahead and swap them. */
scm_swap_fluid (fluid, value_box, dynamic_state);
}
SCM
scm_apply_0 (SCM proc, SCM args)
{
SCM *argv;
int i, nargs;
nargs = scm_ilength (args);
if (SCM_UNLIKELY (nargs < 0))
scm_wrong_type_arg_msg ("apply", 2, args, "list");
/* FIXME: Use vm_builtin_apply instead of alloca. */
argv = alloca (nargs * sizeof(SCM));
for (i = 0; i < nargs; i++)
{
argv[i] = SCM_CAR (args);
args = SCM_CDR (args);
}
return scm_call_n (proc, argv, nargs);
}
static SCM
eval (SCM x, SCM env)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
unsigned int argc;
loop:
SCM_TICK;
if (!SCM_MEMOIZED_P (x))
abort ();
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_MEMOIZED_TAG (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 = CAPTURE_ENV (env);
for (; scm_is_pair (inits); inits = CDR (inits))
new_env = scm_cons (EVAL1 (CAR (inits), env),
new_env);
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_LAMBDA:
RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
case SCM_M_QUOTE:
return mx;
case SCM_M_DEFINE:
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
case SCM_M_DYNWIND:
{
SCM in, out, res;
scm_i_thread *t = SCM_I_CURRENT_THREAD;
in = EVAL1 (CAR (mx), env);
out = EVAL1 (CDDR (mx), env);
scm_call_0 (in);
scm_dynstack_push_dynwind (&t->dynstack, in, out);
res = eval (CADR (mx), env);
scm_dynstack_pop (&t->dynstack);
scm_call_0 (out);
return res;
}
case SCM_M_WITH_FLUIDS:
{
long i, len;
SCM *fluidv, *valuesv, walk, res;
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
len = scm_ilength (CAR (mx));
fluidv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
fluidv[i] = EVAL1 (CAR (walk), env);
valuesv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
valuesv[i] = EVAL1 (CAR (walk), env);
scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv,
thread->dynamic_state);
res = eval (CDDR (mx), env);
scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return res;
}
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_call_with_vm (scm_the_vm (), proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
argc = SCM_I_INUM (CADR (mx));
mx = CDDR (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_c_vm_run (scm_the_vm (), 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_with_vm (scm_the_vm (), producer, SCM_EOL);
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:
{
int n;
SCM ret;
for (n = SCM_I_INUM (mx); n; n--)
env = CDR (env);
ret = CAR (env);
if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
/* we don't know what variable, though, because we don't have its
name */
error_used_before_defined ();
return ret;
}
case SCM_M_LEXICAL_SET:
{
int n;
SCM val = EVAL1 (CDR (mx), env);
for (n = SCM_I_INUM (CAR (mx)); n; n--)
env = CDR (env);
SCM_SETCAR (env, val);
return SCM_UNSPECIFIED;
}
case SCM_M_TOPLEVEL_REF:
if (SCM_VARIABLEP (mx))
return SCM_VARIABLE_REF (mx);
else
{
while (scm_is_pair (env))
env = CDR (env);
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
}
case SCM_M_TOPLEVEL_SET:
{
SCM var = CAR (mx);
SCM val = EVAL1 (CDR (mx), env);
if (SCM_VARIABLEP (var))
{
SCM_VARIABLE_SET (var, val);
return SCM_UNSPECIFIED;
}
else
{
while (scm_is_pair (env))
env = CDR (env);
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
val);
return SCM_UNSPECIFIED;
}
}
case SCM_M_MODULE_REF:
if (SCM_VARIABLEP (mx))
return SCM_VARIABLE_REF (mx);
else
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, SCM_BOOL_F));
case SCM_M_MODULE_SET:
if (SCM_VARIABLEP (CDR (mx)))
{
SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
else
{
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, SCM_BOOL_F),
EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
case SCM_M_PROMPT:
{
SCM vm, k, res;
scm_i_jmp_buf registers;
/* We need the handler after nonlocal return to the setjmp, so
make sure it is volatile. */
volatile SCM handler;
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
vm = scm_the_vm ();
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
k,
SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp,
SCM_VM_DATA (vm)->ip,
®isters);
if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
proc = handler;
args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
goto apply_proc;
}
res = eval (CADR (mx), env);
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
default:
abort ();
}
}
