[Guile-commits] 08/17: srfi-18: Use srfi-35 conditions.

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 177a058a400e8a718813b73b1cfe33adb5565eae
Author: Andy Wingo <address@hidden>
Date:   Sun Oct 30 22:30:21 2016 +0100

    srfi-18: Use srfi-35 conditions.
    
    * module/srfi/srfi-18.scm: Use srfi-35 conditions instead of our
      home-grown equivalent system.
      (thread-exception-handlers): Remove unused table.
      (srfi-18-exception-handler): Always capture key consed to args; no
      special case for bare key.
    * test-suite/tests/srfi-18.test (provided?): Adapt to reason always
      being key+args.
---
 module/srfi/srfi-18.scm       |   51 ++++++++++++++++++++---------------------
 test-suite/tests/srfi-18.test |    2 +-
 2 files changed, 26 insertions(+), 27 deletions(-)

diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index cb2ac1c..8e5956b 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -34,6 +34,9 @@
   #:use-module ((ice-9 threads) #:prefix threads:)
   #:use-module (ice-9 match)
   #:use-module ((srfi srfi-34) #:prefix srfi-34:)
+  #:use-module ((srfi srfi-35) #:select (define-condition-type
+                                          &error
+                                          condition))
   #:export (;; Threads
             make-thread
             thread-name
@@ -97,27 +100,31 @@
       (scm-error 'wrong-type-arg caller
                 "Wrong type argument: ~S" (list arg) '())))
 
-(define abandoned-mutex-exception (list 'abandoned-mutex-exception))
-(define join-timeout-exception (list 'join-timeout-exception))
-(define terminated-thread-exception (list 'terminated-thread-exception))
-(define uncaught-exception (list 'uncaught-exception))
+(define-condition-type &abandoned-mutex-exception &error
+  abandoned-mutex-exception?)
+(define-condition-type &join-timeout-exception &error
+  join-timeout-exception?)
+(define-condition-type &terminated-thread-exception &error
+  terminated-thread-exception?)
+(define-condition-type &uncaught-exception &error
+  uncaught-exception?
+  (reason uncaught-exception-reason))
 
 (define object-names (make-weak-key-hash-table))
 (define object-specifics (make-weak-key-hash-table))
 (define thread-start-conds (make-weak-key-hash-table))
-(define thread-exception-handlers (make-weak-key-hash-table))
 
 ;; EXCEPTIONS
 
 (define (initial-handler obj) 
-  (srfi-18-exception-preserver (cons uncaught-exception obj)))
+  (srfi-18-exception-preserver (condition (&uncaught-exception (reason obj)))))
 
 (define thread->exception (make-object-property))
 
 (define (srfi-18-exception-preserver obj)
-  (if (or (terminated-thread-exception? obj)
-          (uncaught-exception? obj))
-      (set! (thread->exception (threads:current-thread)) obj)))
+  (when (or (terminated-thread-exception? obj)
+            (uncaught-exception? obj))
+    (set! (thread->exception (threads:current-thread)) obj)))
 
 (define (srfi-18-exception-handler key . args)
 
@@ -125,10 +132,9 @@
   ;; if one is caught at this level, it has already been taken care of by
   ;; `initial-handler'.
 
-  (and (not (eq? key 'srfi-34))
-       (srfi-18-exception-preserver (if (null? args) 
-                                       (cons uncaught-exception key)
-                                       (cons* uncaught-exception key args)))))
+  (unless (eq? key 'srfi-34)
+    (srfi-18-exception-preserver
+     (condition (&uncaught-exception (reason (cons key args)))))))
 
 (define current-exception-handler (make-parameter initial-handler))
 
@@ -144,15 +150,6 @@
      (parameterize ((current-exception-handler handler))
        (thunk)))))
 
-(define (join-timeout-exception? obj) (eq? obj join-timeout-exception))
-(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception))
-(define (uncaught-exception? obj) 
-  (and (pair? obj) (eq? (car obj) uncaught-exception)))
-(define (uncaught-exception-reason exc)
-  (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))
-(define (terminated-thread-exception? obj) 
-  (eq? obj terminated-thread-exception))
-
 ;; THREADS
 
 ;; Create a new thread and prevent it from starting using a condition variable.
@@ -252,9 +249,9 @@
            (with-exception-handler initial-handler
              current-handler)
            (srfi-18-exception-preserver
-            terminated-thread-exception))
+            (condition (&terminated-thread-exception))))
          (lambda () (srfi-18-exception-preserver
-                     terminated-thread-exception))))
+                     (condition (&terminated-thread-exception))))))
     (threads:cancel-thread thread)
     *unspecified*))
 
@@ -264,7 +261,7 @@
            (let ((v (apply threads:join-thread thread args))
                  (e (thread->exception thread)))
              (if (and (= (length args) 1) (not v))
-                 (srfi-34:raise join-timeout-exception))
+                 (srfi-34:raise (condition (&join-timeout-exception))))
              (if e (srfi-34:raise e))
              v))))
   (call/cc thread-join-inner!))
@@ -303,7 +300,9 @@
     (wrap (lambda ()
            (catch 'abandoned-mutex-error
                   (lambda () (apply threads:lock-mutex mutex args))
-                  (lambda (key . args) (srfi-34:raise 
abandoned-mutex-exception))))))
+                  (lambda (key . args)
+                     (srfi-34:raise
+                      (condition (&abandoned-mutex-exception))))))))
   (call/cc mutex-lock-inner!))
 
 (define (mutex-unlock! mutex . args) 
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
index 5fba80e..a0474a3 100644
--- a/test-suite/tests/srfi-18.test
+++ b/test-suite/tests/srfi-18.test
@@ -484,7 +484,7 @@
         (with-exception-handler
          (lambda (obj)
            (and (uncaught-exception? obj)
-                (eq? (uncaught-exception-reason obj) 'foo)
+                (equal? (uncaught-exception-reason obj) '(foo))
                 (set! success #t)))
          (lambda () (thread-join! t)))
         success)))))