Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / module / srfi / srfi-18.scm

diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 925ecb3..684a125 100644 (file)
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -1,11 +1,11 @@
 ;;; srfi-18.scm --- Multithreading support
 
-;; Copyright (C) 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009, 2010, 2012 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
 ;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
+;; version 3 of the License, or (at your option) any later version.
 ;; 
 ;; This library is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -105,7 +105,6 @@
 (define terminated-thread-exception (list 'terminated-thread-exception))
 (define uncaught-exception (list 'uncaught-exception))
 
-(define mutex-owners (make-weak-key-hash-table))
 (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))
@@ -146,13 +145,15 @@
     (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))
-    (apply (@ (srfi srfi-34) with-exception-handler) 
-           (list (lambda (obj)
-                   (hashq-set! thread-exception-handlers ct hl) 
-                   (handler obj))
-                 (lambda () 
-                   (let ((r (thunk)))
-                     (hashq-set! thread-exception-handlers ct hl) r))))))
+    ((@ (srfi srfi-34) with-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)))
@@ -230,7 +231,7 @@
   (let* ((ct (time->seconds (current-time)))
         (t (cond ((time? timeout) (- (time->seconds timeout) ct))
                  ((number? timeout) (- timeout ct))
-                 (else (scm-error 'wrong-type-arg caller
+                 (else (scm-error 'wrong-type-arg "thread-sleep!"
                                   "Wrong type argument: ~S" 
                                   (list timeout) 
                                   '()))))
@@ -249,8 +250,8 @@
 (define (wrap thunk)
   (lambda (continuation)
     (with-exception-handler (lambda (obj)
-                             (apply (current-exception-handler) (list obj))
-                             (apply continuation (list)))
+                             ((current-exception-handler) obj)
+                             (continuation))
                            thunk)))
 
 ;; A pass-thru to cancel-thread that first installs a handler that throws
@@ -276,7 +277,7 @@
 (define (thread-join! thread . args) 
   (define thread-join-inner!
     (wrap (lambda ()
-           (let ((v (apply join-thread (cons thread args)))
+           (let ((v (apply join-thread thread args))
                  (e (thread->exception thread)))
              (if (and (= (length args) 1) (not v))
                  (raise join-timeout-exception))
@@ -319,12 +320,12 @@
   (define mutex-lock-inner!
     (wrap (lambda ()
            (catch 'abandoned-mutex-error
-                  (lambda () (apply lock-mutex (cons mutex args)))
+                  (lambda () (apply lock-mutex mutex args))
                   (lambda (key . args) (raise abandoned-mutex-exception))))))
   (call/cc mutex-lock-inner!))
 
 (define (mutex-unlock! mutex . args) 
-  (apply unlock-mutex (cons mutex args)))
+  (apply unlock-mutex mutex args))
 
 ;; CONDITION VARIABLES
 ;; These functions are all pass-thrus to the existing Guile implementations.