gtk: Add thread-queue/dequeue-no-hang!, rm peek-until, fix -no-hang.

Fix when-non-empty-before, which did not append! to waiting-dequeuers,
and thus would only time out.

Not exporting peek-until.  Its TIME argument is... weird -- not
universal.  Swat can import it.

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index da32ea10d7d02ced4bc79be8dbf61fe329e27709..402def6438315cf2abce1239b9d031ffc81ac797 100644 (file)
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -379,6 +379,8 @@ USA.
 (define-package (gtk swat)
   (parent (gtk))
   (files "swat")
+  (import (runtime thread-queue)
+         thread-queue/peek-until)
   (import (gtk gtk-widget)
          gtk-widget-destroy-callback)
   (import (gtk fix-layout)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 78369822bd1858b09d92d0f5fe9ff3e2580160ef..d95720a72c373462162fe4f89bf334f45f2162af 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -577,9 +577,9 @@ USA.
          thread-queue/queue-no-hang!
          thread-queue/push!
          thread-queue/dequeue!
-         thread-queue/peek-no-hang
-         thread-queue/peek-until
-         thread-queue/peek))
+         thread-queue/dequeue-no-hang!
+         thread-queue/peek
+         thread-queue/peek-no-hang))
 
 (define-package (runtime simple-file-ops)
   (files "sfile")

diff --git a/src/runtime/thread-queue.scm b/src/runtime/thread-queue.scm
index fcbae0b3a75ceb42c859e89f65e71d2de13a503b..d909974eb087e5d611036c777ac208002e966fbd 100644 (file)
--- a/src/runtime/thread-queue.scm
+++ b/src/runtime/thread-queue.scm
@@ -117,15 +117,15 @@ USA.
            #f)
        (%queue! queue item))))
 
-(define (thread-queue/dequeue-no-hang queue msec)
-  (guarantee-thread-queue queue 'thread-queue/dequeue-no-hang)
-  (guarantee-non-negative-fixnum msec 'thread-queue/dequeue-no-hang)
-  (thread-queue/dequeue-until
+(define (thread-queue/dequeue-no-hang! queue msec)
+  (guarantee-thread-queue queue 'thread-queue/dequeue-no-hang!)
+  (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)
-  (guarantee-integer time 'thread-queue/dequeue-until)
+(define (thread-queue/dequeue-until! queue time)
+  (guarantee-thread-queue queue 'thread-queue/dequeue-until!)
+  (guarantee-integer time 'thread-queue/dequeue-until!)
   (when-non-empty-before time queue %dequeue!))
 
 (declare (integrate-operator when-non-empty-before))
@@ -139,6 +139,9 @@ USA.
             (if (<= time now)
                 #f
                 (begin
+                  (set-%thread-queue/waiting-dequeuers!
+                   queue (append! (%thread-queue/waiting-dequeuers queue)
+                                  (list (current-thread))))
                   (register-timer-event (- time now) (lambda () unspecific))
                   (suspend-current-thread)
                   (loop)))))))))