guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-244-g4d497b6


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-244-g4d497b6
Date: Tue, 08 May 2012 20:34:01 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=4d497b629b73afda35ba409c3dcbfb665fe41dde

The branch, master has been updated
       via  4d497b629b73afda35ba409c3dcbfb665fe41dde (commit)
       via  53bdfcf03418c4709127140d64f12ede970c174b (commit)
       via  7dbc03498a763ca6a45e26aabfa74e8c317b55bf (commit)
       via  c15defef7f1de408f35066d2f2883c110724b2f9 (commit)
      from  4105f688e33e592534b809c048451d94db82681a (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 4d497b629b73afda35ba409c3dcbfb665fe41dde
Merge: 4105f68 53bdfcf
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 30 21:34:58 2012 +0200

    Merge remote-tracking branch 'origin/stable-2.0'
    
    Conflicts:
        libguile/vm-engine.c
        libguile/vm-i-system.c

-----------------------------------------------------------------------

Summary of changes:
 libguile/_scm.h        |    8 ++
 libguile/values.c      |   20 ++++-
 libguile/values.h      |    3 +-
 libguile/vm-engine.c   |  175 ++------------------------------------
 libguile/vm-engine.h   |   42 ++++-----
 libguile/vm-i-loader.c |    9 +--
 libguile/vm-i-scheme.c |   26 +-----
 libguile/vm-i-system.c |  151 +++++++++++++++-------------------
 libguile/vm.c          |  219 ++++++++++++++++++++++++++++++++++++++++++++++++
 9 files changed, 345 insertions(+), 308 deletions(-)

diff --git a/libguile/_scm.h b/libguile/_scm.h
index c3384be..7dd188d 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -247,6 +247,14 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int);
 
 
 
+#if (defined __GNUC__)
+# define SCM_NOINLINE __attribute__ ((__noinline__))
+#else
+# define SCM_NOINLINE /* noinline */
+#endif
+
+
+
 /* The endianness marker in objcode.  */
 #ifdef WORDS_BIGENDIAN
 # define SCM_OBJCODE_ENDIANNESS "BE"
diff --git a/libguile/values.c b/libguile/values.c
index fdd9359..55577f2 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011 Free Software Foundation, 
Inc.
+/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011, 2012 Free Software 
Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -108,14 +108,26 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1,
   if (n == 1)
     result = SCM_CAR (args);
   else
-    {
-      result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args));
-    }
+    result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args));
 
   return result;
 }
 #undef FUNC_NAME
 
+SCM
+scm_c_values (SCM *base, size_t nvalues)
+{
+  SCM ret, *walk;
+
+  if (nvalues == 1)
+    return *base;
+
+  for (ret = SCM_EOL, walk = base + nvalues - 1; walk >= base; walk--)
+    ret = scm_cons (*walk, ret);
+
+  return scm_values (ret);
+}
+
 void
 scm_init_values (void)
 {
diff --git a/libguile/values.h b/libguile/values.h
index 5f79855..f11c9d9 100644
--- a/libguile/values.h
+++ b/libguile/values.h
@@ -3,7 +3,7 @@
 #ifndef SCM_VALUES_H
 #define SCM_VALUES_H
 
-/* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2000,2001, 2006, 2008, 2012 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -33,6 +33,7 @@ SCM_API SCM scm_values_vtable;
 SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2);
 
 SCM_API SCM scm_values (SCM args);
+SCM_API SCM scm_c_values (SCM *base, size_t nvalues);
 SCM_API SCM scm_c_value_ref (SCM values, size_t idx);
 SCM_INTERNAL void scm_init_values (void);
 
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 1d16ec4..4b6c98a 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -56,9 +56,6 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
 
   /* Internal variables */
   int nvalues = 0;
-  const char *func_name = NULL;         /* used for error reporting */
-  SCM finish_args;                      /* used both for returns: both in error
-                                           and normal situations */
   scm_i_jmp_buf registers;              /* used for prompts */
 
 #ifdef HAVE_LABELS_AS_VALUES
@@ -128,8 +125,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
     PUSH (SCM_PACK (0)); /* mvra */
     PUSH (SCM_PACK (0)); /* ra */
     PUSH (prog);
-    if (SCM_UNLIKELY (sp + nargs >= stack_limit))
-      goto vm_error_too_many_args;
+    VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
     while (nargs--)
       PUSH (*argv++);
   }
