From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Mon, 17 Jan 2011 19:19:12 +0000 (-0700)
Subject: Fixed sit-for on gtk-screens using peek timeout.
X-Git-Tag: 20110609-Gtk-Screen~9
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4d7f72fa25b439765785b2cfae44698b743e353e;p=mit-scheme.git

Fixed sit-for on gtk-screens using peek timeout.

* src/edwin/input.scm (keyboard-peek-no-hang)
(handle-simple-events-until): Added optional "timeout" argument,
implemented with the new handle-simple-events-until procedure.  Pull
the simple event handling out of handle-simple-events' loop to create
simple-event-handled?, and used it to implement
handle-simple-events-until.

* src/edwin/simple.scm (sit-for): Get screens up-to-date first, even
with input pending(?).  Replaced busy loop with optional timeout
argument to keyboard-peek-no-hang.  This processes simple events,
which call update-screens! as necessary.
---

diff --git a/src/edwin/input.scm b/src/edwin/input.scm
index 6fed24a61..10b655c25 100644
--- a/src/edwin/input.scm
+++ b/src/edwin/input.scm
@@ -197,26 +197,46 @@ B 3BAB8C
 		(apply-input-event key))
 	    (loop))))))
 
-(define (keyboard-peek-no-hang)
-  (handle-simple-events (lambda () ((editor-peek-no-hang current-editor) 0))
-			#t))
+(define (keyboard-peek-no-hang #!optional timeout)
+  (let ((milliseconds (if (default-object? timeout) 0 timeout)))
+    (guarantee-fixnum milliseconds 'keyboard-peek-no-hang)
+    (handle-simple-events-until
+     (+ (real-time-clock) milliseconds)
+     (editor-peek-no-hang current-editor)
+     #t)))
 
 (define (handle-simple-events thunk discard?)
   (let loop ()
     (let ((input (thunk)))
-      (if (and (input-event? input)
-	       (let ((type (input-event/type input)))
-		 (or (eq? type 'UPDATE)
-		     (eq? type 'SET-SCREEN-SIZE)
-		     (and (eq? type 'DELETE-SCREEN)
-			  (eq? (input-event/operator input) delete-screen!)
-			  (not (selected-screen?
-				(car (input-event/operands input))))))))
-	  (begin
-	    (apply-input-event input)
-	    (if discard? ((editor-read current-editor)))
-	    (loop))
+      (if (simple-event-handled? input discard?)
+	  (loop)
 	  input))))
+
+(define (simple-event-handled? input discard?)
+  (if (and (input-event? input)
+	   (let ((type (input-event/type input)))
+	     (or (eq? type 'UPDATE)
+		 (eq? type 'SET-SCREEN-SIZE)
+		 (and (eq? type 'DELETE-SCREEN)
+		      (eq? (input-event/operator input) delete-screen!)
+		      (not (selected-screen?
+			    (car (input-event/operands input))))))))
+      (begin
+	(apply-input-event input)
+	(if discard? ((editor-read current-editor)))
+	#t)
+      #f))
+
+(define (handle-simple-events-until end-time peek-no-hang discard?)
+  (let loop ()
+    (let* ((now (real-time-clock))
+	   (timeout (- end-time now)))
+      (if (not (positive? timeout))
+	  #f
+	  (let ((input (peek-no-hang timeout)))
+	    (if (simple-event-handled? input discard?)
+		(loop)
+		input))))))
 
 (define read-key-timeout/fast 500)
 (define read-key-timeout/slow 2000)
diff --git a/src/edwin/simple.scm b/src/edwin/simple.scm
index a208a1d17..5cdb7a737 100644
--- a/src/edwin/simple.scm
+++ b/src/edwin/simple.scm
@@ -226,12 +226,9 @@ USA.
 	      (else (extract-string start end))))))))
 
 (define (sit-for interval)
-  (let ((time-limit (+ (real-time-clock) interval)))
-    (let loop ()
-      (if (and (not (keyboard-peek-no-hang))
-	       (< (real-time-clock) time-limit)
-	       (update-screens! false))
-	  (loop)))))
+  (guarantee-fixnum interval 'sit-for)
+  (update-screens! 'ignore-input)
+  (keyboard-peek-no-hang interval))
 
 (define sleep-for
   sleep-current-thread)