edwin: Add a timeout parameter to the peek-no-hang input operations.

Factor the busy loop out and name it keyboard-peek-busy-no-hang.  Use
it in the peek-no-hang input operations to implement the timeout.

diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg
index 811069443d04f9f8a7a64d4a9ac1da5b2012260d..9a0a5d576fa2c21f046671a30d280ed9c47b4e76 100644 (file)
--- a/src/edwin/edwin.pkg
+++ b/src/edwin/edwin.pkg
@@ -984,6 +984,8 @@ USA.
     (parent (edwin screen))
     (export (edwin)
            resize-screen)
+    (import (edwin keyboard)
+           keyboard-peek-busy-no-hang)
     (import (edwin process)
            register-process-output-events)
     (import (runtime primitive-io)
@@ -1041,6 +1043,8 @@ USA.
            screen-xterm
            xterm-screen/set-icon-name
            xterm-screen/set-name)
+    (import (edwin keyboard)
+           keyboard-peek-busy-no-hang)
     (import (edwin process)
            register-process-output-events)
     (initialization (initialize-package!)))
@@ -1178,6 +1182,8 @@ USA.
            swp_nozorder
            update-window
            ws_overlappedwindow)
+    (import (edwin keyboard)
+           keyboard-peek-busy-no-hang)
     (export (edwin win-commands)
            win32-screen/get-client-size
            win32-screen/get-position
@@ -1269,6 +1275,8 @@ USA.
            screen-char-height
            screen-pel-width
            screen-pel-height)
+    (import (edwin keyboard)
+           keyboard-peek-busy-no-hang)
     (import (runtime os2-window-primitives)
            button-event-type:down
            button-event/flags

diff --git a/src/edwin/input.scm b/src/edwin/input.scm
index 772502ad3a302c5ff5baa8f47bd1b59ca4618dcd..8b3a72efcd77c00d7df58f3aab680fc880e72a90 100644 (file)
--- a/src/edwin/input.scm
+++ b/src/edwin/input.scm
@@ -197,35 +197,69 @@ B 3BAB8C
                (apply-input-event key))
            (loop))))))
 