@@ -153,170 +149,15 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
   }
 #endif
 
-  
- vm_done:
-  SYNC_ALL ();
-  return finish_args;
-
-  /* Errors */
-  {
-    SCM err_msg;
-
-    /* FIXME: need to sync regs before allocating anything, in each case. */
-
-  vm_error_bad_instruction:
-    err_msg  = scm_from_latin1_string ("VM: Bad instruction: ~s");
-    finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
-    goto vm_error;
-
-  vm_error_unbound:
-    /* FINISH_ARGS should be the name of the unbound variable.  */
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Unbound variable: ~s");
-    scm_error_scm (scm_misc_error_key, program, err_msg,
-                   scm_list_1 (finish_args), SCM_BOOL_F);
-    goto vm_error;
-
-  vm_error_unbound_fluid:
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Unbound fluid: ~s");
-    scm_error_scm (scm_misc_error_key, program, err_msg,
-                   scm_list_1 (finish_args), SCM_BOOL_F);
-    goto vm_error;
-
-  vm_error_not_a_variable:
-    SYNC_ALL ();
-    scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
-               scm_list_1 (finish_args), scm_list_1 (finish_args));
-    goto vm_error;
-
-  vm_error_apply_to_non_list:
-    SYNC_ALL ();
-    scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
-               scm_list_1 (finish_args), scm_list_1 (finish_args));
-    goto vm_error;
-
-  vm_error_kwargs_length_not_even:
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Odd length of keyword argument list");
-    scm_error_scm (sym_keyword_argument_error, program, err_msg,
-                   SCM_EOL, SCM_BOOL_F);
-
-  vm_error_kwargs_invalid_keyword:
-    /* FIXME say which one it was */
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Invalid keyword");
-    scm_error_scm (sym_keyword_argument_error, program, err_msg,
-                   SCM_EOL, SCM_BOOL_F);
-
-  vm_error_kwargs_unrecognized_keyword:
-    /* FIXME say which one it was */
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Unrecognized keyword");
-    scm_error_scm (sym_keyword_argument_error, program, err_msg,
-                   SCM_EOL, SCM_BOOL_F);
-
-  vm_error_too_many_args:
-    err_msg  = scm_from_latin1_string ("VM: Too many arguments");
-    finish_args = scm_list_1 (scm_from_int (nargs));
-    goto vm_error;
-
-  vm_error_wrong_num_args:
-    /* nargs and program are valid */
-    SYNC_ALL ();
-    scm_wrong_num_args (program);
-    /* shouldn't get here */
-    goto vm_error;
-
-  vm_error_wrong_type_apply:
-    SYNC_ALL ();
-    scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
-               scm_list_1 (program), scm_list_1 (program));
-    goto vm_error;
-
-  vm_error_stack_overflow:
-    err_msg  = scm_from_latin1_string ("VM: Stack overflow");
-    finish_args = SCM_EOL;
-    if (stack_limit < vp->stack_base + vp->stack_size)
-      /* There are VM_STACK_RESERVE_SIZE bytes left.  Make them available so
-        that `throw' below can run on this VM.  */
-      vp->stack_limit = vp->stack_base + vp->stack_size;
-    goto vm_error;
-
-  vm_error_stack_underflow:
-    err_msg  = scm_from_latin1_string ("VM: Stack underflow");
-    finish_args = SCM_EOL;
-    goto vm_error;
-
-  vm_error_improper_list:
-    err_msg  = scm_from_latin1_string ("Expected a proper list, but got object 
with tail ~s");
-    goto vm_error;
-
-  vm_error_not_a_pair:
-    SYNC_ALL ();
-    scm_wrong_type_arg_msg (func_name, 1, finish_args, "pair");
-    /* shouldn't get here */
-    goto vm_error;
-
-  vm_error_not_a_bytevector:
-    SYNC_ALL ();
-    scm_wrong_type_arg_msg (func_name, 1, finish_args, "bytevector");
-    /* shouldn't get here */
-    goto vm_error;
-
-  vm_error_not_a_struct:
-    SYNC_ALL ();
-    scm_wrong_type_arg_msg (func_name, 1, finish_args, "struct");
-    /* shouldn't get here */
-    goto vm_error;
-
-  vm_error_no_values:
-    err_msg  = scm_from_latin1_string ("Zero values returned to single-valued 
continuation");
-    finish_args = SCM_EOL;
-    goto vm_error;
-
-  vm_error_not_enough_values:
-    err_msg  = scm_from_latin1_string ("Too few values returned to 
continuation");
-    finish_args = SCM_EOL;
-    goto vm_error;
-
-  vm_error_continuation_not_rewindable:
-    err_msg  = scm_from_latin1_string ("Unrewindable partial continuation");
-    finish_args = scm_cons (finish_args, SCM_EOL);
-    goto vm_error;
-
-  vm_error_bad_wide_string_length:
-    err_msg  = scm_from_latin1_string ("VM: Bad wide string length: ~S");
-    goto vm_error;
-
-#ifdef VM_CHECK_IP
-  vm_error_invalid_address:
-    err_msg  = scm_from_latin1_string ("VM: Invalid program address");
-    finish_args = SCM_EOL;
-    goto vm_error;
-#endif
-
-#if VM_CHECK_OBJECT
-  vm_error_object:
-    err_msg = scm_from_latin1_string ("VM: Invalid object table access");
-    finish_args = SCM_EOL;
-    goto vm_error;
-#endif
-
-#if VM_CHECK_FREE_VARIABLES
-  vm_error_free_variable:
-    err_msg = scm_from_latin1_string ("VM: Invalid free variable access");
-    finish_args = SCM_EOL;
-    goto vm_error;
-#endif
-
-  vm_error:
-    SYNC_ALL ();
+  abort (); /* never reached */
 
-    scm_ithrow (sym_vm_error, scm_list_3 (sym_vm_run, err_msg, finish_args),
-               1);
-  }
+ vm_error_bad_instruction:
+  vm_error_bad_instruction (ip[-1]);
+  abort (); /* never reached */
 
+ handle_overflow:
+  SYNC_ALL ();
+  vm_error_stack_overflow (vp);
   abort (); /* never reached */
 }
 
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 000397d..5a4bf40 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -103,8 +103,11 @@
  * Cache/Sync
  */
 
+#define VM_ASSERT(condition, handler) \
+  do { if (SCM_UNLIKELY (!(condition))) { SYNC_ALL(); handler; } } while (0)
+
 #ifdef VM_ENABLE_ASSERTIONS
-# define ASSERT(condition) if (SCM_UNLIKELY (!(condition))) abort()
+# define ASSERT(condition) VM_ASSERT (condition, abort())
 #else
 # define ASSERT(condition)
 #endif
@@ -191,18 +194,16 @@
 
 /* Accesses to a program's object table.  */
 #if VM_CHECK_OBJECT
-#define CHECK_OBJECT(_num) \
-  do { if (SCM_UNLIKELY ((_num) >= object_count)) goto vm_error_object; } 
while (0)
+#define CHECK_OBJECT(_num)                              \
+  VM_ASSERT ((_num) < object_count, vm_error_object ())
 #else
 #define CHECK_OBJECT(_num)
 #endif
 
 #if VM_CHECK_FREE_VARIABLES
-#define CHECK_FREE_VARIABLE(_num)                                       \
-  do {                                                                  \
-    if (SCM_UNLIKELY ((_num) >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))) \
-      goto vm_error_free_variable;                                      \
-  } while (0)
+#define CHECK_FREE_VARIABLE(_num)                               \
+  VM_ASSERT ((_num) < SCM_PROGRAM_NUM_FREE_VARIABLES (program), \
+             vm_error_free_variable ())
 #else
 #define CHECK_FREE_VARIABLE(_num)
 #endif
