%exception-handler fluid refactor

* libguile/throw.c (scm_init_throw): Define %exception-handler here.
* module/ice-9/boot-9.scm (%eh): Use the incoming %exception-handler,
  and then delete it.  This way we should be able to do unwind-only
  exceptions from C.

diff --git a/libguile/throw.c b/libguile/throw.c
index e10695a..37be4cd 100644 (file)
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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
@@ -57,6 +57,8 @@
 
 static SCM catch_var, throw_var, with_throw_handler_var;
 
+static SCM exception_handler_fluid;
+
 SCM
 scm_catch (SCM key, SCM thunk, SCM handler)
 {
@@ -546,6 +548,11 @@ scm_init_throw ()
   tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
   scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
 
+  exception_handler_fluid = scm_make_fluid_with_default (SCM_BOOL_F);
+  /* This binding is later removed when the Scheme definitions of catch,
+     throw, and with-throw-handler are created in boot-9.scm.  */
+  scm_c_define ("%exception-handler", exception_handler_fluid);
+
   catch_var = scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0,
                                                        pre_init_catch));
   throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 23f2d5b..9289902 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -706,10 +706,9 @@ information is unavailable."
 ;; shared fluid. Hide the helpers in a lexical contour.
 
 (define with-throw-handler #f)
-(let ()
-  (define %exception-handler (make-fluid #f))
+(let ((%eh (module-ref (current-module) '%exception-handler)))
   (define (make-exception-handler catch-key prompt-tag pre-unwind)
-    (vector (fluid-ref %exception-handler) catch-key prompt-tag pre-unwind))
+    (vector (fluid-ref %eh) catch-key prompt-tag pre-unwind))
   (define (exception-handler-prev handler) (vector-ref handler 0))
   (define (exception-handler-catch-key handler) (vector-ref handler 1))
   (define (exception-handler-prompt-tag handler) (vector-ref handler 2))
@@ -762,7 +761,7 @@ If there is no handler at all, Guile prints an error and then exits."
     (unless (symbol? key)
       (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
              (list 1 key) (list key)))
-    (dispatch-exception (fluid-ref %exception-handler) key args))
+    (dispatch-exception (fluid-ref %eh) key args))
 
   (define* (catch k thunk handler #:optional pre-unwind-handler)
     "Invoke @var{thunk} in the dynamic context of @var{handler} for
@@ -806,8 +805,7 @@ non-locally, that exit determines the continuation."
       (call-with-prompt
        tag
        (lambda ()
-         (with-fluid* %exception-handler
-             (make-exception-handler k tag pre-unwind-handler)
+         (with-fluid* %eh (make-exception-handler k tag pre-unwind-handler)
            thunk))
        (lambda (cont k . args)
          (apply handler k args)))))
@@ -819,10 +817,10 @@ for key @var{k}, then invoke @var{thunk}."
         (scm-error 'wrong-type-arg "with-throw-handler"
                    "Wrong type argument in position ~a: ~a"
                    (list 1 k) (list k)))
-    (with-fluid* %exception-handler
-        (make-exception-handler k #f pre-unwind-handler)
+    (with-fluid* %eh (make-exception-handler k #f pre-unwind-handler)
       thunk))
 
+  (hashq-remove! (%get-pre-modules-obarray) '%exception-handler)
   (define! 'catch catch)
   (define! 'with-throw-handler with-throw-handler)
   (define! 'throw throw))