Reimplement catch, throw, and with-throw-handler

* module/ice-9/boot-9.scm: Reimplement catch, throw, and
  with-throw-handler in such a way that the exception handler is
  threaded not through the exception-handling closures, but through a
  data structure in the exception-handler fluid.  This will allow us to
  do unwind-only exception dispatch on stack overflow.

module/ice-9/boot-9.scm

@@ -707,45 +707,64 @@ information is unavailable."
 
 (define with-throw-handler #f)
 (let ()
-  (define (default-exception-handler k . args)
+  (define %exception-handler (make-fluid #f))
-    (cond
+  (define (make-exception-handler catch-key prompt-tag pre-unwind)
-     ((eq? k 'quit)
+    (vector (fluid-ref %exception-handler) 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))
+  (define (exception-handler-pre-unwind handler) (vector-ref handler 3))
+
+  (define %running-pre-unwind (make-fluid '()))
+
+  (define (dispatch-exception handler key args)
+    (unless handler
+      (when (eq? key 'quit)
         (primitive-exit (cond
                          ((not (pair? args)) 0)
                          ((integer? (car args)) (car args))
                          ((not (car args)) 1)
                          (else 0))))
-     (else
+      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key args)
-      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
+      (primitive-exit 1))
-      (primitive-exit 1))))
 
-  (define %running-exception-handlers (make-fluid '()))
+    (let ((catch-key (exception-handler-catch-key handler))
-  (define %exception-handler (make-fluid default-exception-handler))
+          (prev (exception-handler-prev handler)))
-
+      (if (or (eqv? catch-key #t) (eq? catch-key key))
-  (define (default-throw-handler prompt-tag catch-k)
+          (let ((prompt-tag (exception-handler-prompt-tag handler))
-    (let ((prev (fluid-ref %exception-handler)))
+                (pre-unwind (exception-handler-pre-unwind handler)))
-      (lambda (thrown-k . args)
+            (if pre-unwind
-        (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+                ;; Instead of using a "running" set, it would be a lot
-            (apply abort-to-prompt prompt-tag thrown-k args)
+                ;; cleaner semantically to roll back the exception
-            (apply prev thrown-k args)))))
+                ;; handler binding to the one that was in place when the
-
+                ;; pre-unwind handler was installed, and keep it like
-  (define (custom-throw-handler prompt-tag catch-k pre)
+                ;; that for the rest of the dispatch.  Unfortunately
-    (let ((prev (fluid-ref %exception-handler)))
+                ;; that is incompatible with existing semantics.  We'll
-      (lambda (thrown-k . args)
+                ;; see if we can change that later on.
-        (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+                (let ((running (fluid-ref %running-pre-unwind)))
-            (let ((running (fluid-ref %running-exception-handlers)))
+                  (with-fluid* %running-pre-unwind (cons handler running)
-              (with-fluid* %running-exception-handlers (cons pre running)
                     (lambda ()
-                  (if (not (memq pre running))
+                      (unless (memq handler running)
-                      (apply pre thrown-k args))
+                        (apply pre-unwind key args))
-                  ;; fall through
                       (if prompt-tag
-                      (apply abort-to-prompt prompt-tag thrown-k args)
+                          (apply abort-to-prompt prompt-tag key args)
-                      (apply prev thrown-k args)))))
+                          (dispatch-exception prev key args)))))
-            (apply prev thrown-k args)))))
+                (apply abort-to-prompt prompt-tag key args)))
+          (dispatch-exception prev key args))))
 
-  (set! catch
+  (define (throw key . args)
-        (lambda* (k thunk handler #:optional pre-unwind-handler)
+    "Invoke the catch form matching @var{key}, passing @var{args} to the
+@var{handler}.
+
+@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
+
+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))
+
+  (define* (catch k thunk handler #:optional pre-unwind-handler)
     "Invoke @var{thunk} in the dynamic context of @var{handler} for
 exceptions matching @var{key}.  If thunk throws to the symbol
 @var{key}, then @var{handler} is invoked this way:
@@ -788,15 +807,12 @@ non-locally, that exit determines the continuation."
        tag
        (lambda ()
          (with-fluid* %exception-handler
-                   (if pre-unwind-handler
+             (make-exception-handler k tag pre-unwind-handler)
-                       (custom-throw-handler tag k pre-unwind-handler)
-                       (default-throw-handler tag k))
            thunk))
        (lambda (cont k . args)
-               (apply handler k args))))))
+         (apply handler k args)))))
 
-  (set! with-throw-handler
+  (define (with-throw-handler k thunk pre-unwind-handler)
-        (lambda (k thunk pre-unwind-handler)
     "Add @var{handler} to the dynamic context as a throw handler
 for key @var{k}, then invoke @var{thunk}."
     (if (not (or (symbol? k) (eqv? k #t)))
@@ -804,21 +820,12 @@ for key @var{k}, then invoke @var{thunk}."
                    "Wrong type argument in position ~a: ~a"
                    (list 1 k) (list k)))
     (with-fluid* %exception-handler
-              (custom-throw-handler #f k pre-unwind-handler)
+        (make-exception-handler k #f pre-unwind-handler)
-            thunk)))
+      thunk))
 
-  (set! throw
+  (define! 'catch catch)
-        (lambda (key . args)
+  (define! 'with-throw-handler with-throw-handler)
-          "Invoke the catch form matching @var{key}, passing @var{args} to the
+  (define! 'throw throw))
-@var{handler}.
-
-@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
-
-If there is no handler at all, Guile prints an error and then exits."
-          (if (not (symbol? key))
-              ((fluid-ref %exception-handler) 'wrong-type-arg "throw"
-               "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
-              (apply (fluid-ref %exception-handler) key args)))))