@@ -276,21 +277,19 @@
 # define NULLSTACK_FOR_NONLOCAL_EXIT()
 #endif
 
-#define CHECK_OVERFLOW()                       \
-  if (SCM_UNLIKELY (sp >= stack_limit))         \
-    goto vm_error_stack_overflow
-
+/* For this check, we don't use VM_ASSERT, because that leads to a
+   per-site SYNC_ALL, which is too much code growth.  The real problem
+   of course is having to check for overflow all the time... */
+#define CHECK_OVERFLOW()                                                \
+  do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)
 
 #ifdef VM_CHECK_UNDERFLOW
-#define CHECK_UNDERFLOW()                       \
-  if (SCM_UNLIKELY (sp <= SCM_FRAME_UPPER_ADDRESS (fp)))        \
-    goto vm_error_stack_underflow
 #define PRE_CHECK_UNDERFLOW(N)                  \
-  if (SCM_UNLIKELY (sp - N <= SCM_FRAME_UPPER_ADDRESS (fp)))    \
-    goto vm_error_stack_underflow
+  VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow 
())
+#define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
 #else
-#define CHECK_UNDERFLOW() /* nop */
 #define PRE_CHECK_UNDERFLOW(N) /* nop */
+#define CHECK_UNDERFLOW() /* nop */
 #endif
 
 
