Use internal-time/seconds->ticks in thread-queue/*-no-hang.

Moved test procedure to tests/runtime/test-thread-queue.scm.

diff --git a/src/runtime/thread-queue.scm b/src/runtime/thread-queue.scm
index c575bbe85d391d635b320bb4ceb3bdc344636597..fcbae0b3a75ceb42c859e89f65e71d2de13a503b 100644 (file)
--- a/src/runtime/thread-queue.scm
+++ b/src/runtime/thread-queue.scm
@@ -117,10 +117,11 @@ USA.
            #f)
        (%queue! queue item))))
 
-(define (thread-queue/dequeue-no-hang queue timeout)
+(define (thread-queue/dequeue-no-hang queue msec)
   (guarantee-thread-queue queue 'thread-queue/dequeue-no-hang)
-  (guarantee-non-negative-fixnum timeout 'thread-queue/dequeue-no-hang)
-  (thread-queue/dequeue-until queue (+ (real-time-clock) timeout)))
+  (guarantee-non-negative-fixnum msec 'thread-queue/dequeue-no-hang)
+  (thread-queue/dequeue-until
+   queue (+ (real-time-clock) (internal-time/seconds->ticks (/ msec 1000)))))
 
 (define (thread-queue/dequeue-until queue time)
   (guarantee-thread-queue queue 'thread-queue/dequeue-until)
@@ -153,10 +154,11 @@ USA.
                       (list (current-thread))))
        (suspend-current-thread)))))
 
-(define (thread-queue/peek-no-hang queue timeout)
+(define (thread-queue/peek-no-hang queue msec)
   (guarantee-thread-queue queue 'thread-queue/peek-no-hang)
-  (guarantee-non-negative-fixnum timeout 'thread-queue/peek-no-hang)
-  (thread-queue/peek-until queue (+ (real-time-clock) timeout)))
+  (guarantee-non-negative-fixnum msec 'thread-queue/peek-no-hang)
+  (thread-queue/peek-until
+   queue (+ (real-time-clock) (internal-time/seconds->ticks (/ msec 1000)))))
 
 (define (thread-queue/peek-until queue time)
   (guarantee-thread-queue queue 'thread-queue/peek-until)
@@ -253,32 +255,4 @@ USA.
     (set-%thread-queue/element-count! queue
                                      (1+ (%thread-queue/element-count queue)))
     (%resume-dequeuers queue)
-    item))
-
-(define (test)
-  ;; Sets up a "producer" thread that puts the letters of the alphabet
-  ;; into a thread-queue, one each 2-3 seconds.  A "consumer" thread
-  ;; waits on the queue, printing what it reads.
-  (outf-error ";Thread Queue Test\n")
-  (let ((queue (make-thread-queue)))
-    (create-thread
-     #f
-     (lambda ()
-       (outf-error ";    Consumer: "(current-thread)"\n")
-       (let loop ()
-        (outf-error ";    Consumer reads.\n")
-        (let ((item (thread-queue/dequeue! queue)))
-          (outf-error ";    Consumer read "item"\n")
-          (loop)))))
-    (create-thread
-     #f
-     (lambda ()
-       (outf-error ";    Producer: "(current-thread)"\n")
-       (for-each (lambda (item)
-                  (outf-error ";    Producer: sleeping...\n")
-                  (sleep-current-thread 2000)
-                  (outf-error ";    Producer: queuing "item"...\n")
-                  (thread-queue/queue! queue item)
-                  (outf-error ";    Producer: queued "item"\n"))
-                '(#\a #\b #\c #\d #\e))
-       (outf-error ";    Producer done.\n")))))
\ No newline at end of file
+    item))
\ No newline at end of file

diff --git a/tests/check.scm b/tests/check.scm
index b838bbb284aea675f01a9405cc39509591a8ef6c..bc6e5d12d772c703c2ce47a233821aefefe675a5 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -47,6 +47,7 @@ USA.
     "runtime/test-floenv"
     "runtime/test-hash-table"
     "runtime/test-integer-bits"
+    "runtime/test-thread-queue"
     "runtime/test-process"
     "runtime/test-regsexp"
     ("runtime/test-wttree" (runtime wt-tree))

diff --git a/tests/runtime/test-thread-queue.scm b/tests/runtime/test-thread-queue.scm
new file mode 100644 (file)
index 0000000..44afc25
--- /dev/null
+++ b/tests/runtime/test-thread-queue.scm
@@ -0,0 +1,71 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012 Massachusetts Institute
+    of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests of thread-queue (mailbox) support
+
+(declare (usual-integrations))
+\f
+(define test-items '(#\a pause
+                    #\b #\c pause
+                    #\d #\e #\f #\g #\h #\i #\j
+                    end))
+
+(define (test)
+  ;; Sets up a "producer" thread that puts characters into a
+  ;; thread-queue, and a "consumer" thread that waits on the queue,
+  ;; collecting what it reads.
+  (let* ((queue (make-thread-queue))
+        (consumer
+         (create-thread
+          #f
+          (lambda ()
+            (sleep-current-thread 100)
+            (let loop ((items '()))
+              (let ((item (thread-queue/dequeue! queue)))
+                (if (eq? 'end item)
+                    (exit-current-thread (reverse! items))
+                    (loop (cons item items)))))))))
+    (for-each (lambda (item)
+               (if (eq? 'pause item)
+                   (sleep-current-thread 100)
+                   (thread-queue/queue! queue item)))
+             test-items)
+    (thread-join consumer)))
+
+(define (thread-join thread)
+  (let ((value))
+    (with-thread-events-blocked
+     (lambda ()
+       (join-thread thread (lambda (thread v)
+                            (declare (ignore thread))
+                            (set! value v)
+                            #f))
+       (suspend-current-thread)
+       value))))
+
+(define-test 'thread-queue
+  (lambda ()
+    (assert-equal (test) (filter char? test-items))))
\ No newline at end of file