[Guile-commits] 02/05: Add intrinsics for error conditions (wrong num args etc)

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 6eb473514966c4cbb61bbbf27bde5c9ca5fed850
Author: Andy Wingo <address@hidden>
Date:   Wed Jun 27 09:19:36 2018 +0200

    Add intrinsics for error conditions (wrong num args etc)
    
    * libguile/intrinsics.c (error_wrong_num_args, error_no_values)
      (error_not_enough_values, error_wrong_number_of_values): New
      intrinsics.
    * libguile/intrinsics.h: Add new intrinsics.
    * libguile/vm-engine.c: Signal errors using the new intrinsics.
    * libguile/vm.c (vm_error): Remove, now that it's unused.
      (vm_error_bad_instruction): Abort instead of throwing an exception.
      If we get a bad instruction, nothing good will ever happen!
      (compose_continuation): Use wrong-type-arg for unrewindable
      continuations.
      (scm_bootstrap_vm): No need to make "vm-run" or "vm-error" symbols.
---
 libguile/intrinsics.c | 30 ++++++++++++++++++++++++++++++
 libguile/intrinsics.h |  7 +++++++
 libguile/vm-engine.c  | 15 ++++++++-------
 libguile/vm.c         | 48 +++---------------------------------------------
 4 files changed, 48 insertions(+), 52 deletions(-)

diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 9094134..73ad2b0 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 cc175fe..6526abc 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 18ae5a6..0cf1a0c 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 bb6c32a..9e12274 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");