@@ -333,10 +332,7 @@ do                                         \
 {                                              \
   for (; scm_is_pair (l); l = SCM_CDR (l))      \
     PUSH (SCM_CAR (l));                         \
-  if (SCM_UNLIKELY (!NILP (l))) {               \
-    finish_args = scm_list_1 (l);               \
-    goto vm_error_improper_list;                \
-  }                                             \
+  VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
 } while (0)
 
 
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 6fa8eb2..c323156 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -105,11 +105,8 @@ VM_DEFINE_LOADER (107, load_wide_string, 
"load-wide-string")
   scm_t_wchar *wbuf;
 
   FETCH_LENGTH (len);
-  if (SCM_UNLIKELY (len % 4))
-    {
-      finish_args = scm_list_1 (scm_from_size_t (len));
-      goto vm_error_bad_wide_string_length;
-    }
+  VM_ASSERT ((len % 4) == 0,
+             vm_error_bad_wide_string_length (len));
 
   SYNC_REGISTER ();
   PUSH (scm_i_make_wide_string (len / 4, &wbuf, 1));
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 89c3555..0e39563 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -136,11 +136,7 @@ VM_DEFINE_FUNCTION (142, cons, "cons", 2)
 }
 
 #define VM_VALIDATE_CONS(x, proc)              \
-  if (SCM_UNLIKELY (!scm_is_pair (x)))          \
-    { func_name = proc;                         \
-      finish_args = x;                          \
-      goto vm_error_not_a_pair;                 \
-    }
+  VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
   
 VM_DEFINE_FUNCTION (143, car, "car", 1)
 {
@@ -562,12 +558,7 @@ VM_DEFINE_INSTRUCTION (170, make_array, "make-array", 3, 
-1, 1)
  * Structs
  */
 #define VM_VALIDATE_STRUCT(obj, proc)           \
-  if (SCM_UNLIKELY (!SCM_STRUCTP (obj)))       \
-    {                                          \
-      func_name = proc;                         \
-      finish_args = (obj);                     \
-      goto vm_error_not_a_struct;              \
-    }
+  VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
 
 VM_DEFINE_FUNCTION (171, struct_p, "struct?", 1)
 {
@@ -713,16 +704,7 @@ VM_DEFINE_INSTRUCTION (178, slot_set, "slot-set", 0, 3, 0)
  * Bytevectors
  */
 #define VM_VALIDATE_BYTEVECTOR(x, proc)                \
-  do                                           \
-    {                                          \
-      if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x)))        \
-       {                                       \
-          func_name = proc;                     \
-         finish_args = x;                      \
-         goto vm_error_not_a_bytevector;       \
-       }                                       \
-    }                                          \
-  while (0)
+  VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
 
 #define BV_REF_WITH_ENDIANNESS(stem, fn_stem)                           \
 {                                                                       \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 7153ab5..b6c15d2 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -31,16 +31,20 @@ VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
 
 VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
 {
+  SCM ret;
+
   nvalues = SCM_I_INUM (*sp--);
   NULLSTACK (1);
+
   if (nvalues == 1)
-    POP (finish_args);
+    POP (ret);
   else
     {
-      POP_LIST (nvalues);
-      POP (finish_args);
       SYNC_REGISTER ();
-      finish_args = scm_values (finish_args);
+      sp -= nvalues;
+      CHECK_UNDERFLOW ();
+      ret = scm_c_values (sp + 1, nvalues);
+      NULLSTACK (nvalues);
     }
     
   {
@@ -58,7 +62,8 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
     NULLSTACK (old_sp - sp);
   }
   
-  goto vm_done;
+  SYNC_ALL ();
+  return ret;
 }
 
 VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0)
