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 (); } }