scm_handle_by_message uses scm_print_exception

* libguile/throw.c (handler_message, should_print_backtrace): Use
  scm_print_exception.  Add a helper function to determine when to print
  a backtrace; don't do so on read or syntax errors.

diff --git a/libguile/throw.c b/libguile/throw.c
index b5931fb..7b2a98b 100644 (file)
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -335,109 +335,37 @@ scm_exit_status (SCM args)
 }
        
 
+static int
+should_print_backtrace (SCM tag, SCM stack)
+{
+  return SCM_BACKTRACE_P
+    && scm_is_true (stack)
+    && scm_initialized_p
+    /* It's generally not useful to print backtraces for errors reading
+       or expanding code in these fallback catch statements. */
+    && !scm_is_eq (tag, scm_from_latin1_symbol ("read-error"))
+    && !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"));
+}
+
 static void
 handler_message (void *handler_data, SCM tag, SCM args)
 {
-  char *prog_name = (char *) handler_data;
-  SCM p = scm_current_error_port ();
-
-  if (scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"))
-      && scm_ilength (args) >= 5)
-    {
-      SCM who = SCM_CAR (args);
-      SCM what = SCM_CADR (args);
-      SCM where = SCM_CADDR (args);
-      SCM form = SCM_CADDDR (args);
-      SCM subform = SCM_CAR (SCM_CDDDDR (args));
-
-      scm_puts ("Syntax error:\n", p);
-
-      if (scm_is_true (where))
-        {
-          SCM file, line, col;
-
-          file = scm_assq_ref (where, scm_sym_filename);
-          line = scm_assq_ref (where, scm_sym_line);
-          col = scm_assq_ref (where, scm_sym_column);
-
-          if (scm_is_true (file))
-            scm_display (file, p);
-          else
-            scm_puts ("unknown file", p);
-          scm_puts (":", p);
-          scm_display (line, p);
-          scm_puts (":", p);
-          scm_display (col, p);
-          scm_puts (": ", p);
-        }
-      else
-        scm_puts ("unknown location: ", p);
-
-      if (scm_is_true (who))
-        {
-          scm_display (who, p);
-          scm_puts (": ", p);
-        }
-      
-      scm_display (what, p);
+  SCM p, stack, frame;
 
-      if (scm_is_true (subform))
-        {
-          scm_puts (" in subform ", p);
-          scm_write (subform, p);
-          scm_puts (" of ", p);
-          scm_write (form, p);
-        }
-      else if (scm_is_true (form))
-        {
-          scm_puts (" in form ", p);
-          scm_write (form, p);
-        }
+  p = scm_current_error_port ();
+  stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
+  frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
 
-      scm_newline (p);
-    }
-  else if (scm_ilength (args) == 4)
+  if (should_print_backtrace (tag, stack))
     {
-      SCM stack   = scm_make_stack (SCM_BOOL_T, SCM_EOL);
-      SCM subr    = SCM_CAR (args);
-      SCM message = SCM_CADR (args);
-      SCM parts   = SCM_CADDR (args);
-      SCM rest    = SCM_CADDDR (args);
-
-      if (SCM_BACKTRACE_P && scm_is_true (stack) && scm_initialized_p)
-       {
-         SCM highlights;
-
-         if (scm_is_eq (tag, scm_arg_type_key)
-             || scm_is_eq (tag, scm_out_of_range_key))
-           highlights = rest;
-         else
-           highlights = SCM_EOL;
-
-         scm_puts ("Backtrace:\n", p);
-         scm_display_backtrace_with_highlights (stack, p,
-                                                SCM_BOOL_F, SCM_BOOL_F,
-                                                highlights);
-         scm_newline (p);
-       }
-      scm_i_display_error (scm_is_true (stack)
-                           ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F,
-                           p, subr, message, parts, rest);
+      scm_puts ("Backtrace:\n", p);
+      scm_display_backtrace_with_highlights (stack, p,
+                                             SCM_BOOL_F, SCM_BOOL_F,
+                                             SCM_EOL);
+      scm_newline (p);
     }
-  else
-    {
-      if (! prog_name)
-       prog_name = "guile";
-
-      scm_puts (prog_name, p);
-      scm_puts (": ", p);
 
-      scm_puts ("uncaught throw to ", p);
-      scm_prin1 (tag, p, 0);
-      scm_puts (": ", p);
-      scm_prin1 (args, p, 1);
-      scm_putc ('\n', p);
-    }
+  scm_print_exception (p, frame, tag, args);
 }