[no subject]

[Ludovic Courtès]

branch: master
commit ea233c2ffdb2cc216653b2eba58c313dfaa49823
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Sep 1 16:06:18 2023 +0200

    tests: Reify exceptions instead of hanging.
    
    Previously, exceptions raised in a test would lead Fibers to print
    "Uncaught exception in task" and the test would then hang.  With this
    change, tests actually fail.
    
    * tests/database.scm (with-fibers): Wrap EXP... in
    'with-exception-handler'.  When RESULT is an exception, rethrow it.
---
 tests/database.scm | 21 ++++++++++++++++++---
 1 file changed, 18 insertions(+), 3 deletions(-)

diff --git a/tests/database.scm b/tests/database.scm
index e87d864..035957f 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -34,6 +34,8 @@
              (rnrs io ports)
              (squee)
              (fibers)
+             (ice-9 control)
+             (ice-9 exceptions)
              (ice-9 match)
              (srfi srfi-19)
              (srfi srfi-64))
@@ -115,12 +117,25 @@
        (lambda ()
          (parameterize ((%db-connection-pool
                          (make-resource-pool (list db))))
-           exp ...))
-       #:drain? #t
+           (let/ec return
+             (with-exception-handler
+                 (lambda (exception)
+                   ;; XXX: 'display-backtrace' might throw in a way that
+                   ;; 'false-if-exception' cannot catch.
+                   ;;
+                   ;; (false-if-exception
+                   ;;  (display-backtrace (make-stack #t) 
(current-error-port)))
+                   (return exception))
+               (lambda ()
+                 exp ...)))))
+       #:drain? #f
        #:parallelism 1
        #:hz 5))
+
     (db-close db)
-    result))
+    (if (exception? result)
+        (raise-exception result)
+        result)))
 
 (current-logging-level 'debug)