@@ -298,20 +303,16 @@ VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 
0, 1, 1)
      unlike in top-variable-ref, it really isn't an internal assertion
      that can be optimized out -- the variable could be coming directly
      from the user.  */
-  if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
-    {
-      func_name = "variable-ref";
-      finish_args = x;
-      goto vm_error_not_a_variable;
-    }
-  else if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
+  VM_ASSERT (SCM_VARIABLEP (x),
+             vm_error_not_a_variable ("variable-ref", x));
+
+  if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
     {
       SCM var_name;
 
       /* Attempt to provide the variable name in the error message.  */
       var_name = scm_module_reverse_lookup (scm_current_module (), x);
-      finish_args = scm_is_true (var_name) ? var_name : x;
-      goto vm_error_unbound;
+      vm_error_unbound (program, scm_is_true (var_name) ? var_name : x);
     }
   else
     {
@@ -326,14 +327,10 @@ VM_DEFINE_INSTRUCTION (26, variable_bound, 
"variable-bound?", 0, 1, 1)
 {
   SCM x = *sp;
   
-  if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
-    {
-      func_name = "variable-bound?";
-      finish_args = x;
-      goto vm_error_not_a_variable;
-    }
-  else
-    *sp = scm_from_bool (VARIABLE_BOUNDP (x));
+  VM_ASSERT (SCM_VARIABLEP (x),
+             vm_error_not_a_variable ("variable-bound?", x));
+
+  *sp = scm_from_bool (VARIABLE_BOUNDP (x));
   NEXT;
 }
 
@@ -348,11 +345,7 @@ VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 
1, 0, 1)
     {
       SYNC_REGISTER ();
       resolved = resolve_variable (what, scm_program_module (program));
-      if (!VARIABLE_BOUNDP (resolved))
-        {
-          finish_args = what;
-          goto vm_error_unbound;
-        }
+      VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what));
       what = resolved;
       OBJECT_SET (objnum, what);
     }
@@ -374,11 +367,8 @@ VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, 
"long-toplevel-ref", 2, 0, 1)
     {
       SYNC_REGISTER ();
       resolved = resolve_variable (what, scm_program_module (program));
-      if (!VARIABLE_BOUNDP (resolved))
-        {
-          finish_args = what;
-          goto vm_error_unbound;
-        }
+      VM_ASSERT (VARIABLE_BOUNDP (resolved),
+                 vm_error_unbound (program, what));
       what = resolved;
       OBJECT_SET (objnum, what);
     }
@@ -410,12 +400,8 @@ VM_DEFINE_INSTRUCTION (30, long_local_set, 
"long-local-set", 2, 1, 0)
 
 VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0)
 {
-  if (SCM_UNLIKELY (!SCM_VARIABLEP (sp[0])))
-    {
-      func_name = "variable-set!";
-      finish_args = sp[0];
-      goto vm_error_not_a_variable;
-    }
+  VM_ASSERT (SCM_VARIABLEP (sp[0]),
+             vm_error_not_a_variable ("variable-set!", sp[0]));
   VARIABLE_SET (sp[0], sp[-1]);
   DROPN (2);
   NEXT;
@@ -598,8 +584,8 @@ VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, 
"assert-nargs-ee", 2, 0, 0)
   scm_t_ptrdiff n;
   n = FETCH () << 8;
   n += FETCH ();
