Re: srfi-18 requirements

["Julian Graham" <joolean@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1655 bytes --]

Hi Neil,

(Apologies for the delay in getting this to you -- a host of
professional and personal crises reared up over the last week or so.)

Find attached a patch (in two parts -- sorry, still getting used to
git) to the core threading code that includes the changes we
discussed, specifically:

* Re-added support for locking mutexes with an owner other than the
current thread
* Enabled the previously ifdef'd out functions scm_mutex_owner and
scm_mutex_level
* Added a new function, scm_mutex_locked_p, useful for distinguishing
between unlocked and unowned mutex states.
* Updated the threads.test file to reflect the changes above
* Updated the documentation in api-scheduling.texi to reflect the changes above
* Updated the ChangeLog to reflect the changes above

Also attached are updated versions of the Scheme SRFI-18
implementation as well as the SRFI-18-specific test code.

A couple of notes: For purposes of elegance, I've changed semantics of
fat_mutex.level -- where previously all non-recursive mutexes had a
level of -1, recursiveness is now denoted by an integer field on
fat_mutex.  Any mutex (recursive or not) is in a locked state iff its
level is greater than 0.

Second, during the testing I did for this round of changes, I noticed
a few more deadlocks that I believe are related to the existing core
threading model (as opposed to the changes included in this patch).
These seem to crop up when I run overnight tests on modified core
code, probably because different timings and thread interactions are
introduced.  I think I've got fixes for some of them, and I'll
follow-up in a separate mailing list thread.


Regards,
Julian

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-latest-set-of-SRFI-18-support-changes-to-core-thread.patch --]
[-- Type: text/x-diff; name=0001-latest-set-of-SRFI-18-support-changes-to-core-thread.patch, Size: 14332 bytes --]

From 4f04a30ccb5f4129c0720f6b10bbad3ef9244cb6 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian@smokebottle.(none)>
Date: Sun, 13 Apr 2008 19:51:23 -0400
Subject: [PATCH] latest set of SRFI-18 support changes to core threads

---
 doc/ref/api-scheduling.texi   |   33 +++++++-
 libguile/threads.c            |  162 ++++++++++++++++++++++------------------
 libguile/threads.h            |    5 +-
 test-suite/tests/threads.test |   46 ++++++++++++
 4 files changed, 168 insertions(+), 78 deletions(-)

diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index ec136fb..29eed5e 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -409,17 +409,21 @@ function is equivalent to calling `make-mutex' and specifying the
 @code{recursive} flag.
 @end deffn
 
-@deffn {Scheme Procedure} lock-mutex mutex [timeout]
+@deffn {Scheme Procedure} lock-mutex mutex [timeout [owner]]
 @deffnx {C Function} scm_lock_mutex (mutex)
-@deffnx {C Function} scm_lock_mutex_timed (mutex, timeout)
-Lock @var{mutex}.  If the mutex is already locked by another thread
-then block and return only when @var{mutex} has been acquired.
+@deffnx {C Function} scm_lock_mutex_timed (mutex, timeout, owner)
+Lock @var{mutex}.  If the mutex is already locked, then block and 
+return only when @var{mutex} has been acquired.
 
 When @var{timeout} is given, it specifies a point in time where the 
 waiting should be aborted.  It can be either an integer as returned 
 by @code{current-time} or a pair as returned by @code{gettimeofday}.  
 When the waiting is aborted, @code{#f} is returned. 
 
+When @var{owner} is given, it specifies an owner for @var{mutex} other
+than the calling thread.  @var{owner} may also be @code{#f}, 
+indicating that the mutex should be locked but left unowned.
+
 For standard mutexes (@code{make-mutex}), and error is signalled if
 the thread has itself already locked @var{mutex}.
 
@@ -471,6 +475,27 @@ returned by @code{current-time} or a pair as returned by
 returned.  Otherwise the function returns @code{#t}.
 @end deffn
 
+@deffn {Scheme Procedure} mutex-owner mutex
+@deffnx {C Function} scm_mutex_owner (mutex)
+Return the current owner of @var{mutex}, in the form of a thread or 
+@code{#f} (indicating no owner).  Note that a mutex may be unowned but
+still locked.
+@end deffn
+
+@deffn {Scheme Procedure} mutex-level mutex
+@deffnx {C Function} scm_mutex_level (mutex)
+Return the current lock level of @var{mutex}.  If @var{mutex} is
+currently unlocked, this value will be 0; otherwise, it will be the
+number of times @var{mutex} has been recursively locked by its current
+owner.
+@end deffn
+
+@deffn {Scheme Procedure} mutex-locked? mutex
+@deffnx {C Function} scm_mutex_locked_p (mutex)
+Return @code{#t} if @var{mutex} is locked, regardless of ownership;
+otherwise, return @code{#f}.
+@end deffn
+
 @deffn {Scheme Procedure} make-condition-variable
 @deffnx {C Function} scm_make_condition_variable ()
 Return a new condition variable.
diff --git a/libguile/threads.c b/libguile/threads.c
index 68c5f79..938644c 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -511,9 +511,9 @@ guilify_self_2 (SCM parent)
 typedef struct {
   scm_i_pthread_mutex_t lock;
   SCM owner;
-  int level;      /* how much the owner owns us.  
-		     < 0 for non-recursive mutexes */
+  int level; /* how much the owner owns us.  <= 1 for non-recursive mutexes */
 
+  int recursive; /* allow recursive locking? */
   int unchecked_unlock; /* is it an error to unlock an unlocked mutex? */
   int allow_external_unlock; /* is it an error to unlock a mutex that is not
 				owned by the current thread? */
@@ -1154,8 +1154,9 @@ make_fat_mutex (int recursive, int unchecked_unlock, int external_unlock)
   m = scm_gc_malloc (sizeof (fat_mutex), "mutex");
   scm_i_pthread_mutex_init (&m->lock, NULL);
   m->owner = SCM_BOOL_F;
-  m->level = recursive? 0 : -1;
+  m->level = 0;
 
+  m->recursive = recursive;
   m->unchecked_unlock = unchecked_unlock;
   m->allow_external_unlock = external_unlock;
 
@@ -1211,79 +1212,77 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0,
 SCM_SYMBOL (scm_abandoned_mutex_error_key, "abandoned-mutex-error");
 
 static SCM
-fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret)
+fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
 {
   fat_mutex *m = SCM_MUTEX_DATA (mutex);
 
-  SCM thread = scm_current_thread ();
-  scm_i_thread *t = SCM_I_THREAD_DATA (thread);
-
+  SCM new_owner = SCM_UNBNDP (owner) ? scm_current_thread() : owner;
   SCM err = SCM_BOOL_F;
 
   struct timeval current_time;
 
   scm_i_scm_pthread_mutex_lock (&m->lock);
-  if (scm_is_false (m->owner))
-    {
-      m->owner = thread;
-      scm_i_pthread_mutex_lock (&t->admin_mutex);
-      t->mutexes = scm_cons (mutex, t->mutexes);
-      scm_i_pthread_mutex_unlock (&t->admin_mutex);
-      *ret = 1;
-    }
-  else if (scm_is_eq (m->owner, thread))
+
+  while (1)
     {
-      if (m->level >= 0)
+      if (m->level == 0)
 	{
+	  m->owner = new_owner;
 	  m->level++;
-	  *ret = 1;
-	}
-      else
-	err = scm_cons (scm_misc_error_key,
-			scm_from_locale_string ("mutex already locked by "
-						"current thread"));
-    }
-  else
-    {
-      int first_iteration = 1;
-      while (1)
-	{
-	  if (scm_is_eq (m->owner, thread) || scm_c_thread_exited_p (m->owner))
+	  
+	  if (SCM_I_IS_THREAD (new_owner))
 	    {
+	      scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
 	      scm_i_pthread_mutex_lock (&t->admin_mutex);
 	      t->mutexes = scm_cons (mutex, t->mutexes);
 	      scm_i_pthread_mutex_unlock (&t->admin_mutex);
-	      *ret = 1;
-	      if (scm_c_thread_exited_p (m->owner)) 
-		{
-		  m->owner = thread;
-		  err = scm_cons (scm_abandoned_mutex_error_key,
-				  scm_from_locale_string ("lock obtained on "
-							  "abandoned mutex"));
-		}
-	      break;
 	    }
-	  else if (!first_iteration)
+	  *ret = 1;
+	  break;
+	}
+      else if (SCM_I_IS_THREAD (m->owner) && scm_c_thread_exited_p (m->owner))
+	{
+	  m->owner = new_owner;
+	  err = scm_cons (scm_abandoned_mutex_error_key,
+			  scm_from_locale_string ("lock obtained on abandoned "
+						  "mutex"));
+	  *ret = 1;
+	  break;
+	}
+      else if (scm_is_eq (m->owner, new_owner))
+	{
+	  if (m->recursive)
+	    {
+	      m->level++;
+	      *ret = 1;		  
+	    }
+	  else
 	    {
-	      if (timeout != NULL) 
+	      err = scm_cons (scm_misc_error_key,
+			      scm_from_locale_string ("mutex already locked "
+						      "by thread"));
+	      *ret = 0;
+	    }
+	  break;  
+	}
+      else
+	{
+	  if (timeout != NULL) 
+	    {
+	      gettimeofday (&current_time, NULL);
+	      if (current_time.tv_sec > timeout->tv_sec ||
+		  (current_time.tv_sec == timeout->tv_sec &&
+		   current_time.tv_usec * 1000 > timeout->tv_nsec))
 		{
-		  gettimeofday (&current_time, NULL);
-		  if (current_time.tv_sec > timeout->tv_sec ||
-		      (current_time.tv_sec == timeout->tv_sec &&
-		       current_time.tv_usec * 1000 > timeout->tv_nsec))
-		    {
-		      *ret = 0;
-		      break;
-		    }
+		  *ret = 0;
+		  break;
 		}
-	      scm_i_pthread_mutex_unlock (&m->lock);
-	      SCM_TICK;
-	      scm_i_scm_pthread_mutex_lock (&m->lock);
 	    }
-	  else
-	    first_iteration = 0;
-	  block_self (m->waiting, mutex, &m->lock, timeout);
+	  scm_i_pthread_mutex_unlock (&m->lock);
+	  SCM_TICK;
+	  scm_i_scm_pthread_mutex_lock (&m->lock);
 	}
+      block_self (m->waiting, mutex, &m->lock, timeout);
     }
   scm_i_pthread_mutex_unlock (&m->lock);
   return err;
@@ -1291,11 +1290,11 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret)
 
 SCM scm_lock_mutex (SCM mx)
 {
-  return scm_lock_mutex_timed (mx, SCM_UNDEFINED);
+  return scm_lock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED);
 }
 
-SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 1, 0,
-	    (SCM m, SCM timeout),
+SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0,
+	    (SCM m, SCM timeout, SCM owner),
 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
 "blocks until the mutex becomes available. The function returns when "
 "the calling thread owns the lock on @var{mutex}.  Locking a mutex that "
@@ -1315,7 +1314,7 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 1, 0,
       waittime = &cwaittime;
     }
 
-  exception = fat_mutex_lock (m, waittime, &ret);
+  exception = fat_mutex_lock (m, waittime, owner, &ret);
   if (!scm_is_false (exception))
     scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);
   return ret ? SCM_BOOL_T : SCM_BOOL_F;
@@ -1346,7 +1345,7 @@ SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
   to_timespec (scm_from_int(0), &cwaittime);
   waittime = &cwaittime;
   
-  exception = fat_mutex_lock (mutex, waittime, &ret);
+  exception = fat_mutex_lock (mutex, waittime, SCM_UNDEFINED, &ret);
   if (!scm_is_false (exception))
     scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);
   return ret ? SCM_BOOL_T : SCM_BOOL_F;
@@ -1373,15 +1372,19 @@ fat_mutex_unlock (SCM mutex, SCM cond,
   int err = 0, ret = 0;
 
   scm_i_scm_pthread_mutex_lock (&m->lock);
-  if (!scm_is_eq (m->owner, scm_current_thread ()))
+
+  SCM owner = m->owner;
+
+  if (!scm_is_eq (owner, scm_current_thread ()))
     {
-      if (scm_is_false (m->owner))
+      if (m->level == 0)
 	{
 	  if (!m->unchecked_unlock)
 	    {
 	      scm_i_pthread_mutex_unlock (&m->lock);
 	      scm_misc_error (NULL, "mutex not locked", SCM_EOL);
 	    }
+	  owner = scm_current_thread ();
 	}
       else if (!m->allow_external_unlock)
 	{
@@ -1392,8 +1395,6 @@ fat_mutex_unlock (SCM mutex, SCM cond,
 
   if (! (SCM_UNBNDP (cond)))
     {
-      int lock_ret = 0;
-
       c = SCM_CONDVAR_DATA (cond);
       while (1)
 	{
@@ -1402,8 +1403,9 @@ fat_mutex_unlock (SCM mutex, SCM cond,
 	  scm_i_scm_pthread_mutex_lock (&c->lock);
 	  if (m->level > 0)
 	    m->level--;
-	  else
+	  if (m->level == 0)
 	    m->owner = unblock_from_queue (m->waiting);
+
 	  scm_i_pthread_mutex_unlock (&m->lock);
 	  
 	  t->block_asyncs++;
@@ -1430,7 +1432,7 @@ fat_mutex_unlock (SCM mutex, SCM cond,
 	  if (brk)
 	    {
 	      if (relock)
-		fat_mutex_lock (mutex, NULL, &lock_ret);
+		scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner);
 	      scm_i_pthread_mutex_unlock (&c->lock);
 	      break;
 	    }
@@ -1449,8 +1451,9 @@ fat_mutex_unlock (SCM mutex, SCM cond,
     {
       if (m->level > 0)
 	m->level--;
-      else
+      if (m->level == 0) 
 	m->owner = unblock_from_queue (m->waiting);
+	  
       scm_i_pthread_mutex_unlock (&m->lock);
       ret = 1;
     }
@@ -1501,22 +1504,27 @@ SCM_DEFINE (scm_mutex_p, "mutex?", 1, 0, 0,
 }
 #undef FUNC_NAME 
 
-#if 0
-
 SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0,
 	    (SCM mx),
 	    "Return the thread owning @var{mx}, or @code{#f}.")
 #define FUNC_NAME s_scm_mutex_owner
 {
+  SCM owner;
+  fat_mutex *m = NULL;
+
   SCM_VALIDATE_MUTEX (1, mx);
-  return (SCM_MUTEX_DATA(mx))->owner;
+  m = SCM_MUTEX_DATA (mx);
+  scm_i_pthread_mutex_lock (&m->lock);
+  owner = m->owner;
+  scm_i_pthread_mutex_unlock (&m->lock);
+
+  return owner;
 }
 #undef FUNC_NAME
 
 SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0,
 	    (SCM mx),
-	    "Return the lock level of a recursive mutex, or -1\n"
-	    "for a standard mutex.")
+	    "Return the lock level of mutex @var{mx}.")
 #define FUNC_NAME s_scm_mutex_level
 {
   SCM_VALIDATE_MUTEX (1, mx);
@@ -1524,7 +1532,15 @@ SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-#endif
+SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0,
+	    (SCM mx),
+	    "Returns @code{#t} if the mutex @var{mx} is locked.")
+#define FUNC_NAME s_scm_mutex_locked_p
+{
+  SCM_VALIDATE_MUTEX (1, mx);
+  return SCM_MUTEX_DATA (mx)->level > 0 ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
 
 static SCM
 fat_cond_mark (SCM cv)
diff --git a/libguile/threads.h b/libguile/threads.h
index e1944a5..d10e0f8 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -170,12 +170,15 @@ SCM_API SCM scm_make_mutex (void);
 SCM_API SCM scm_make_recursive_mutex (void);
 SCM_API SCM scm_make_mutex_with_flags (SCM flags);
 SCM_API SCM scm_lock_mutex (SCM m);
-SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout);
+SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner);
 SCM_API void scm_dynwind_lock_mutex (SCM mutex);
 SCM_API SCM scm_try_mutex (SCM m);
 SCM_API SCM scm_unlock_mutex (SCM m);
 SCM_API SCM scm_unlock_mutex_timed (SCM m, SCM cond, SCM timeout);
 SCM_API SCM scm_mutex_p (SCM o);
+SCM_API SCM scm_mutex_locked_p (SCM m);
+SCM_API SCM scm_mutex_owner (SCM m);
+SCM_API SCM scm_mutex_level (SCM m);
 
 SCM_API SCM scm_make_condition_variable (void);
 SCM_API SCM scm_wait_condition_variable (SCM cond, SCM mutex);
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index 62ee0cd..9cd062d 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -279,6 +279,52 @@
 	  (not (thread-cleanup (current-thread)))))
 
       ;;
+      ;; mutex ownership
+      ;;
+
+      (with-test-prefix "mutex-ownership"
+	(pass-if "mutex ownership for locked mutex"
+	  (let ((m (make-mutex)))
+	    (lock-mutex m)
+	    (eq? (mutex-owner m) (current-thread))))
+
+	(pass-if "mutex ownership for unlocked mutex"
+	  (let ((m (make-mutex)))
+	    (not (mutex-owner m))))
+
+	(pass-if "locking mutex on behalf of other thread"
+	  (let* ((m (make-mutex))
+		 (t (begin-thread 'foo)))
+	    (lock-mutex m #f t)
+	    (eq? (mutex-owner m) t)))
+
+        (pass-if "locking mutex with no owner"
+	  (let ((m (make-mutex)))
+	    (lock-mutex m #f #f)
+	    (not (mutex-owner m)))))
+
+      ;;
+      ;; mutex lock levels
+      ;;
+
+      (with-test-prefix "mutex-lock-levels"
+			
+        (pass-if "unlocked level is 0"
+	  (let ((m (make-mutex)))
+	    (and (not (mutex-locked? m)) (eqv? (mutex-level m) 0))))
+
+        (pass-if "non-recursive lock level is 1"
+	  (let ((m (make-mutex)))
+	    (lock-mutex m)
+	    (and (mutex-locked? m) (eqv? (mutex-level m) 1))))
+
+	(pass-if "recursive lock level is >1"
+	  (let ((m (make-mutex 'recursive)))
+	    (lock-mutex m)
+	    (lock-mutex m)
+	    (and (mutex-locked? m) (eqv? (mutex-level m) 2)))))
+
+      ;;
       ;; mutex behavior
       ;;
 
-- 
1.5.4.3


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-ChangeLog-updates-for-latest-set-of-SRFI-18-changes.patch --]
[-- Type: text/x-diff; name=0002-ChangeLog-updates-for-latest-set-of-SRFI-18-changes.patch, Size: 2507 bytes --]

From e9a8373bd67f8b39ad378175931fa258f953a3ba Mon Sep 17 00:00:00 2001
From: Julian Graham <julian@smokebottle.(none)>
Date: Sun, 13 Apr 2008 20:31:18 -0400
Subject: [PATCH] ChangeLog updates for latest set of SRFI-18 changes

---
 doc/ref/ChangeLog    |    8 ++++++++
 libguile/ChangeLog   |   14 ++++++++++++++
 test-suite/ChangeLog |    9 +++++++++
 3 files changed, 31 insertions(+), 0 deletions(-)

diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog
index 7719819..4a0a943 100644
--- a/doc/ref/ChangeLog
+++ b/doc/ref/ChangeLog
@@ -1,3 +1,11 @@
+2008-04-13  Julian Graham  <joolean@gmail.com>
+
+	* api-scheduling.texi (Mutexes and Condition Variables): Add
+	documentation for new functions "scm_mutex_owner",
+	"scm_mutex_level", and "scm_mutex_locked_p".  Update
+	documentation for function "scm_lock_mute_timed" to reflect
+	addition of optional ownership argument.
+
 2008-03-28  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* libguile-concepts.texi (Multi-Threading): Fix typo.
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index ea75158..48a849e 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,17 @@
+2008-04-13  Julian Graham  <joolean@gmail.com>
+
+	* threads.c (fat_mutex)[recursive]: New field.
+	(make_fat_mutex): Adjust initialization to reflect changes to
+	mutex lock level semantics.
+	(fat_mutex_lock, fat_mutex_unlock): Add support for unowned 
+	mutexes and locking mutexes on behalf of other threads.
+	(scm_lock_mutex, scm_lock_mutex_timed): Update to reflect
+	signature change to fat_mutex_lock.
+	(scm_mutex_owner, scm_mutex_level, scm_mutex_locked_p): New /
+	re-enabled functions.
+	* threads.h (scm_mutex_owner, scm_mutex_level, 
+	scm_mutex_locked_p): Prototypes for new functions.
+
 2008-04-13  Ludovic Courtès  <ludo@gnu.org>
 
 	* inline.h (SCM_C_USE_EXTERN_INLINE): New macro.  Use it to make
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index 7b546b3..fcacd9c 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,12 @@
+2008-04-13  Julian Graham  <joolean@gmail.com>
+
+	* tests/threads.test (mutex-ownership, mutex-lock-levels): New 
+	test prefix.
+	(mutex ownership for locked mutex, mutex ownership for unlocked
+	mutex, locking mutex on behalf of other thread, locking mutex
+	with no owner, unlocked level is 0, non-recursive lock level
+	is 1, recursive lock level is >1): New tests.
+
 2008-04-13  Ludovic Courtès  <ludo@gnu.org>
 
 	* tests/goops.test (defining classes)[interaction with
-- 
1.5.4.3


[-- Attachment #4: srfi-18.scm --]
[-- Type: application/octet-stream, Size: 12057 bytes --]

;;; 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 <julian.graham@aya.yale.edu>
;;; 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

[-- Attachment #5: srfi-18.test --]
[-- Type: application/octet-stream, Size: 15868 bytes --]

;;;; 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)))