From 75e5e5c7aad78876fb9e4a2c1523491f58985917 Mon Sep 17 00:00:00 2001
From: Julian Graham <address@hidden(none)>
Date: Thu, 15 May 2008 00:50:50 -0400
Subject: [PATCH] Scheme SRFI-18 implementation and tests file

---
 srfi/ChangeLog                |    4 +
 srfi/srfi-18.scm              |  379 ++++++++++++++++++++++++++++++++
 test-suite/ChangeLog          |    4 +
 test-suite/tests/srfi-18.test |  477 +++++++++++++++++++++++++++++++++++++++++
 4 files changed, 864 insertions(+), 0 deletions(-)
 create mode 100644 srfi/srfi-18.scm
 create mode 100644 test-suite/tests/srfi-18.test

diff --git a/srfi/ChangeLog b/srfi/ChangeLog
index 1f6c599..fe88665 100644
--- a/srfi/ChangeLog
+++ b/srfi/ChangeLog
@@ -1,3 +1,7 @@
+2008-05-15  Julian Graham  <address@hidden>
+
+	* srfi-18.scm: New file.
+
 2008-04-28  Ludovic Courtès  <address@hidden>
 
 	* srfi-1.c (scm_srfi1_partition): Properly type-check LIST.
diff --git a/srfi/srfi-18.scm b/srfi/srfi-18.scm
new file mode 100644
index 0000000..0593f4e
--- /dev/null
+++ b/srfi/srfi-18.scm
@@ -0,0 +1,379 @@
+;;; srfi-18.scm --- Multithreading support
+
+;; Copyright (C) 2008 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.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Julian Graham <address@hidden>
+;;; Date: 2008-04-11
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-18 (Multithreading support).
+;;
+;; All procedures defined in SRFI-18, which are not already defined in
+;; the Guile core library, are exported.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-18)
+  :use-module (srfi srfi-34)
+  :export (
+
+;;; Threads
+ ;; current-thread			<= in the core
+ ;; thread?				<= in the core
+ make-thread
+ thread-name
+ thread-specific
+ thread-specific-set!
+ thread-start!
+ thread-yield!
+ thread-sleep!
+ thread-terminate!
+ thread-join!
+
+;;; Mutexes
+ ;; mutex?				<= in the core
+ make-mutex
+ mutex-name
+ mutex-specific
+ mutex-specific-set!
+ mutex-state
+ mutex-lock!
+ mutex-unlock!
+
+;;; Condition variables
+ ;; condition-variable?			<= in the core
+ make-condition-variable
+ condition-variable-name
+ condition-variable-specific
+ condition-variable-specific-set!
+ condition-variable-signal!
+ condition-variable-broadcast!
+ condition-variable-wait!
+
+;;; Time
+ current-time
+ time?
+ time->seconds
+ seconds->time
+ 
+ current-exception-handler
+ with-exception-handler
+ raise
+ join-timeout-exception?
+ abandoned-mutex-exception?
+ terminated-thread-exception?
+ uncaught-exception?
+ uncaught-exception-reason
+ )
+  :re-export (thread? mutex? condition-variable?)
+  :replace (current-time 
+	    make-thread 
+	    make-mutex 
+	    make-condition-variable
+	    raise))
+
+(cond-expand-provide (current-module) '(srfi-18))
+
+(define (check-arg-type pred arg caller)
+  (if (pred arg)
+      arg
+      (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 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))
+(define thread-exception-handlers (make-weak-key-hash-table))
+
+;; EXCEPTIONS
+
+(define raise (@ (srfi srfi-34) raise))
+(define (initial-handler obj) 
+  (srfi-18-exception-preserver (cons uncaught-exception 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 (current-thread)) obj)))
+
+(define (srfi-18-exception-handler key . args)
+
+  ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
+  ;; 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)))))
+
+(define (current-handler-stack)
+  (let ((ct (current-thread)))
+    (or (hashq-ref thread-exception-handlers ct)
+	(hashq-set! thread-exception-handlers ct (list initial-handler)))))
+
+(define (with-exception-handler handler thunk)
+  (let ((ct (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))
+    (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))))))
+
+(define (current-exception-handler)
+  (car (current-handler-stack)))
+
+(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.
+;; Once started, install a top-level exception handler that rethrows any 
+;; exceptions wrapped in an uncaught-exception wrapper. 
+
+(define make-thread 
+  (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
+			     (lambda () 
+			       (lock-mutex lmutex)
+			       (signal-condition-variable lcond)
+			       (lock-mutex smutex)
+			       (unlock-mutex lmutex)
+			       (wait-condition-variable scond smutex)
+			       (unlock-mutex smutex)
+			       (with-exception-handler initial-handler 
+						       thunk)))))
+    (lambda (thunk . name)
+      (let ((n (and (pair? name) (car name)))
+
+	    (lm (make-mutex 'launch-mutex))
+	    (lc (make-condition-variable 'launch-condition-variable))
+	    (sm (make-mutex 'start-mutex))
+	    (sc (make-condition-variable 'start-condition-variable)))
+	
+	(lock-mutex lm)
+	(let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
+				       srfi-18-exception-handler)))
+	  (hashq-set! thread-start-conds t (cons sm sc))
+	  (and n (hashq-set! object-names t n))
+	  (wait-condition-variable lc lm)
+	  (unlock-mutex lm)
+	  t)))))
+
+(define (thread-name thread)
+  (hashq-ref object-names (check-arg-type thread? thread "thread-name")))
+
+(define (thread-specific thread)
+  (hashq-ref object-specifics 
+	     (check-arg-type thread? thread "thread-specific")))
+
+(define (thread-specific-set! thread obj)
+  (hashq-set! object-specifics
+	      (check-arg-type thread? thread "thread-specific-set!")
+	      obj)
+  *unspecified*)
+
+(define (thread-start! thread)
+  (let ((x (hashq-ref thread-start-conds
+		      (check-arg-type thread? thread "thread-start!"))))
+    (and x (let ((smutex (car x))
+		 (scond (cdr x)))
+	     (hashq-remove! thread-start-conds thread)
+	     (lock-mutex smutex)
+	     (signal-condition-variable scond)
+	     (unlock-mutex smutex)))
+    thread))
+
+(define (thread-yield!) (yield) *unspecified*)
+
+(define (thread-sleep! timeout)
+  (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
+				   "Wrong type argument: ~S" 
+				   (list timeout) 
+				   '()))))
+	 (secs (inexact->exact (truncate t)))
+	 (usecs (inexact->exact (truncate (* (- t secs) 1000)))))
+    (and (> secs 0) (sleep secs))
+    (and (> usecs 0) (usleep usecs))
+    *unspecified*))
+
+;; A convenience function for installing exception handlers on SRFI-18 
+;; primitives that resume the calling continuation after the handler is 
+;; invoked -- this resolves a behavioral incompatibility with Guile's
+;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
+;; exceptions.  (SRFI-18, "Primitives and exceptions")
+
+(define (wrap thunk)
+  (lambda (continuation)
+    (with-exception-handler (lambda (obj)
+			      (apply (current-exception-handler) (list obj))
+			      (apply continuation (list)))
+			    thunk)))
+
+;; A pass-thru to cancel-thread that first installs a handler that throws
+;; terminated-thread exception, as per SRFI-18, 
+
+(define (thread-terminate! thread)
+  (define (thread-terminate-inner!)
+    (let ((current-handler (thread-cleanup thread)))
+      (if (thunk? current-handler)
+	  (set-thread-cleanup! thread 
+			       (lambda ()
+				 (with-exception-handler initial-handler
+							 current-handler) 
+				 (srfi-18-exception-preserver
+				  terminated-thread-exception)))
+	  (set-thread-cleanup! thread
+			       (lambda () (srfi-18-exception-preserver
+					   terminated-thread-exception))))
+      (cancel-thread thread)
+      *unspecified*))
+  (thread-terminate-inner!))
+
+(define (thread-join! thread . args) 
+  (define thread-join-inner!
+    (wrap (lambda ()
+	    (let ((v (apply join-thread (cons thread args)))
+		  (e (thread->exception thread)))
+	      (if (and (= (length args) 1) (not v))
+		  (raise join-timeout-exception))
+	      (if e (raise e))
+	      v))))
+  (call/cc thread-join-inner!))
+
+;; MUTEXES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define make-mutex
+  (lambda name
+    (let ((n (and (pair? name) (car name)))
+	  (m ((@ (guile) make-mutex) 
+	      'unchecked-unlock 
+	      'allow-external-unlock 
+	      'recursive)))
+      (and n (hashq-set! object-names m n)) m)))
+
+(define (mutex-name mutex)
+  (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
+
+(define (mutex-specific mutex)
+  (hashq-ref object-specifics 
+	     (check-arg-type mutex? mutex "mutex-specific")))
+
+(define (mutex-specific-set! mutex obj)
+  (hashq-set! object-specifics
+	      (check-arg-type mutex? mutex "mutex-specific-set!")
+	      obj)
+  *unspecified*)
+
+(define (mutex-state mutex)
+  (let ((owner (mutex-owner mutex)))
+    (if owner
+	(if (thread-exited? owner) 'abandoned owner)
+	(if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
+
+(define (mutex-lock! mutex . args) 
+  (define mutex-lock-inner!
+    (wrap (lambda ()
+	    (catch 'abandoned-mutex-error
+		   (lambda () (apply lock-mutex (cons 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)))
+
+;; CONDITION VARIABLES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define make-condition-variable
+  (lambda name
+    (let ((n (and (pair? name) (car name)))
+	  (m ((@ (guile) make-condition-variable))))
+      (and n (hashq-set! object-names m n)) m)))
+
+(define (condition-variable-name condition-variable)
+  (hashq-ref object-names (check-arg-type condition-variable? 
+					  condition-variable
+					  "condition-variable-name")))
+
+(define (condition-variable-specific condition-variable)
+  (hashq-ref object-specifics (check-arg-type condition-variable? 
+					      condition-variable 
+					      "condition-variable-specific")))
+
+(define (condition-variable-specific-set! condition-variable obj)
+  (hashq-set! object-specifics
+	      (check-arg-type condition-variable? 
+			      condition-variable 
+			      "condition-variable-specific-set!")
+	      obj)
+  *unspecified*)
+
+(define (condition-variable-signal! cond) 
+  (signal-condition-variable cond) 
+  *unspecified*)
+
+(define (condition-variable-broadcast! cond)
+  (broadcast-condition-variable cond)
+  *unspecified*)
+
+;; TIME
+
+(define current-time gettimeofday)
+(define (time? obj)
+  (and (pair? obj)
+       (let ((co (car obj))) (and (integer? co) (>= co 0)))
+       (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
+
+(define (time->seconds time) 
+  (and (check-arg-type time? time "time->seconds")
+       (+ (car time) (/ (cdr time) 1000000))))
+
+(define (seconds->time x)
+  (and (check-arg-type number? x "seconds->time")
+       (let ((fx (truncate x)))
+	 (cons (inexact->exact fx)
+	       (inexact->exact (truncate (* (- x fx) 1000000)))))))
+
+;; srfi-18.scm ends here
\ No newline at end of file
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index 1d73fbf..5f97142 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,7 @@
+2008-05-15  Julian Graham  <address@hidden>
+
+	* tests/srfi-18.test: New file.
+
 2008-05-14  Julian Graham  <address@hidden>
 
 	* tests/threads.test (mutex-ownership, mutex-lock-levels): New
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
new file mode 100644
index 0000000..d116768
--- /dev/null
+++ b/test-suite/tests/srfi-18.test
@@ -0,0 +1,477 @@
+;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
+;;;; Julian Graham, 2007-10-26
+;;;;
+;;;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;;; 
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;; 
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-srfi-18)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-18))
+
+(with-test-prefix "current-thread"
+
+  (pass-if "current-thread eq current-thread"
+    (eq? (current-thread) (current-thread))))
+
+(with-test-prefix "thread?"
+
+  (pass-if "current-thread is thread"
+    (thread? (current-thread)))
+
+  (pass-if "foo not thread"
+    (not (thread? 'foo))))
+
+(with-test-prefix "make-thread"
+
+  (pass-if "make-thread creates new thread"
+    (let* ((n (length (all-threads)))
+	   (t (make-thread (lambda () 'foo) 'make-thread-1))
+	   (r (> (length (all-threads)) n)))
+      (thread-terminate! t) r)))
+
+(with-test-prefix "thread-name"
+
+  (pass-if "make-thread with name binds name"
+    (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
+	   (r (eq? (thread-name t) 'thread-name-1)))
+      (thread-terminate! t) r))
+
+  (pass-if "make-thread without name does not bind name"
+    (let* ((t (make-thread (lambda () 'foo)))
+	   (r (not (thread-name t))))
+      (thread-terminate! t) r)))
+
+(with-test-prefix "thread-specific"
+
+  (pass-if "thread-specific is initially #f"
+    (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
+	   (r (not (thread-specific t))))
+      (thread-terminate! t) r))
+
+  (pass-if "thread-specific-set! can set value"
+    (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
+      (thread-specific-set! t "hello")
+      (let ((r (equal? (thread-specific t) "hello")))
+	(thread-terminate! t) r))))
+
+(with-test-prefix "thread-start!"
+
+  (pass-if "thread activates only after start" 
+    (let* ((started #f)
+	   (m (make-mutex 'thread-start-mutex))
+	   (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
+      (and (not started) (thread-start! t) (thread-join! t) started))))
+
+(with-test-prefix "thread-yield!"
+
+  (pass-if "thread yield suceeds"
+    (thread-yield!) #t))
+
+(with-test-prefix "thread-sleep!"
+
+  (pass-if "thread sleep with time"
+    (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
+      (unspecified? (thread-sleep! future-time))))
+
+  (pass-if "thread sleep with number"
+    (let ((old-secs (car (current-time))))
+      (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
+
+  (pass-if "thread does not sleep on past time"
+    (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
+      (unspecified? (thread-sleep! past-time)))))
+
+(with-test-prefix "thread-terminate!"
+  
+  (pass-if "termination destroys non-started thread"
+    (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
+	  (num-threads (length (all-threads)))
+	  (success #f))
+      (thread-terminate! t)
+      (with-exception-handler 
+       (lambda (obj) (set! success (terminated-thread-exception? obj)))
+       (lambda () (thread-join! t)))
+      success))
+
+  (pass-if "termination destroys started thread"
+    (let* ((m1 (make-mutex 'thread-terminate-2a))
+	   (m2 (make-mutex 'thread-terminate-2b))
+	   (c (make-condition-variable 'thread-terminate-2))
+	   (t (make-thread (lambda () 
+			     (mutex-lock! m1) 
+			     (condition-variable-signal! c)
+			     (mutex-unlock! m1)
+			     (mutex-lock! m2))
+			   'thread-terminate-2))
+	   (success #f))
+      (mutex-lock! m1)
+      (mutex-lock! m2)
+      (thread-start! t)
+      (mutex-unlock! m1 c)
+      (thread-terminate! t)
+      (with-exception-handler
+       (lambda (obj) (set! success (terminated-thread-exception? obj)))
+       (lambda () (thread-join! t)))
+      success)))
+
+(with-test-prefix "thread-join!"
+
+  (pass-if "join receives result of thread"
+    (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
+      (thread-start! t)
+      (eq? (thread-join! t) 'foo)))
+
+  (pass-if "join receives timeout val if timeout expires"
+    (let* ((m (make-mutex 'thread-join-2))
+	   (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
+      (mutex-lock! m)
+      (thread-start! t)
+      (let ((r (thread-join! t (current-time) 'bar)))
+	(thread-terminate! t)
+	(eq? r 'bar))))
+
+  (pass-if "join throws exception on timeout without timeout val"
+    (let* ((m (make-mutex 'thread-join-3))
+	   (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
+	   (success #f))
+      (mutex-lock! m)
+      (thread-start! t)
+      (with-exception-handler
+       (lambda (obj) (set! success (join-timeout-exception? obj)))
+       (lambda () (thread-join! t (current-time))))
+      (thread-terminate! t)
+      success))
+
+  (pass-if "join waits on timeout"
+    (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
+      (thread-start! t)
+      (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
+
+(with-test-prefix "mutex?"
+
+  (pass-if "make-mutex creates mutex"
+    (mutex? (make-mutex)))
+
+  (pass-if "symbol not mutex"
+    (not (mutex? 'foo))))
+
+(with-test-prefix "mutex-name"
+
+  (pass-if "make-mutex with name binds name"
+    (let* ((m (make-mutex 'mutex-name-1)))
+      (eq? (mutex-name m) 'mutex-name-1)))
+
+  (pass-if "make-mutex without name does not bind name"
+    (let* ((m (make-mutex)))
+      (not (mutex-name m)))))
+
+(with-test-prefix "mutex-specific"
+
+  (pass-if "mutex-specific is initially #f"
+    (let ((m (make-mutex 'mutex-specific-1)))
+      (not (mutex-specific m))))
+
+  (pass-if "mutex-specific-set! can set value"
+    (let ((m (make-mutex 'mutex-specific-2)))
+      (mutex-specific-set! m "hello")
+      (equal? (mutex-specific m) "hello"))))
+
+(with-test-prefix "mutex-state"
+
+  (pass-if "mutex state is initially not-abandoned"
+    (let ((m (make-mutex 'mutex-state-1)))
+      (eq? (mutex-state m) 'not-abandoned)))
+
+  (pass-if "mutex state of locked, owned mutex is owner thread"
+    (let ((m (make-mutex 'mutex-state-2)))
+      (mutex-lock! m)
+      (eq? (mutex-state m) (current-thread))))
+	  
+  (pass-if "mutex state of locked, unowned mutex is not-owned"
+    (let ((m (make-mutex 'mutex-state-3)))
+      (mutex-lock! m #f #f)
+      (eq? (mutex-state m) 'not-owned)))
+
+  (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
+    (let* ((m (make-mutex 'mutex-state-4))
+	   (t (make-thread (lambda () (mutex-lock! m)))))
+      (thread-start! t)
+      (thread-join! t)
+      (eq? (mutex-state m) 'abandoned))))
+
+(with-test-prefix "mutex-lock!"
+  
+  (pass-if "mutex-lock! returns true on successful lock"
+    (let* ((m (make-mutex 'mutex-lock-1)))
+      (mutex-lock! m)))
+
+  (pass-if "mutex-lock! returns false on timeout"
+    (let* ((m (make-mutex 'mutex-lock-2))
+	   (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
+      (mutex-lock! m)
+      (thread-start! t)
+      (not (thread-join! t))))
+
+  (pass-if "mutex-lock! returns true when lock obtained within timeout"
+    (let* ((m (make-mutex 'mutex-lock-3))
+	   (t (make-thread (lambda () 
+			     (mutex-lock! m (+ (time->seconds (current-time)) 
+					       100)
+					  #f)))))
+      (mutex-lock! m)
+      (thread-start! t)
+      (mutex-unlock! m)
+      (thread-join! t)))
+
+  (pass-if "can lock mutex for non-current thread"
+    (let* ((m1 (make-mutex 'mutex-lock-4a))
+	   (m2 (make-mutex 'mutex-lock-4b))
+	   (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
+      (mutex-lock! m1)
+      (thread-start! t)
+      (mutex-lock! m2 #f t)
+      (let ((success (eq? (mutex-state m2) t))) 
+	(thread-terminate! t) success)))
+
+  (pass-if "locking abandoned mutex throws exception"
+    (let* ((m (make-mutex 'mutex-lock-5))
+	   (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
+	   (success #f))
+      (thread-start! t)
+      (thread-join! t)
+      (with-exception-handler
+       (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
+       (lambda () (mutex-lock! m)))
+      (and success (eq? (mutex-state m) (current-thread)))))
+
+  (pass-if "sleeping threads notified of abandonment"
+    (let* ((m1 (make-mutex 'mutex-lock-6a))
+	   (m2 (make-mutex 'mutex-lock-6b))
+	   (c (make-condition-variable 'mutex-lock-6))
+	   (t (make-thread (lambda () 
+			     (mutex-lock! m1)
+			     (mutex-lock! m2)
+			     (condition-variable-signal! c))))
+	   (success #f))
+      (mutex-lock! m1)
+      (thread-start! t)
+      (with-exception-handler
+       (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
+       (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
+      success)))
+
+(with-test-prefix "mutex-unlock!"
+   
+  (pass-if "unlock changes mutex state"
+    (let* ((m (make-mutex 'mutex-unlock-1)))
+      (mutex-lock! m)
+      (mutex-unlock! m)
+      (eq? (mutex-state m) 'not-abandoned)))
+
+  (pass-if "can unlock from any thread"
+    (let* ((m (make-mutex 'mutex-unlock-2))
+	   (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
+      (mutex-lock! m)
+      (thread-start! t)
+      (thread-join! t)
+      (eq? (mutex-state m) 'not-abandoned)))
+
+  (pass-if "mutex unlock is true when condition is signalled"
+    (let* ((m (make-mutex 'mutex-unlock-3))
+	   (c (make-condition-variable 'mutex-unlock-3))
+	   (t (make-thread (lambda () 
+			     (mutex-lock! m) 
+			     (condition-variable-signal! c) 
+			     (mutex-unlock! m)))))
+      (mutex-lock! m)
+      (thread-start! t)
+      (mutex-unlock! m c)))
+
+  (pass-if "mutex unlock is false when condition times out"
+    (let* ((m (make-mutex 'mutex-unlock-4))
+	   (c (make-condition-variable 'mutex-unlock-4)))
+      (mutex-lock! m)
+      (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
+
+(with-test-prefix "condition-variable?"
+
+  (pass-if "make-condition-variable creates condition variable"
+    (condition-variable? (make-condition-variable)))
+
+  (pass-if "symbol not condition variable"
+    (not (condition-variable? 'foo))))
+
+(with-test-prefix "condition-variable-name"
+
+  (pass-if "make-condition-variable with name binds name"
+    (let* ((c (make-condition-variable 'condition-variable-name-1)))
+      (eq? (condition-variable-name c) 'condition-variable-name-1)))
+
+  (pass-if "make-condition-variable without name does not bind name"
+    (let* ((c (make-condition-variable)))
+      (not (condition-variable-name c)))))
+
+(with-test-prefix "condition-variable-specific"
+
+  (pass-if "condition-variable-specific is initially #f"
+    (let ((c (make-condition-variable 'condition-variable-specific-1)))
+      (not (condition-variable-specific c))))
+
+  (pass-if "condition-variable-specific-set! can set value"
+    (let ((c (make-condition-variable 'condition-variable-specific-1)))
+      (condition-variable-specific-set! c "hello")
+      (equal? (condition-variable-specific c) "hello"))))
+
+(with-test-prefix "condition-variable-signal!"
+  
+  (pass-if "condition-variable-signal! wakes up single thread"
+    (let* ((m (make-mutex 'condition-variable-signal-1))
+	   (c (make-condition-variable 'condition-variable-signal-1))
+	   (t (make-thread (lambda () 
+			     (mutex-lock! m) 
+			     (condition-variable-signal! c) 
+			     (mutex-unlock! m)))))
+      (mutex-lock! m)
+      (thread-start! t)
+      (mutex-unlock! m c))))
+
+(with-test-prefix "condition-variable-broadcast!"
+
+  (pass-if "condition-variable-broadcast! wakes up multiple threads"
+    (let* ((sem 0)
+	   (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
+	   (m1 (make-mutex 'condition-variable-broadcast-1-a))
+	   (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
+	   (m2 (make-mutex 'condition-variable-broadcast-1-b))
+	   (inc-sem! (lambda () 
+		       (mutex-lock! m1)
+		       (set! sem (+ sem 1))
+		       (condition-variable-broadcast! c1)
+		       (mutex-unlock! m1)))
+	   (dec-sem! (lambda ()
+		       (mutex-lock! m1)
+		       (while (eqv? sem 0) (wait-condition-variable c1 m1))
+		       (set! sem (- sem 1))
+		       (mutex-unlock! m1)))
+	   (t1 (make-thread (lambda () 
+			      (mutex-lock! m2)
+			      (inc-sem!)
+			      (mutex-unlock! m2 c2)
+			      (inc-sem!))))
+	   (t2 (make-thread (lambda () 
+			      (mutex-lock! m2)
+			      (inc-sem!)
+			      (mutex-unlock! m2 c2)
+			      (inc-sem!)))))
+      (thread-start! t1)
+      (thread-start! t2)
+      (dec-sem!)
+      (dec-sem!)
+      (mutex-lock! m2)
+      (condition-variable-broadcast! c2)
+      (mutex-unlock! m2)
+      (dec-sem!)
+      (dec-sem!))))
+
+(with-test-prefix "time?"
+
+  (pass-if "current-time is time" (time? (current-time)))
+  (pass-if "number is not time" (not (time? 123)))
+  (pass-if "symbol not time" (not (time? 'foo))))
+
+(with-test-prefix "time->seconds"
+
+  (pass-if "time->seconds makes time into rational"
+    (rational? (time->seconds (current-time))))
+
+  (pass-if "time->seconds is reversible"
+    (let ((t (current-time)))
+      (equal? t (seconds->time (time->seconds t))))))
+
+(with-test-prefix "seconds->time"
+
+  (pass-if "seconds->time makes rational into time"
+    (time? (seconds->time 123.456)))
+
+  (pass-if "seconds->time is reversible"
+    (let ((t (time->seconds (current-time))))
+      (equal? t (time->seconds (seconds->time t))))))
+
+(with-test-prefix "current-exception-handler"
+
+  (pass-if "current handler returned at top level"
+    (procedure? (current-exception-handler)))
+
+  (pass-if "specified handler set under with-exception-handler"
+    (let ((h (lambda (key . args) 'nothing)))
+      (with-exception-handler h (lambda () (eq? (current-exception-handler) 
+						h)))))
+
+  (pass-if "multiple levels of handler nesting"
+    (let ((h (lambda (key . args) 'nothing))
+	  (i (current-exception-handler)))
+      (and (with-exception-handler h (lambda () 
+				       (eq? (current-exception-handler) h)))
+	   (eq? (current-exception-handler) i))))
+
+  (pass-if "exception handler installation is thread-safe"
+    (let* ((h1 (current-exception-handler))
+	   (h2 (lambda (key . args) 'nothing-2))
+	   (m (make-mutex 'current-exception-handler-4))
+	   (c (make-condition-variable 'current-exception-handler-4))
+	   (t (make-thread (lambda () 
+			     (with-exception-handler 
+			      h2 (lambda () 
+				   (mutex-lock! m) 
+				   (condition-variable-signal! c) 
+				   (wait-condition-variable c m)
+				   (and (eq? (current-exception-handler) h2)
+					(mutex-unlock! m)))))
+			   'current-exception-handler-4)))
+      (mutex-lock! m)
+      (thread-start! t)
+      (wait-condition-variable c m)
+      (and (eq? (current-exception-handler) h1)
+	   (condition-variable-signal! c)
+	   (mutex-unlock! m)
+	   (thread-join! t)))))
+
+(with-test-prefix "uncaught-exception-reason"
+
+  (pass-if "initial handler captures top level exception"
+    (let ((t (make-thread (lambda () (raise 'foo))))
+	  (success #f))
+      (thread-start! t)
+      (with-exception-handler
+       (lambda (obj)
+	 (and (uncaught-exception? obj)
+	      (eq? (uncaught-exception-reason obj) 'foo)
+	      (set! success #t)))
+       (lambda () (thread-join! t)))
+      success))
+
+  (pass-if "initial handler captures non-SRFI-18 throw"
+    (let ((t (make-thread (lambda () (throw 'foo))))
+	  (success #f))
+      (thread-start! t)
+      (with-exception-handler
+       (lambda (obj)
+	 (and (uncaught-exception? obj)
+	      (eq? (uncaught-exception-reason obj) 'foo)
+	      (set! success #t)))
+       (lambda () (thread-join! t)))
+      success)))
-- 
1.5.4.3