[Guile-commits] 07/17: srfi-18: Use parameters.

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 0d57476f0a6ed30c420210946947740d3cf19fde
Author: Andy Wingo <address@hidden>
Date:   Sun Oct 30 22:15:17 2016 +0100

    srfi-18: Use parameters.
    
    * module/srfi/srfi-18.scm: Use srfi-34 internally with srfi-34: prefix.
      (current-exception-handler): Be a parameter.
      (with-exception-handler): Adapt to current-exception-handler change.
      (thread-join!, mutex-lock!): Adapt to use srfi-34: prefix.
---
 module/srfi/srfi-18.scm |   40 +++++++++++++++-------------------------
 1 file changed, 15 insertions(+), 25 deletions(-)

diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 6d74346..cb2ac1c 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -33,7 +33,7 @@
 (define-module (srfi srfi-18)
   #:use-module ((ice-9 threads) #:prefix threads:)
   #:use-module (ice-9 match)
-  #:use-module (srfi srfi-34)
+  #:use-module ((srfi srfi-34) #:prefix srfi-34:)
   #:export (;; Threads
             make-thread
             thread-name
@@ -80,7 +80,7 @@
                (threads:current-thread . current-thread)
                (threads:thread? . thread?)
                (threads:mutex? . mutex?)
-               raise)
+               (srfi-34:raise . raise))
   #:replace (current-time
              make-thread
              make-mutex
@@ -130,29 +130,19 @@
                                        (cons uncaught-exception key)
                                        (cons* uncaught-exception key args)))))
 
-(define (current-handler-stack)
-  (let ((ct (threads:current-thread)))
-    (or (hashq-ref thread-exception-handlers ct)
-       (hashq-set! thread-exception-handlers ct (list initial-handler)))))
+(define current-exception-handler (make-parameter initial-handler))
 
 (define (with-exception-handler handler thunk)
-  (let ((ct (threads:current-thread))
-        (hl (current-handler-stack)))
-    (check-arg-type procedure? handler "with-exception-handler") 
-    (check-arg-type thunk? thunk "with-exception-handler")
-    (hashq-set! thread-exception-handlers ct (cons handler hl))
-    ((@ (srfi srfi-34) with-exception-handler) 
+  (check-arg-type procedure? handler "with-exception-handler")
+  (check-arg-type thunk? thunk "with-exception-handler")
+  (srfi-34:with-exception-handler
+   (let ((prev-handler (current-exception-handler)))
      (lambda (obj)
-       (hashq-set! thread-exception-handlers ct hl) 
-       (handler obj))
-     (lambda () 
-       (call-with-values thunk
-         (lambda res
-           (hashq-set! thread-exception-handlers ct hl)
-           (apply values res)))))))
-
-(define (current-exception-handler)
-  (car (current-handler-stack)))
+       (parameterize ((current-exception-handler prev-handler))
+         (handler obj))))
+   (lambda ()
+     (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))
@@ -274,8 +264,8 @@
            (let ((v (apply threads:join-thread thread args))
                  (e (thread->exception thread)))
              (if (and (= (length args) 1) (not v))
-                 (raise join-timeout-exception))
-             (if e (raise e))
+                 (srfi-34:raise join-timeout-exception))
+             (if e (srfi-34:raise e))
              v))))
   (call/cc thread-join-inner!))
 
@@ -313,7 +303,7 @@
     (wrap (lambda ()
            (catch 'abandoned-mutex-error
                   (lambda () (apply threads:lock-mutex mutex args))
-                  (lambda (key . args) (raise abandoned-mutex-exception))))))
+                  (lambda (key . args) (srfi-34:raise 
abandoned-mutex-exception))))))
   (call/cc mutex-lock-inner!))
 
 (define (mutex-unlock! mutex . args)