print-exception gets a c binding

* libguile/backtrace.c (scm_print_exception): Add C binding for
  print-exception, which dispatches to whatever is defined in Scheme.
  (boot_print_exception): Add initial binding, replaced later in
  Scheme.

* module/ice-9/boot-9.scm: Expect there to already be a print-exception
  binding.

diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 7e93ff3..70bb7fb 100644 (file)
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -55,6 +55,42 @@
  * Note that these functions shouldn't generate errors themselves.
  */
 
+static SCM
+boot_print_exception (SCM port, SCM frame, SCM key, SCM args)
+#define FUNC_NAME "boot-print-exception"
+{
+  scm_puts ("Throw to key ", port);
+  scm_write (key, port);
+  scm_puts (" with args ", port);
+  scm_write (args, port);
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM
+scm_print_exception (SCM port, SCM frame, SCM key, SCM args)
+#define FUNC_NAME "print-exception"
+{
+  static SCM print_exception = SCM_BOOL_F;
+
+  SCM_VALIDATE_OPOUTPORT (1, port);
+  if (scm_is_true (frame))
+    SCM_VALIDATE_FRAME (2, frame);
+  SCM_VALIDATE_SYMBOL (3, key);
+  SCM_VALIDATE_LIST (4, args);
+  
+  if (scm_is_false (print_exception))
+    print_exception = scm_c_module_lookup (scm_the_root_module (),
+                                           "print-exception");
+
+  return scm_call_4 (scm_variable_ref (print_exception),
+                     port, frame, key, args);
+}
+#undef FUNC_NAME
+
+
+\f
+
 /* Print parameters for error messages. */
 
 #define DISPLAY_ERROR_MESSAGE_MAX_LEVEL   7
@@ -72,6 +108,7 @@
        if (!(_cond)) \
           return SCM_BOOL_F;
 
+
 static void
 display_header (SCM source, SCM port)
 {
@@ -734,6 +771,7 @@ scm_backtrace (void)
 void
 scm_init_backtrace ()
 {
+  scm_c_define_gsubr ("print-exception", 4, 0, 0, boot_print_exception);
 #include "libguile/backtrace.x"
 }
 

diff --git a/libguile/backtrace.h b/libguile/backtrace.h
index bc593bc..42bd26f 100644 (file)
--- a/libguile/backtrace.h
+++ b/libguile/backtrace.h
@@ -3,7 +3,7 @@
 #ifndef SCM_BACKTRACE_H
 #define SCM_BACKTRACE_H
 
-/* Copyright (C) 1996,1998,1999,2000,2001, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,1999,2000,2001, 2004, 2006, 2008, 2010, 2011 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
@@ -25,6 +25,8 @@
 
 #include "libguile/__scm.h"
 
+SCM_API SCM scm_print_exception (SCM port, SCM frame, SCM key, SCM args);
+
 SCM_API void scm_display_error_message (SCM message, SCM args, SCM port);
 SCM_INTERNAL void scm_i_display_error (SCM frame, SCM port, SCM subr,
                                       SCM message, SCM args, SCM rest);

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 66cec58..46adc51 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -486,7 +486,8 @@ If there is no handler at all, Guile prints an error and then exits."
 ;;;
 
 (define set-exception-printer! #f)
-(define print-exception #f)
+;; There is already a definition of print-exception from backtrace.c
+;; that we will override.
 
 (let ((exception-printers '()))
   (define (print-location frame port)