* Improved the threads test suite.

* Removed unnecessary references in header files.

7 files changed, 174 insertions, 131 deletions

diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index d5960e2fc..8801b50e6 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,12 @@
+2000-06-08  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* coop.c (scm_I_am_dead):  Made static and renamed to I_am_dead.
+
+	* coop.h (scm_internal_select, scm_I_am_dead), iselect.h
+	(scm_I_am_dead, scm_init_iselect):  Removed references.
+
+	* threads.c (mutex_free):  Added comment.
+
 2000-06-07  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* feature.c (scm_init_feature):  Let the threads subsystem take
diff --git a/libguile/coop.c b/libguile/coop.c
index f8f4d4554..8182e2565 100644
--- a/libguile/coop.c
+++ b/libguile/coop.c
@@ -40,7 +40,7 @@
  * If you do not wish that, delete this exception notice.  */
 
 
-/* $Id: coop.c,v 1.25.2.1 2000-06-06 15:20:17 dirk Exp $ */
+/* $Id: coop.c,v 1.25.2.2 2000-06-08 14:26:09 dirk Exp $ */
 
 /* Cooperative thread library, based on QuickThreads */
 
@@ -192,6 +192,8 @@ static void coop_only (void *pu, void *pt, qt_userf_t *f);
 static void *coop_aborthelp (qt_t *sp, void *old, void *null);
 static void *coop_yieldhelp (qt_t *sp, void *old, void *blockq);
 
+static int I_am_dead;
+
 
 /* called on process termination.  */
 #ifdef HAVE_ATEXIT
@@ -699,11 +701,11 @@ coop_abort ()
     }
 
 #ifdef GUILE_ISELECT
-  scm_I_am_dead = 1;
+  I_am_dead = 1;
   do {
     newthread = coop_wait_for_runnable_thread();
   } while (newthread == coop_global_curr);
-  scm_I_am_dead = 0;
+  I_am_dead = 0;
 #else
   newthread = coop_next_runnable_thread();
 #endif
@@ -861,8 +863,6 @@ typedef unsigned long *ulongptr;
 static char bc[256]; /* Bit counting array.  bc[x] is the number of
 			bits in x. */
 
-int scm_I_am_dead;
-
 /* This flag indicates that several threads are waiting on the same
    file descriptor.  When this is the case, the common fd sets are
    updated in a more inefficient way.  */
@@ -1197,7 +1197,7 @@ find_thread (int n, struct timeval *now, int sleepingp)
        error to all of them.  */
     {
       error_revive_threads ();
-      if (!scm_I_am_dead)
+      if (!I_am_dead)
 	return coop_global_curr;
     }
   else if (n == 0)
diff --git a/libguile/coop.h b/libguile/coop.h
index fbd5cd257..b5ab30ff4 100644
--- a/libguile/coop.h
+++ b/libguile/coop.h
@@ -94,18 +94,6 @@ Here starts the content of iselect.h:
 
 #endif /* no FD_SET */
 
-extern int scm_internal_select (int fds,
-				SELECT_TYPE *rfds,
-				SELECT_TYPE *wfds,
-				SELECT_TYPE *efds,
-				struct timeval *timeout);
-
-#ifdef GUILE_ISELECT
-
-extern int scm_I_am_dead;
-
-#endif /* GUILE_ISELECT */
-
 
 /*****************************************************************************
 Here ends the content of iselect.h:
diff --git a/libguile/iselect.h b/libguile/iselect.h
index e2a04f5e7..6af102ddc 100644
--- a/libguile/iselect.h
+++ b/libguile/iselect.h
@@ -90,14 +90,6 @@ extern int scm_internal_select (int fds,
 				SELECT_TYPE *efds,
 				struct timeval *timeout);
 
-#ifdef GUILE_ISELECT
-
-extern int scm_I_am_dead;
-
-extern void scm_init_iselect (void);
-
-#endif /* GUILE_ISELECT */
-
 #endif
 
 /*
diff --git a/libguile/threads.c b/libguile/threads.c
index d94ba7861..34f9cc23d 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -506,6 +506,9 @@ SCM_DEFINE(scm_mutex_unlock, "mutex-unlock", 1, 0, 0,
 static scm_sizet
 mutex_free (SCM mutex)
 {
+  /* Dirk:FIXME:: What happens to the threads that are blocked because of this
+   * mutex?  They will never wake up again.  */
+
   return (* scm_thread.mutex_free) (SCM_MUTEX_DATA (mutex));  
 }
 
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index ef4183374..001f35f5c 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,8 @@
+2000-06-08  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* tests/threads.test:  Restructured, added some tests, always
+	check if threads are provided at all.
+
 2000-06-06  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* lib.scm (pass-if, expect-fail):  Generalized to allow a sequence
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index 730ecfbec..a4855f89c 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -48,196 +48,242 @@
 ;;;
 
 