-  if (sp - (fp - 1) != n)
-    goto vm_error_wrong_num_args;
+  VM_ASSERT (sp - (fp - 1) == n,
+             vm_error_wrong_num_args (program));
   NEXT;
 }
 
@@ -608,8 +594,8 @@ VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, 
"assert-nargs-ge", 2, 0, 0)
   scm_t_ptrdiff n;
   n = FETCH () << 8;
   n += FETCH ();
-  if (sp - (fp - 1) < n)
-    goto vm_error_wrong_num_args;
+  VM_ASSERT (sp - (fp - 1) >= n,
+             vm_error_wrong_num_args (program));
   NEXT;
 }
 
@@ -679,9 +665,9 @@ VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 
0, 0)
   nkw += FETCH ();
   kw_and_rest_flags = FETCH ();
 
-  if (!(kw_and_rest_flags & F_REST)
-      && ((sp - (fp - 1) - nkw) % 2))
-    goto vm_error_kwargs_length_not_even;
+  VM_ASSERT ((kw_and_rest_flags & F_REST)
+             || ((sp - (fp - 1) - nkw) % 2) == 0,
+             vm_error_kwargs_length_not_even (program))
 
   CHECK_OBJECT (idx);
   kw = OBJECT_REF (idx);
@@ -703,13 +689,14 @@ VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 
0, 0)
                  break;
                }
            }
-         if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
-           goto vm_error_kwargs_unrecognized_keyword;
-
+          VM_ASSERT (scm_is_pair (walk)
+                     || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
+                     vm_error_kwargs_unrecognized_keyword (program));
          nkw++;
        }
-      else if (!(kw_and_rest_flags & F_REST))
-        goto vm_error_kwargs_invalid_keyword;
+      else
+        VM_ASSERT (kw_and_rest_flags & F_REST,
+                   vm_error_kwargs_invalid_keyword (program));
     }
 
   NEXT;
@@ -808,7 +795,10 @@ VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
           goto vm_call;
         }
       else
-        goto vm_error_wrong_type_apply;
+        {
+          SYNC_ALL();
+          vm_error_wrong_type_apply (program);
+        }
     }
 
   CACHE_PROGRAM ();
@@ -856,7 +846,10 @@ VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 
1)
           goto vm_tail_call;
         }
       else
-        goto vm_error_wrong_type_apply;
+        {
+          SYNC_ALL();
+          vm_error_wrong_type_apply (program);
+        }
     }
   else
     {
@@ -1003,10 +996,8 @@ VM_DEFINE_INSTRUCTION (61, partial_cont_call, 
"partial-cont-call", 0, -1, 0)
   SCM vmcont;
   POP (vmcont);
   SYNC_REGISTER ();
-  if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
-    { finish_args = vmcont;
-      goto vm_error_continuation_not_rewindable;
-    }
+  VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
+             vm_error_continuation_not_rewindable (vmcont));
   vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp,
                                      &current_thread->dynstack,
                                      &registers);
@@ -1064,7 +1055,10 @@ VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1)
           goto vm_mv_call;
         }
       else
-        goto vm_error_wrong_type_apply;
+        {
+          SYNC_ALL();
+          vm_error_wrong_type_apply (program);
+        }
     }
 
   CACHE_PROGRAM ();
@@ -1098,12 +1092,8 @@ VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1)
   ASSERT (nargs >= 2);
 
   len = scm_ilength (ls);
-  if (SCM_UNLIKELY (len < 0))
-    {
-      finish_args = ls;
-      goto vm_error_apply_to_non_list;
-    }
-
+  VM_ASSERT (len >= 0,
+             vm_error_apply_to_non_list (ls));
   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 
   nargs += len - 2;
@@ -1120,12 +1110,8 @@ VM_DEFINE_INSTRUCTION (66, tail_apply, "tail-apply", 1, 
-1, 1)
   ASSERT (nargs >= 2);
 
   len = scm_ilength (ls);
-  if (SCM_UNLIKELY (len < 0))
-    {
-      finish_args = ls;
-      goto vm_error_apply_to_non_list;
-    }
-
+  VM_ASSERT (len >= 0,
+             vm_error_apply_to_non_list (ls));
   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 
   nargs += len - 2;