-(define (keyboard-peek-no-hang)
-  (handle-simple-events (editor-peek-no-hang current-editor) #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)
 
+(define (keyboard-peek-busy-no-hang peek timeout)
+  ;; This busy-loop applies the PEEK thunk repeatedly for TIMEOUT
+  ;; msec.  Old display types that only PEEK-no-hang for 0 seconds
+  ;; must use this.
+  (let* ((start (real-time-clock))
+        (end (+ start timeout)))
+    (let loop ()
+      (or (peek)
+         (let ((now (real-time-clock)))
+           (if (< now end)
+               (loop)
+               #f))))))
+
 (define (keyboard-read-1 reader discard?)
   (remap-alias-key
    (handle-simple-events
     (lambda ()
       (let ((peek-no-hang (editor-peek-no-hang current-editor)))
-       (if (not (peek-no-hang))
+       (if (not (peek-no-hang 0))
            (begin
              (if (let ((interval (ref-variable auto-save-interval))
                        (count auto-save-keystroke-count))
@@ -236,31 +270,24 @@ B 3BAB8C
                    (do-auto-save)
                    (set! auto-save-keystroke-count 0)))
              (update-screens! #f)))
-       (let ((wait
-              (lambda (timeout)
-                (let ((t (+ (real-time-clock) timeout)))
-                  (let loop ()
-                    (cond ((peek-no-hang) #f)
-                          ((>= (real-time-clock) t) #t)
-                          (else (loop))))))))
-         ;; Perform the appropriate juggling of the minibuffer message.
-         (cond ((within-typein-edit?)
-                (if message-string
-                    (begin
-                      (wait read-key-timeout/slow)
-                      (set! message-string #f)
-                      (set! message-should-be-erased? #f)
-                      (clear-current-message!))))
-               ((and (or message-should-be-erased?
-                         (and command-prompt-string
-                              (not command-prompt-displayed?)))
-                     (wait read-key-timeout/fast))
-                (set! message-string #f)
-                (set! message-should-be-erased? #f)
-                (if command-prompt-string
-                    (begin
-                      (set! command-prompt-displayed? #t)
-                      (set-current-message! command-prompt-string))
-                    (clear-current-message!)))))
+       ;; Perform the appropriate juggling of the minibuffer message.
+       (cond ((within-typein-edit?)
+              (if message-string
+                  (begin
+                    (peek-no-hang read-key-timeout/slow)
+                    (set! message-string #f)
+                    (set! message-should-be-erased? #f)
+                    (clear-current-message!))))
+             ((and (or message-should-be-erased?
+                       (and command-prompt-string
+                            (not command-prompt-displayed?)))
+                   (not (peek-no-hang read-key-timeout/fast)))
+              (set! message-string #f)
+              (set! message-should-be-erased? #f)
+              (if command-prompt-string
+                  (begin
+                    (set! command-prompt-displayed? #t)
+                    (set-current-message! command-prompt-string))
+                  (clear-current-message!))))
        (reader)))
     discard?)))
\ No newline at end of file

diff --git a/src/edwin/os2term.scm b/src/edwin/os2term.scm
index 7dacc2a51d7c45629e6ab144904fd11ea30ece38..a7854c4c52c89f0b676404016a9bd018125dacf0 100644 (file)
--- a/src/edwin/os2term.scm
+++ b/src/edwin/os2term.scm
@@ -641,9 +641,12 @@ USA.
       (setup-pending 'IN-UPDATE)
       pending)
 
-    (define (peek-no-hang)
-      (setup-pending #f)
-      pending)
+    (define (peek-no-hang timeout)
+      (keyboard-peek-busy-no-hang
+       (lambda ()
+        (setup-pending #f)
+        pending)
+       timeout))
 
     (define (peek)
       (setup-pending #t)

diff --git a/src/edwin/simple.scm b/src/edwin/simple.scm
index 4f9604a86a7cd70f8bac9d653011d56f4117d882..ff75dddba9b0d9240196ddb8b7b508d08ca40d0c 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)

diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm
index f57b3dd3bcca0dde7c7059a5d22a1bde163af055..2016888b3a25f572f890848231f11e20cfb04561 100644 (file)
--- a/src/edwin/tterm.scm
+++ b/src/edwin/tterm.scm
@@ -334,13 +334,16 @@ USA.
        (named-lambda (halt-update?)
         (or (fix:< start end)
             (read-more?)))
-       (named-lambda (peek-no-hang)
-        (let ((event (->event (match-event #f))))
-          (if (input-event? event)
-              (begin
-                (apply-input-event event)
-                #f)
-              event)))
+       (named-lambda (peek-no-hang timeout)
+        (keyboard-peek-busy-no-hang
+         (lambda ()
+           (let ((event (->event (match-event #f))))
+             (if (input-event? event)
+                 (begin
+                   (apply-input-event event)
+                   #f)
+                 event)))
+         timeout))
        (named-lambda (peek)
         (->event (match-event #t)))
        (named-lambda (read)

diff --git a/src/edwin/win32.scm b/src/edwin/win32.scm
index f25a2d58b272538a1fc0b473a4087cba06b9633c..86dea2b80bff20ae112594e04bfba2a48d8327a6 100644 (file)
--- a/src/edwin/win32.scm
+++ b/src/edwin/win32.scm
@@ -386,9 +386,12 @@ USA.
       (values (lambda ()               ;halt-update?
                (or pending-result
                    (probe 'IN-UPDATE)))
-             (lambda ()                ;peek-no-hang
-               (or pending-result
-                   (probe #f)))
+             (lambda (timeout)         ;peek-no-hang
+               (keyboard-peek-busy-no-hang
+                (lambda ()
+                  (or pending-result
+                      (probe #f)))
+                timeout))
              (lambda ()                ;peek
                (or pending-result
                    (let ((result (get-next-event #t)))

diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm
index c6454bc217c7be53335475b287a7f9de3286c4a2..490ba74366ca0308c72551bae119d1e24f271fc1 100644 (file)
--- a/src/edwin/xterm.scm
+++ b/src/edwin/xterm.scm
@@ -472,10 +472,14 @@ USA.
               (or pending-result
                   (fix:< start end)
                   (probe 'IN-UPDATE)))
-            (lambda ()                 ;peek-no-hang
-              (or pending-result
-                  (fix:< start end)
-                  (probe #f)))
+            (lambda (timeout)          ;peek-no-hang
+              (keyboard-peek-busy-no-hang
+               (lambda ()
+                 (or pending-result
+                     (and (fix:< start end)
+                          (string-ref string start))
+                     (probe #f)))
+               timeout))
             (lambda ()                 ;peek
               (or pending-result
                   (if (fix:< start end)