-(define (pass-if-documented identifier)
-  (with-test-prefix "documented?"
-    (pass-if identifier
-      (let ((documented #f))
-	(with-output-to-string
-	  (lambda ()
-	    (set! documented (documentation identifier))))
-	documented))))
+(define (check-feature feature)
+  (if (not (provided? feature))
+      (throw 'unsupported)))
 
 
-(define (true)
+(define (documented? identifier)
+  (let ((documented #f))
+    (with-output-to-string
+      (lambda ()
+	(set! documented (documentation identifier))))
+    documented))
+
+
+(define (default-error-handler)
   #t)
 
 
+(defmacro repeat (count body . rest)
+  `(let ((c ,count))
+     (do ((i 0 (+ i 1)))
+	 ((= i ,count))
+       ,body
+       ,@rest)))
+
+
 ;;;
 ;;; threads
 ;;;
 
 (with-test-prefix "threads"
 
-  ;; Is documentation available?
+  (with-test-prefix "call-with-new-thread"
 
-  (pass-if-documented "call-with-new-thread")
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "call-with-new-thread"))
 
-  (pass-if-documented "thread?")
+    (pass-if "thread runs and exits"
+      (check-feature 'threads)
+      (let* ((flag #f)
+	     (function (lambda () (set! flag #t)))
+	     (thread (call-with-new-thread function default-error-handler)))
+	(thread-join thread)
+	flag))
 
-  (pass-if-documented "thread-exit")
+    ;; Check for threads spawning other threads
 
-  (pass-if-documented "thread-cancel")
+    ;; Check for correct application of the error handler
 
-  (pass-if-documented "thread-join")
+    ;; Check for correct handling of parameter errors
+    ;; 1) wrong type instead of thread function
+    ;; 2) wrong thread function arity
+    ;; 3) wrong type instead of handler function
+    ;; 4) wrong handler function arity
 
-  (pass-if-documented "thread-yield")
+    )
 
-  ;; Functionality
+  (with-test-prefix "thread?"
 
-  (with-test-prefix "core functionality"
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "thread?"))
 
-    (pass-if "assignment"
-      (let* ((flag #f))
-	(call-with-new-thread
-	 (lambda () 
-	   (set! flag #t))
-	 true)
-	flag))
+    (pass-if "new thread"
+      (check-feature 'threads)
+      (let* ((function (lambda () #t))
+	     (t (call-with-new-thread function default-error-handler)))
+	(thread? t)))
 
-    (pass-if "assignment after exit"
-      (let* ((flag #f))
-	(call-with-new-thread
-	 (lambda () 
-	   (thread-exit 0) 
-	   (set! flag #t))
-	 true)
-	(not flag)))
+    (pass-if "non-thread"
+      (check-feature 'threads)
+      (not (thread? 0))))
 
-    (pass-if "join yield assignment"
-      (let* ((flag #f)
-	     (thread
-	      (call-with-new-thread
-	       (lambda () 
-		 (thread-yield) 
-		 (thread-yield) 
-		 (thread-yield) 
-		 (set! flag #t))
-	       true)))
-	(thread-join thread)
-	flag))
+  (with-test-prefix "thread-exit"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "thread-exit"))
 
-    (pass-if "cancel yield assignment"
+    (pass-if "thread exits appropriately"
+      (check-feature 'threads)
       (let* ((flag #f)
-	     (thread
-	      (call-with-new-thread
-	       (lambda () 
-		 (thread-yield) 
-		 (thread-yield) 
-		 (thread-yield) 
-		 (set! flag #t))
-	       true)))
-	(thread-cancel thread)
+	     (function (lambda () (thread-exit 0) (set! flag #t)))
+	     (thread (call-with-new-thread function default-error-handler)))
+	(thread-join thread)
 	(not flag)))
 
-    (pass-if "assignment after yield"
-      (let* ((flag #f))
-	(call-with-new-thread 
-	 (lambda () 
-	   (thread-yield) 
-	   (thread-yield) 
-	   (set! flag #t)) 
-	 true)
-	(not flag)))
+    ;; Check for parameter errors
 
-    (pass-if "assignment after mutual yield"
-      (let* ((flag #f))
-	(call-with-new-thread
-	 (lambda ()
-	   (thread-yield)
-	   (set! flag #t)) true)
-	(thread-yield)
-	(thread-yield)
-	(thread-yield)
-	flag))
+    )
 
-)
+  (with-test-prefix "thread-cancel"
 
-  (with-test-prefix "thread? obj"
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "thread-cancel"))
 
-    (pass-if "obj = <new thread>"
-      (let ((t (call-with-new-thread true true)))
-	(thread? t)))
+    (pass-if "thread exits appropriately"
+      (check-feature 'threads)
+      (throw 'untested)))
 
-    (pass-if "obj = <inum>"
-      (not (thread? 0)))
+  (with-test-prefix "thread-join"
 
-))
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "thread-join")))
 
+  (with-test-prefix "thread-yield"
 
-;;;
-;;; mutecis
-;;;
+    (pass-if "documented?"
+      (check-feature 'coop-threads)
+      (documented? "thread-yield"))
 
-(with-test-prefix "mutecis"
+    (pass-if "assignment after yield"
+      (check-feature 'coop-threads)
+      (let* ((flag #f)
+	     (function (lambda () (repeat 2 (thread-yield)) (set! flag #t)))
+	     (thread (call-with-new-thread function default-error-handler)))
+	(not flag)))
 
-  ;; Is documentation available?
+    (pass-if "join assignment after yield"
+      (check-feature 'coop-threads)
+      (let* ((flag #f)
+	     (function (lambda () (repeat 3 (thread-yield)) (set! flag #t)))
+	     (thread (call-with-new-thread function default-error-handler)))
+	(thread-join thread)
+	flag))
+
+    (pass-if "assignment after mutual yield"
+      (check-feature 'coop-threads)
+      (let* ((flag #f)
+	     (function (lambda () (repeat 2 (thread-yield)) (set! flag #t)))
+	     (thread (call-with-new-thread function default-error-handler)))
+	(repeat 4 (thread-yield))
+	flag))))
 
-  (pass-if-documented "make-mutex")
 
-  (pass-if-documented "mutex?")
+;;;
+;;; mutecis
+;;;
 
-  (pass-if-documented "mutex-lock")
+(with-test-prefix "mutecis"
 
-  (pass-if-documented "mutex-trylock")
+  (with-test-prefix "make-mutex"
 
-  (pass-if-documented "mutex-unlock")
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "make-mutex")))
 
-  ;; Functionality
+  (with-test-prefix "mutex?"
 
-  (with-test-prefix "mutex? obj"
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "mutex?"))
 
-    (pass-if "obj = <new mutex>"
+    (pass-if "new mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex? m)))
 
-    (pass-if "obj = <locked mutex>"
+    (pass-if "locked mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex-lock m)
 	(mutex? m)))
 
-    (pass-if "obj = <trylocked mutex>"
+    (pass-if "trylocked mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex-trylock m)
 	(mutex? m)))
 
-    (pass-if "obj = <unlocked mutex>"
+    (pass-if "unlocked mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex-lock m)
 	(mutex-unlock m)
 	(mutex? m)))
 
-    (pass-if "obj = <untrylocked mutex>"
+    (pass-if "untrylocked mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex-trylock m)
 	(mutex-unlock m)
 	(mutex? m)))
 
-    (pass-if "obj = <inum>"
+    (pass-if "inum"
+      (check-feature 'threads)
       (not (mutex? 0))))
 
+  (with-test-prefix "mutex-lock"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "mutex-lock")))
+
+  (with-test-prefix "mutex-trylock"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "mutex-trylock")))
+
+  (with-test-prefix "mutex-unlock"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "mutex-unlock")))
+
   (with-test-prefix "mutex-trylock"
 
-    (pass-if "obj = <new mutex>"
+    (pass-if "new mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex-trylock m)))
 
-    (pass-if "obj = <locked mutex>"
+    (pass-if "locked mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex-lock m)
 	(not (mutex-trylock m))))
 
-    (pass-if "obj = <trylocked mutex>"
+    (pass-if "trylocked mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex-trylock m)
 	(not (mutex-trylock m))))
 
-    (pass-if "obj = <unlocked mutex>"
+    (pass-if "unlocked mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex-lock m)
 	(mutex-unlock m)
 	(mutex-trylock m)))
 
-    (pass-if "obj = <untrylocked mutex>"
+    (pass-if "untrylocked mutex"
+      (check-feature 'threads)
       (let ((m (make-mutex)))
 	(mutex-trylock m)
 	(mutex-unlock m)