diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index 90941341f..73ad2b0ce 100644 --- a/libguile/intrinsics.c +++ b/libguile/intrinsics.c @@ -308,6 +308,32 @@ throw_with_value_and_data (SCM val, SCM key_subr_and_message) throw_ (key, scm_list_4 (subr, message, args, data)); } +static void error_no_values (void) SCM_NORETURN; +static void error_not_enough_values (void) SCM_NORETURN; +static void error_wrong_number_of_values (uint32_t expected) SCM_NORETURN; + +static void +error_no_values (void) +{ + scm_misc_error (NULL, "Zero values returned to single-valued continuation", + SCM_EOL); +} + +static void +error_not_enough_values (void) +{ + scm_misc_error (NULL, "Too few values returned to continuation", SCM_EOL); +} + +static void +error_wrong_number_of_values (uint32_t expected) +{ + scm_misc_error (NULL, + "Wrong number of values returned to continuation (expected ~a)", + scm_list_1 (scm_from_uint32 (expected))); +} + + void scm_bootstrap_intrinsics (void) { @@ -356,6 +382,10 @@ scm_bootstrap_intrinsics (void) scm_vm_intrinsics.throw_ = throw_; scm_vm_intrinsics.throw_with_value = throw_with_value; scm_vm_intrinsics.throw_with_value_and_data = throw_with_value_and_data; + scm_vm_intrinsics.error_wrong_num_args = scm_wrong_num_args; + scm_vm_intrinsics.error_no_values = error_no_values; + scm_vm_intrinsics.error_not_enough_values = error_not_enough_values; + scm_vm_intrinsics.error_wrong_number_of_values = error_wrong_number_of_values; scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_intrinsics", diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index cc175fef6..6526abcf9 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -59,6 +59,9 @@ typedef void (*scm_t_thread_regs_scm_intrinsic) (scm_thread*, jmp_buf*, SCM); typedef int (*scm_t_int_from_scm_intrinsic) (SCM); typedef void (*scm_t_thread_regs_intrinsic) (scm_thread*, jmp_buf*); typedef void (*scm_t_scm_scm_noreturn_intrinsic) (SCM, SCM) SCM_NORETURN; +typedef void (*scm_t_noreturn_intrinsic) (void) SCM_NORETURN; +typedef void (*scm_t_scm_noreturn_intrinsic) (SCM) SCM_NORETURN; +typedef void (*scm_t_u32_noreturn_intrinsic) (uint32_t) SCM_NORETURN; #define SCM_FOR_ALL_VM_INTRINSICS(M) \ M(scm_from_scm_scm, add, "add", ADD) \ @@ -117,6 +120,10 @@ typedef void (*scm_t_scm_scm_noreturn_intrinsic) (SCM, SCM) SCM_NORETURN; M(scm_scm_noreturn, throw_, "throw", THROW) \ M(scm_scm_noreturn, throw_with_value, "throw/value", THROW_WITH_VALUE) \ M(scm_scm_noreturn, throw_with_value_and_data, "throw/value+data", THROW_WITH_VALUE_AND_DATA) \ + M(scm_noreturn, error_wrong_num_args, "wrong-num-args", ERROR_WRONG_NUM_ARGS) \ + M(noreturn, error_no_values, "no-values", ERROR_NO_VALUES) \ + M(noreturn, error_not_enough_values, "not-enough-values", ERROR_NOT_ENOUGH_VALUES) \ + M(u32_noreturn, error_wrong_number_of_values, "wrong-number-of-values", ERROR_WRONG_NUMBER_OF_VALUES) \ /* 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 18ae5a638..0cf1a0c30 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -521,7 +521,8 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) uint32_t nlocals; UNPACK_12_12 (op, dst, proc); UNPACK_24 (ip[1], nlocals); - VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1, vm_error_no_values ()); + VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1, + scm_vm_intrinsics.error_no_values ()); FP_SET (dst, FP_REF (proc + 1)); RESET_FRAME (nlocals); NEXT (2); @@ -542,10 +543,10 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) UNPACK_24 (ip[1], nvalues); if (ip[1] & 0x1) VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues, - vm_error_not_enough_values ()); + scm_vm_intrinsics.error_not_enough_values ()); else VM_ASSERT (FRAME_LOCALS_COUNT () == proc + 1 + nvalues, - vm_error_wrong_number_of_values (nvalues)); + scm_vm_intrinsics.error_wrong_number_of_values (nvalues)); NEXT (2); } @@ -907,7 +908,7 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) uint32_t expected; UNPACK_24 (op, expected); VM_ASSERT (FRAME_LOCALS_COUNT () == expected, - vm_error_wrong_num_args (FP_REF (0))); + scm_vm_intrinsics.error_wrong_num_args (FP_REF (0))); NEXT (1); } VM_DEFINE_OP (22, assert_nargs_ge, "assert-nargs-ge", OP1 (X8_C24)) @@ -915,7 +916,7 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) uint32_t expected; UNPACK_24 (op, expected); VM_ASSERT (FRAME_LOCALS_COUNT () >= expected, - vm_error_wrong_num_args (FP_REF (0))); + scm_vm_intrinsics.error_wrong_num_args (FP_REF (0))); NEXT (1); } VM_DEFINE_OP (23, assert_nargs_le, "assert-nargs-le", OP1 (X8_C24)) @@ -923,7 +924,7 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) uint32_t expected; UNPACK_24 (op, expected); VM_ASSERT (FRAME_LOCALS_COUNT () <= expected, - vm_error_wrong_num_args (FP_REF (0))); + scm_vm_intrinsics.error_wrong_num_args (FP_REF (0))); NEXT (1); } @@ -1023,7 +1024,7 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume) uint16_t expected, nlocals; UNPACK_12_12 (op, expected, nlocals); VM_ASSERT (FRAME_LOCALS_COUNT () == expected, - vm_error_wrong_num_args (FP_REF (0))); + scm_vm_intrinsics.error_wrong_num_args (FP_REF (0))); ALLOC_FRAME (expected + nlocals); while (nlocals--) SP_SET (nlocals, SCM_UNDEFINED); diff --git a/libguile/vm.c b/libguile/vm.c index bb6c32a74..9e1227472 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -84,8 +84,6 @@ static int vm_default_engine = SCM_VM_REGULAR_ENGINE; /* Unfortunately we can't snarf these: snarfed things are only loaded up from (system vm vm), which might not be loaded before an error happens. */ -static SCM sym_vm_run; -static SCM sym_vm_error; static SCM sym_keyword_argument_error; static SCM sym_regular; static SCM sym_debug; @@ -309,32 +307,14 @@ static void vm_dispatch_abort_hook (struct scm_vm *vp) */ -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_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; -static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; -static void vm_error_wrong_number_of_values (uint32_t expected) SCM_NORETURN SCM_NOINLINE; - -static void -vm_error (const char *msg, SCM arg) -{ - scm_throw (sym_vm_error, - scm_list_3 (sym_vm_run, scm_from_latin1_string (msg), - SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg))); -} static void vm_error_bad_instruction (uint32_t inst) { - vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst)); -} - -static void -vm_error_wrong_num_args (SCM proc) -{ - scm_wrong_num_args (proc); + fprintf (stderr, "VM: Bad instruction: %x\n", inst); + abort (); } static void @@ -344,26 +324,6 @@ vm_error_wrong_type_apply (SCM proc) scm_list_1 (proc), scm_list_1 (proc)); } -static void -vm_error_no_values (void) -{ - vm_error ("Zero values returned to single-valued continuation", - SCM_UNDEFINED); -} - -static void -vm_error_not_enough_values (void) -{ - vm_error ("Too few values returned to continuation", SCM_UNDEFINED); -} - -static void -vm_error_wrong_number_of_values (uint32_t expected) -{ - vm_error ("Wrong number of values returned to continuation (expected ~a)", - scm_from_uint32 (expected)); -} - @@ -1201,7 +1161,7 @@ compose_continuation (scm_thread *thread, jmp_buf *registers, SCM cont) ptrdiff_t old_fp_offset; if (SCM_UNLIKELY (! SCM_VM_CONT_REWINDABLE_P (cont))) - vm_error ("Unrewindable partial continuation", cont); + scm_wrong_type_arg_msg (NULL, 0, cont, "resumable continuation"); nargs = frame_locals_count (thread) - 1; args = alloca (nargs * sizeof (*args)); @@ -1721,8 +1681,6 @@ scm_bootstrap_vm (void) scm_vm_intrinsics.rest_arg_length = rest_arg_length; scm_vm_intrinsics.abort_to_prompt = abort_to_prompt; - sym_vm_run = scm_from_latin1_symbol ("vm-run"); - sym_vm_error = scm_from_latin1_symbol ("vm-error"); sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error"); sym_regular = scm_from_latin1_symbol ("regular"); sym_debug = scm_from_latin1_symbol ("debug");