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 6fed24a61a8c27f64136e5050ceb492c0aa6b188..10b655c251c94534f67c36edf864922d2ec925e9 100644 (file)
--- 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))))))
 \f
 (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 a208a1d1725350fc4992eee45082112deb29aca9..5cdb7a737e224ef60164597086a2835ab2c86a4f 100644 (file)
--- 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)