From: Matt Birkholz Date: Thu, 6 Sep 2012 18:25:36 +0000 (-0700) Subject: Use internal-time/seconds->ticks in thread-queue/*-no-hang. X-Git-Tag: release-9.2.0~220 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=369a18ab778c469229bc4912ad3144bda88a5cbb;p=mit-scheme.git 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 c575bbe85..fcbae0b3a 100644 --- 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 b838bbb28..bc6e5d12d 100644 --- 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 index 000000000..44afc2533 --- /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)) + +(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