@@ -1296,7 +1282,10 @@ VM_DEFINE_INSTRUCTION (70, return_values, 
"return/values", 1, -1, -1)
       NULLSTACK (vals + nvalues - sp);
     }
   else
-    goto vm_error_no_values;
+    {
+      SYNC_ALL ();
+      vm_error_no_values ();
+    }
 
   /* Restore the last program */
   program = SCM_FRAME_PROGRAM (fp);
@@ -1320,10 +1309,7 @@ VM_DEFINE_INSTRUCTION (71, return_values_star, 
"return/values*", 1, -1, -1)
       l = SCM_CDR (l);
       nvalues++;
     }
-  if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
-    finish_args = scm_list_1 (l);
-    goto vm_error_improper_list;
-  }
+  VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l));
 
   goto vm_return_values;
 }
@@ -1349,8 +1335,7 @@ VM_DEFINE_INSTRUCTION (73, truncate_values, 
"truncate-values", 2, -1, -1)
   if (rest)
     nbinds--;
 
-  if (nvalues < nbinds)
-    goto vm_error_not_enough_values;
+  VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ());
 
   if (rest)
     POP_LIST (nvalues - nbinds);
@@ -1542,8 +1527,7 @@ VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1)
 {
   unsigned n = FETCH ();
   SYNC_REGISTER ();
-  if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
-    goto vm_error_stack_underflow;
+  PRE_CHECK_UNDERFLOW (n + 2);
   vm_abort (vm, n, &registers);
   /* vm_abort should not return */
   abort ();
@@ -1597,11 +1581,8 @@ VM_DEFINE_INSTRUCTION (93, fluid_ref, "fluid-ref", 0, 1, 
1)
       SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
       if (scm_is_eq (val, SCM_UNDEFINED))
         val = SCM_I_FLUID_DEFAULT (*sp);
-      if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
-        {
-          finish_args = *sp;
-          goto vm_error_unbound_fluid;
-        }
+      VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
+                 vm_error_unbound_fluid (program, *sp));
       *sp = val;
     }
   
@@ -1636,8 +1617,8 @@ VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, 
"assert-nargs-ee/locals", 1,
   /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
   n = FETCH ();
 
-  if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
-    goto vm_error_wrong_num_args;
+  VM_ASSERT (sp - (fp - 1) == (n & 0x7),
+             vm_error_wrong_num_args (program));
 
   old_sp = sp;
   sp += (n >> 3);
diff --git a/libguile/vm.c b/libguile/vm.c
index 5645f81..b2d0731 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -379,6 +379,225 @@ scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
   scm_puts_unlocked (">", port);
 }
 
