diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index 2022138c2..894db5abb 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -56,6 +56,7 @@ typedef SCM (*scm_t_scm_from_scm_scm_scmp_sp_intrinsic) (SCM, SCM, SCM*, typedef void (*scm_t_thread_scm_noreturn_intrinsic) (scm_thread*, SCM) SCM_NORETURN; typedef SCM (*scm_t_scm_from_thread_regs_intrinsic) (scm_thread*, jmp_buf*); typedef void (*scm_t_thread_regs_scm_intrinsic) (scm_thread*, jmp_buf*, SCM); +typedef int (*scm_t_int_from_scm_intrinsic) (SCM); #define SCM_FOR_ALL_VM_INTRINSICS(M) \ M(scm_from_scm_scm, add, "add", ADD) \ @@ -109,6 +110,7 @@ typedef void (*scm_t_thread_regs_scm_intrinsic) (scm_thread*, jmp_buf*, SCM); M(thread_scm_noreturn, reinstate_continuation_x, "reinstate-continuation!", REINSTATE_CONTINUATION_X) \ M(scm_from_thread_regs, capture_continuation, "capture-continuation", CAPTURE_CONTINUATION) \ M(thread_regs_scm, compose_continuation, "compose-continuation", COMPOSE_CONTINUATION) \ + M(int_from_scm, rest_arg_length, "rest-arg-length", REST_ARG_LENGTH) \ /* Add new intrinsics here; also update scm_bootstrap_intrinsics. */ enum scm_vm_intrinsic diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index a11d8cd40..9ff471100 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -703,7 +703,7 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) /* tail-apply _:24 * - * Tail-apply the procedure in local slot 0 to the rest of the + * Tail-apply the procedure in local slot 1 to the rest of the * arguments. This instruction is part of the implementation of * `apply', and is not generated by the compiler. */ @@ -717,9 +717,9 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) VM_ASSERT (nlocals >= 3, abort ()); list_idx = nlocals - 1; list = FP_REF (list_idx); - list_len = scm_ilength (list); - VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list)); + SYNC_IP (); + list_len = scm_vm_intrinsics.rest_arg_length (list); nlocals = nlocals - 2 + list_len; ALLOC_FRAME (nlocals); diff --git a/libguile/vm.c b/libguile/vm.c index fdf97276d..58badfa91 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -334,7 +334,6 @@ static void vm_throw_with_value_and_data (SCM val, SCM key_subr_and_message) SCM static void vm_error (const char *msg, SCM arg) SCM_NORETURN; static void vm_error_bad_instruction (uint32_t inst) SCM_NORETURN SCM_NOINLINE; -static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; @@ -390,13 +389,6 @@ vm_error_bad_instruction (uint32_t inst) vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst)); } -static void -vm_error_apply_to_non_list (SCM x) -{ - scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S", - scm_list_1 (x), scm_list_1 (x)); -} - static void vm_error_wrong_num_args (SCM proc) { @@ -1310,6 +1302,18 @@ compose_continuation (scm_thread *thread, jmp_buf *registers, SCM cont) } } +static int +rest_arg_length (SCM x) +{ + int len = scm_ilength (x); + + if (SCM_UNLIKELY (len < 0)) + scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S", + scm_list_1 (x), scm_list_1 (x)); + + return len; +} + SCM scm_call_n (SCM proc, SCM *argv, size_t nargs) { @@ -1656,6 +1660,7 @@ scm_bootstrap_vm (void) scm_vm_intrinsics.reinstate_continuation_x = reinstate_continuation_x; scm_vm_intrinsics.capture_continuation = capture_continuation; scm_vm_intrinsics.compose_continuation = compose_continuation; + scm_vm_intrinsics.rest_arg_length = rest_arg_length; sym_vm_run = scm_from_latin1_symbol ("vm-run"); sym_vm_error = scm_from_latin1_symbol ("vm-error");