[Guile-commits] 01/01: commit to squish on previous

[Andy Wingo]

wingo pushed a commit to branch wip-exceptions
in repository guile.

commit 192f8d38da955ee73513f16cf258d41d19ee863a
Author: Andy Wingo <address@hidden>
Date:   Mon Nov 11 20:57:46 2019 +0100

    commit to squish on previous
---
 libguile/exceptions.c            | 17 ++++++++++++++---
 libguile/exceptions.h            |  2 ++
 libguile/throw.c                 | 21 ++++++++++++++-------
 module/ice-9/boot-9.scm          | 17 +++++++++++------
 test-suite/tests/eval.test       | 16 ++++++++--------
 test-suite/tests/exceptions.test | 17 ++++++++---------
 6 files changed, 57 insertions(+), 33 deletions(-)

diff --git a/libguile/exceptions.c b/libguile/exceptions.c
index ae61d0a..1fe281b 100644
--- a/libguile/exceptions.c
+++ b/libguile/exceptions.c
@@ -109,6 +109,7 @@ call_exception_handler (SCM clo, SCM exn)
 SCM_KEYWORD (kw_unwind_p, "unwind?");
 SCM_KEYWORD (kw_unwind_for_type, "unwind-for-type");
 static SCM exception_handler_fluid;
+static SCM active_exception_handlers_fluid;
 static SCM with_exception_handler_var;
 static SCM raise_exception_var;
 
@@ -253,6 +254,15 @@ exception_has_type (SCM exn, SCM type)
 
 
 
+void
+scm_dynwind_throw_handler (void)
+{
+  scm_dynwind_fluid (active_exception_handlers_fluid, SCM_BOOL_F);
+}
+
+
+
+
 /* Default exception handlers.  */
 
 /* Derive the an exit status from the arguments to (quit ...).  */
@@ -489,10 +499,11 @@ scm_init_exceptions ()
   scm_set_smob_apply (tc16_exception_handler, call_exception_handler, 1, 0, 0);
 
   exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
-  /* This binding is later removed when the Scheme definitions of raise,
-     with-exception-handler, and with-pre-unwind-exception-handler are
-     created in boot-9.scm.  */
+  active_exception_handlers_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
+  /* These binding are later removed when the Scheme definitions of
+     raise and with-exception-handler are created in boot-9.scm.  */
   scm_c_define ("%exception-handler", exception_handler_fluid);
+  scm_c_define ("%active-exception-handlers", active_exception_handlers_fluid);
 
   with_exception_handler_var =
     scm_c_define ("with-exception-handler", SCM_BOOL_F);
diff --git a/libguile/exceptions.h b/libguile/exceptions.h
index eaf8964..5f3869b 100644
--- a/libguile/exceptions.h
+++ b/libguile/exceptions.h
@@ -50,6 +50,8 @@ SCM_INTERNAL SCM scm_raise_exception (SCM exn) SCM_NORETURN;
 SCM_INTERNAL SCM scm_exception_kind (SCM exn);
 SCM_INTERNAL SCM scm_exception_args (SCM exn);
 
+SCM_INTERNAL void scm_dynwind_throw_handler (void);
+
 /* This raises a `stack-overflow' exception, without running pre-unwind
    handlers.  */
 SCM_API void scm_report_stack_overflow (void);
diff --git a/libguile/throw.c b/libguile/throw.c
index 0a45062..d03962a 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -23,18 +23,17 @@
 # include <config.h>
 #endif
 
-#include <alloca.h>
 #include <stdio.h>
 #include <unistdio.h>
 
 #include "backtrace.h"
 #include "boolean.h"
-#include "control.h"
 #include "debug.h"
-#include "deprecation.h"
+#include "dynwind.h"
 #include "eq.h"
 #include "eval.h"
 #include "exceptions.h"
+#include "fluids.h"
 #include "gsubr.h"
 #include "init.h"
 #include "list.h"
@@ -109,6 +108,7 @@ struct scm_catch_data
   void *handler_data;
   scm_t_catch_handler pre_unwind_handler;
   void *pre_unwind_handler_data;
+  SCM pre_unwind_running;
 };
 
 static SCM
@@ -126,10 +126,15 @@ catch_pre_unwind_handler (void *data, SCM exn)
   struct scm_catch_data *catch_data = data;
   SCM kind = scm_exception_kind (exn);
   SCM args = scm_exception_args (exn);
-  if (scm_is_eq (catch_data->tag, SCM_BOOL_T)
-      || scm_is_eq (kind, catch_data->tag)) {
+  if ((scm_is_eq (catch_data->tag, SCM_BOOL_T)
+       || scm_is_eq (kind, catch_data->tag))
+      && scm_is_false (scm_fluid_ref (catch_data->pre_unwind_running))) {
+    scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+    scm_dynwind_throw_handler ();
+    scm_dynwind_fluid (catch_data->pre_unwind_running, SCM_BOOL_T);
     catch_data->pre_unwind_handler (catch_data->pre_unwind_handler_data,
                                     kind, args);
+    scm_dynwind_end ();
   }
   return scm_raise_exception (exn);
 }
@@ -142,6 +147,8 @@ catch_body (void *data)
   if (catch_data->pre_unwind_handler) {
     SCM thunk = scm_c_make_thunk (catch_data->body, catch_data->body_data);
     SCM handler = scm_c_make_exception_handler (catch_pre_unwind_handler, 
data);
+    SCM fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
+    catch_data->pre_unwind_running = fluid;
     return scm_with_pre_unwind_exception_handler (handler, thunk);
   }
 
