[PATCH] Thread Plug-in Support #7

[NIIBE Yutaka]

NIIBE Yutaka writes:
 > Patch piece #6.  This patch requires #2 and #3.

Correction.  #6 requires $1 and #3.

And here's another patch (still, not for method table and plug-in).

This patch require #1, #3, and #6.

This patch adds new scheme interface , scm_mutex_trylock("mutex-trylock"), 
and add testcase.  Testcase iw written by Dirk last year, I've change
the module name loaded (doc --> documentation), and change the procedure
documented? and default-error-handler to apply current code base.

libguile/ChangeLog

        * coop-threads.c (scm_mutex_trylock): New function.
        libguile/threads.h (scm_mutex_trylock): New function.

diff -ruNp ../guile-core.w/libguile/coop-threads.c ./libguile/coop-threads.c
--- ../guile-core.w/libguile/coop-threads.c     Fri Apr 13 10:51:03 2001
+++ ./libguile/coop-threads.c   Fri Apr 13 10:50:05 2001
@@ -452,6 +452,20 @@ SCM_DEFINE(scm_mutex_lock, "mutex-lock",
 }
 #undef FUNC_NAME
 
+SCM_DEFINE(scm_mutex_trylock, "mutex-trylock", 1, 0, 0, 
+          (SCM m),
+          "Try the lock of @var{mutex}. If the mutex is already locked, 
return#f\n"
+          "or else get lock and return #t.")
+#define FUNC_NAME s_scm_mutex_lock
+{
+  SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
+  if (coop_mutex_trylock (SCM_MUTEX_DATA (m)) ==0)
+    return SCM_BOOL_T;
+  else
+    return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE(scm_mutex_unlock, "mutex-unlock", 1, 0, 0, 
           (SCM m),
           "Unlocks @var{mutex} if the calling thread owns the lock on\n"
diff -ruNp ../guile-core.w/libguile/threads.h ./libguile/threads.h
--- ../guile-core.w/libguile/threads.h  Fri Apr 13 10:51:03 2001
+++ ./libguile/threads.h        Fri Apr 13 10:50:05 2001
@@ -101,6 +101,7 @@ extern SCM scm_call_with_new_thread (SCM
 extern SCM scm_thread_join (SCM t);
 extern SCM scm_make_mutex (void);
 extern SCM scm_mutex_lock (SCM m);
+extern SCM scm_mutex_trylock (SCM m);
 extern SCM scm_mutex_unlock (SCM m);
 extern SCM scm_make_cond (void);
 extern SCM scm_cond_wait (SCM cond, SCM mutex);

test-suite/ChangeLog

        * tests/threads.test: New test.

diff -ruNp ../guile-core.w/test-suite/tests/threads.test 
./test-suite/tests/threads.test
--- ../guile-core.w/test-suite/tests/threads.test       Thu Jan  1 09:00:00 1970
+++ ./test-suite/tests/threads.test     Fri Apr 13 10:50:05 2001
@@ -0,0 +1,288 @@
+;;;; threads.test --- tests guile's threads     -*- scheme -*-
+;;;; Copyright (C) 2000 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., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+;;;; As a special exception, the Free Software Foundation gives permission
+;;;; for additional uses of the text contained in its release of GUILE.
+;;;;
+;;;; The exception is that, if you link the GUILE library with other files
+;;;; to produce an executable, this does not by itself cause the
+;;;; resulting executable to be covered by the GNU General Public License.
+;;;; Your use of that executable is in no way restricted on account of
+;;;; linking the GUILE library code into it.
+;;;;
+;;;; This exception does not however invalidate any other reasons why
+;;;; the executable file might be covered by the GNU General Public License.
+;;;;
+;;;; This exception applies only to the code released by the
+;;;; Free Software Foundation under the name GUILE.  If you copy
+;;;; code from other Free Software Foundation releases into a copy of
+;;;; GUILE, as the General Public License permits, the exception does
+;;;; not apply to the code that you add in this way.  To avoid misleading
+;;;; anyone as to the status of such modified files, you must delete
+;;;; this exception notice from them.
+;;;;
+;;;; If you write modifications of your own for GUILE, it is your choice
+;;;; whether to permit this exception to apply to your modifications.
+;;;; If you do not wish that, delete this exception notice.  
+
+(use-modules (ice-9 documentation))
+
+;;;
+;;; miscellaneous
+;;;
+
+
+(define (check-feature feature)
+  (if (not (provided? feature))
+      (throw 'unsupported)))
+
+
+(define (documented? object)
+  (not (not (object-documentation object))))
+
+(define (default-error-handler . err)
+  #t)
+
+
+(defmacro repeat (count body . rest)
+  `(let ((c ,count))
+     (do ((i 0 (+ i 1)))
+        ((= i ,count))
+       ,body
+       ,@rest)))
+
+
+;;;
+;;; threads
+;;;
+
+(with-test-prefix "threads"
+
+  (with-test-prefix "call-with-new-thread"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "call-with-new-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))
+
+    ;; Check for threads spawning other threads
+
+    ;; Check for correct application of the error handler
+
+    ;; 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
+
+    )
+
+  (with-test-prefix "thread?"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "thread?"))
+
+    (pass-if "new thread"
+      (check-feature 'threads)
+      (let* ((function (lambda () #t))
+            (t (call-with-new-thread function default-error-handler)))
+       (thread? t)))
+
+    (pass-if "non-thread"
+      (check-feature 'threads)
+      (not (thread? 0))))
+
+  (with-test-prefix "thread-exit"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "thread-exit"))
+
+    (pass-if "thread exits appropriately"
+      (check-feature 'threads)
+      (let* ((flag #f)
+            (function (lambda () (thread-exit 0) (set! flag #t)))
+            (thread (call-with-new-thread function default-error-handler)))
+       (thread-join thread)
+       (not flag)))
+
+    ;; Check for parameter errors
+
+    )
+
+  (with-test-prefix "thread-cancel"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "thread-cancel"))
+
+    (pass-if "thread exits appropriately"
+      (check-feature 'threads)
+      (throw 'untested)))
+
+  (with-test-prefix "thread-join"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "thread-join")))
+
+  (with-test-prefix "thread-yield"
+
+    (pass-if "documented?"
+      (check-feature 'coop-threads)
+      (documented? "thread-yield"))
+
+    (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)))
+
+    (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))))
+
+
+;;;
+;;; mutecis
+;;;
+
+(with-test-prefix "mutecis"
+
+  (with-test-prefix "make-mutex"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "make-mutex")))
+
+  (with-test-prefix "mutex?"
+
+    (pass-if "documented?"
+      (check-feature 'threads)
+      (documented? "mutex?"))
+
+    (pass-if "new mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex? m)))
+
+    (pass-if "locked mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex-lock m)
+       (mutex? m)))
+
+    (pass-if "trylocked mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex-trylock m)
+       (mutex? m)))
+
+    (pass-if "unlocked mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex-lock m)
+       (mutex-unlock m)
+       (mutex? m)))
+
+    (pass-if "untrylocked mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex-trylock m)
+       (mutex-unlock m)
+       (mutex? m)))
+
+    (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 "new mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex-trylock m)))
+
+    (pass-if "locked mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex-lock m)
+       (not (mutex-trylock m))))
+
+    (pass-if "trylocked mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex-trylock m)
+       (not (mutex-trylock m))))
+
+    (pass-if "unlocked mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex-lock m)
+       (mutex-unlock m)
+       (mutex-trylock m)))
+
+    (pass-if "untrylocked mutex"
+      (check-feature 'threads)
+      (let ((m (make-mutex)))
+       (mutex-trylock m)
+       (mutex-unlock m)
+       (mutex-trylock m)))))
+
+;;;
+;;; condition variables
+;;;
--