From e08d9b229a99913e967963752da7d6bcc5c7b6bb Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Fri, 5 Apr 2013 10:03:45 -0700
Subject: [PATCH] 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.
---
 src/gtk/gtk.pkg              |  2 ++
 src/runtime/runtime.pkg      |  6 +++---
 src/runtime/thread-queue.scm | 17 ++++++++++-------
 3 files changed, 15 insertions(+), 10 deletions(-)

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index da32ea10d..402def643 100644
--- 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 78369822b..d95720a72 100644
--- 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 fcbae0b3a..d909974eb 100644
--- 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)))))))))
-- 
2.25.1