+
+/*
+ * VM Error Handling
+ */
+
+static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
+static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_not_a_variable (const char *func_name, SCM x) 
SCM_NORETURN SCM_NOINLINE;
+static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_kwargs_invalid_keyword (SCM proc) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_kwargs_unrecognized_keyword (SCM proc) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_too_many_args (int nargs) 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_stack_overflow (struct scm_vm *vp) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_not_a_struct (const char *subr, SCM x) 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_continuation_not_rewindable (SCM cont) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN 
SCM_NOINLINE;
+#if VM_CHECK_IP
+static void vm_error_invalid_address (void) SCM_NORETURN SCM_NOINLINE;
+#endif
+#if VM_CHECK_OBJECT
+static void vm_error_object (void) SCM_NORETURN SCM_NOINLINE;
+#endif
+#if VM_CHECK_FREE_VARIABLES
+static void vm_error_free_variable (void) SCM_NORETURN SCM_NOINLINE;
+#endif
+
+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)));
+  abort(); /* not reached */
+}
+
+static void
+vm_error_bad_instruction (scm_t_uint32 inst)
+{
+  vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst));
+}
+
+static void
+vm_error_unbound (SCM proc, SCM sym)
+{
+  scm_error_scm (scm_misc_error_key, proc,
+                 scm_from_latin1_string ("Unbound variable: ~s"),
+                 scm_list_1 (sym), SCM_BOOL_F);
+}
+
+static void
+vm_error_unbound_fluid (SCM proc, SCM fluid)
+{
+  scm_error_scm (scm_misc_error_key, proc,
+                 scm_from_latin1_string ("Unbound fluid: ~s"),
+                 scm_list_1 (fluid), SCM_BOOL_F);
+}
+
+static void
+vm_error_not_a_variable (const char *func_name, SCM x)
+{
+  scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
+             scm_list_1 (x), scm_list_1 (x));
+}
+
+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_kwargs_length_not_even (SCM proc)
+{
+  scm_error_scm (sym_keyword_argument_error, proc,
+                 scm_from_latin1_string ("Odd length of keyword argument 
list"),
+                 SCM_EOL, SCM_BOOL_F);
+}
+
+static void
+vm_error_kwargs_invalid_keyword (SCM proc)
+{
+  scm_error_scm (sym_keyword_argument_error, proc,
+                 scm_from_latin1_string ("Invalid keyword"),
+                 SCM_EOL, SCM_BOOL_F);
+}
+
+static void
+vm_error_kwargs_unrecognized_keyword (SCM proc)
+{
+  scm_error_scm (sym_keyword_argument_error, proc,
+                 scm_from_latin1_string ("Unrecognized keyword"),
+                 SCM_EOL, SCM_BOOL_F);
+}
+
+static void
+vm_error_too_many_args (int nargs)
+{
+  vm_error ("VM: Too many arguments", scm_from_int (nargs));
+}
+
+static void
+vm_error_wrong_num_args (SCM proc)
+{
+  scm_wrong_num_args (proc);
+}
+
+static void
+vm_error_wrong_type_apply (SCM proc)
+{
+  scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
+             scm_list_1 (proc), scm_list_1 (proc));
+}
+
+static void
+vm_error_stack_overflow (struct scm_vm *vp)
+{
+  if (vp->stack_limit < vp->stack_base + vp->stack_size)
+    /* There are VM_STACK_RESERVE_SIZE bytes left.  Make them available so
+       that `throw' below can run on this VM.  */
+    vp->stack_limit = vp->stack_base + vp->stack_size;
+  else
+    /* There is no space left on the stack.  FIXME: Do something more
+       sensible here! */
+    abort ();
+  vm_error ("VM: Stack overflow", SCM_UNDEFINED);
+}
+
+static void
+vm_error_stack_underflow (void)
+{
+  vm_error ("VM: Stack underflow", SCM_UNDEFINED);
+}
+
+static void
+vm_error_improper_list (SCM x)
+{
+  vm_error ("Expected a proper list, but got object with tail ~s", x);
+}
+
+static void
+vm_error_not_a_pair (const char *subr, SCM x)
+{
+  scm_wrong_type_arg_msg (subr, 1, x, "pair");
+}
+
+static void
+vm_error_not_a_bytevector (const char *subr, SCM x)
+{
+  scm_wrong_type_arg_msg (subr, 1, x, "bytevector");
+}
+
+static void
+vm_error_not_a_struct (const char *subr, SCM x)
+{
+  scm_wrong_type_arg_msg (subr, 1, x, "struct");
+}
+
+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_continuation_not_rewindable (SCM cont)
+{
+  vm_error ("Unrewindable partial continuation", cont);
+}
+
+static void
+vm_error_bad_wide_string_length (size_t len)
+{
+  vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
+}
+
+#ifdef VM_CHECK_IP
+static void
+vm_error_invalid_address (void)
+{
+  vm_error ("VM: Invalid program address", SCM_UNDEFINED);
+}
+#endif
+
+#if VM_CHECK_OBJECT
+static void
+vm_error_object ()
+{
+  vm_error ("VM: Invalid object table access", SCM_UNDEFINED);
+}
+#endif
+
+#if VM_CHECK_FREE_VARIABLES
+static void
+vm_error_free_variable ()
+{
+  vm_error ("VM: Invalid free variable access", SCM_UNDEFINED);
+}
+#endif
+
+
 static SCM
 really_make_boot_program (long nargs)
 {


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]