@@ -156,7 +163,7 @@ scm_c_catch (SCM tag,
 {
   struct scm_catch_data data =
     { tag, body, body_data, handler, handler_data, pre_unwind_handler,
-      pre_unwind_handler_data };
+      pre_unwind_handler_data, SCM_BOOL_F };
 
   return scm_c_with_exception_handler (tag, catch_post_unwind_handler, &data,
                                        catch_body, &data);
@@ -183,7 +190,7 @@ scm_c_with_throw_handler (SCM tag,
                          int lazy_catch_p)
 {
   struct scm_catch_data data =
-    { tag, body, body_data, NULL, NULL, handler, handler_data };
+    { tag, body, body_data, NULL, NULL, handler, handler_data, SCM_BOOL_F };
 
   if (lazy_catch_p)
     /* Non-zero lazy_catch_p arguments have been deprecated since
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 057199d..3a3fd1c 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1539,6 +1539,8 @@ exception composed of such an instance."
         val))
 
     (define %exception-handler (steal-binding! '%exception-handler))
+    (define %active-exception-handlers
+      (steal-binding! '%active-exception-handlers))
     (define %init-exceptions! (steal-binding! '%init-exceptions!))
 
     (%init-exceptions! &compound-exception
@@ -1579,8 +1581,6 @@ exception composed of such an instance."
                          (exception-kind exn) (exception-args exn))
         (primitive-exit 1))))
 
-    (define %dynamic-handlers (make-thread-local-fluid))
-
     (define* (raise-exception exn #:key (continuable? #f))
       (define (capture-current-exception-handlers)
         ;; FIXME: This is quadratic.
@@ -1599,7 +1599,7 @@ exception composed of such an instance."
           (and (exception? exn)
                ((exception-predicate type) exn)))
          (else #f)))
-      (let lp ((handlers (or (fluid-ref %dynamic-handlers)
+      (let lp ((handlers (or (fluid-ref %active-exception-handlers)
                              (capture-current-exception-handlers))))
         (let ((handler (car handlers))
               (handlers (cdr handlers)))
@@ -1620,7 +1620,7 @@ exception composed of such an instance."
                (else
                 (lp handlers)))))
            (else
-            (with-fluids ((%dynamic-handlers handlers))
+            (with-fluids ((%active-exception-handlers handlers))
               (cond
                (continuable?
                 (handler exn))
@@ -1673,10 +1673,15 @@ 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)))
+      (define running? (make-fluid))
       (with-exception-handler
        (lambda (exn)
-         (when (or (eq? k #t) (eq? k (exception-kind exn)))
-           (apply pre-unwind-handler (exception-kind exn) (exception-args 
exn)))
+         (when (and (or (eq? k #t) (eq? k (exception-kind exn)))
+                    (not (fluid-ref running?)))
+           (with-fluids ((%active-exception-handlers #f)
+                         (running? #t))
+             (apply pre-unwind-handler (exception-kind exn)
+                    (exception-args exn))))
          (raise-exception exn))
        thunk))
 
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 8a52e11..71b06f7 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -1,5 +1,6 @@
 ;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 
Free Software Foundation, Inc.
+;;;; Copyright (C) 2000-2001,2003-2015,2017,2019
+;;;;   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
@@ -387,12 +388,11 @@
   (pass-if "inner trim with prompt tag"
     (let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag)))
            (frames (stack->frames stack)))
-      ;; the top frame on the stack is the lambda inside the 'catch, and the
-      ;; next frame is the (catch 'result ...)
-      (and (eq? (car (frame-call-representation (cadr frames)))
-                'catch)
-           (eq? (car (frame-arguments (cadr frames)))
-                'result))))
+      ;; the top frame on the stack is the body of the catch, and the
+      ;; next frame is the with-exception-handler corresponding to the
+      ;; (catch 'result ...)
+      (eq? (car (frame-call-representation (cadr frames)))
+           'with-exception-handler)))
 
   (pass-if "outer trim with prompt tag"
     (let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag)))
@@ -402,7 +402,7 @@
       (and (eq? (car (frame-call-representation (car frames)))
                 'make-stack)
            (eq? (car (frame-call-representation (car (last-pair frames))))
-                'with-throw-handler)))))
+                'with-exception-handler)))))
 
 ;;;
 ;;; letrec init evaluation
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index 391a19d..291e10e 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -24,15 +24,14 @@
     (syntax-violation 'push "push used outside of throw-test" stx)))
 
 (define-syntax-rule (throw-test title result expr ...)
-  (pass-if title
-    (equal? result
-            (let ((stack '()))
-              (syntax-parameterize ((push (syntax-rules ()
-                                            ((push val)
-                                             (set! stack (cons val stack))))))
-                expr ...
-                ;;(format #t "~a: ~s~%" title (reverse stack))
-                (reverse stack))))))
+  (pass-if-equal title result
+    (let ((stack '()))
+      (syntax-parameterize ((push (syntax-rules ()
+                                    ((push val)
+                                     (set! stack (cons val stack))))))
+        expr ...
+        ;;(format #t "~a: ~s~%" title (reverse stack))
+        (reverse stack)))))
 
 (with-test-prefix "throw/catch"