x11-screen: Backport elimination of keyboard busy loop.

diff --git a/src/x11-screen/x11-screen.scm b/src/x11-screen/x11-screen.scm
index 17be1a0d1b15bf3944116f48a6e26fb081106158..f82160cca080812b93781dc5dabc6ce8346f12d7 100644 (file)
--- a/src/x11-screen/x11-screen.scm
+++ b/src/x11-screen/x11-screen.scm
@@ -372,49 +372,41 @@ USA.
                                 update-screens!
                                 #f))))
        (let ((get-next-event
-              (lambda (block?)
-                (let loop ()
-                  (let ((event (read-event queue display block?)))
-                    (cond ((or (not event) (input-event? event))
-                           event)
-                          ((not (vector? event))
-                           (let ((flag (process-change-event event)))
-                             (if flag
-                                 (pce-event flag)
-                                 (loop))))
-                          (else
-                           (or (process-event event)
-                               (loop)))))))))
+              (lambda (msec)
+                (let ((timeout (and msec (+ (real-time-clock) msec))))
+                  (let loop ()
+                    (let ((event (read-event queue display timeout)))
+                      (cond ((or (not event) (input-event? event))
+                             event)
+                            ((not (vector? event))
+                             (let ((flag (process-change-event event)))
+                               (if flag
+                                   (pce-event flag)
+                                   (loop))))
+                            (else
+                             (or (process-event event)
+                                 (loop))))))))))
          (let ((probe
-                (lambda (block?)
-                  (let ((result (get-next-event block?)))
+                (lambda (msec)
+                  (let ((result (get-next-event msec)))
                     (if result
                         (set! pending-result result))
-                    result)))
-               (guarantee-result
-                (lambda ()
-                  (or (get-next-event #t)
-                      (error "#F returned from blocking read")))))
+                    result))))
            (values
             (lambda ()                 ;halt-update?
               (or pending-result
                   (fix:< start end)
-                  (probe 'IN-UPDATE)))
-            (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))
+                  (probe 0)))
+            (lambda (msec)             ;peek-no-hang
+              (or pending-result
+                  (and (fix:< start end)
+                       (string-ref string start))
+                  (probe msec)))
             (lambda ()                 ;peek
               (or pending-result
-                  (if (fix:< start end)
-                      (string-ref string start)
-                      (let ((result (guarantee-result)))
-                        (set! pending-result result)
-                        result))))
+                  (and (fix:< start end)
+                       (string-ref string start))
+                  (probe #f)))
             (lambda ()                 ;read
               (cond (pending-result
                      => (lambda (result)
@@ -425,26 +417,22 @@ USA.
                        (set! start (fix:+ start 1))
                        char))
                     (else
-                     (guarantee-result)))))))))))
+                     (or (get-next-event #f)
+                         (error "#F returned from blocking read"))))))))))))
 \f
-(define (read-event queue display block?)
-  (let loop ()
-    (let* ((empty "empty")
-          (event* (with-thread-events-blocked
-                   (lambda ()
-                     (if (queue-empty? queue)
-                         empty
-                         (dequeue!/unsafe queue)))))
-          (event (if (eq? event* empty)
-                     (and (not (memq block? '(IN-UPDATE #f)))
-                          (block-for-event display))
-                     event*)))
-      (if (and event trace-port)
-         (write-line event trace-port))
-      (or event
-         (if (memq block? '(IN-UPDATE #f))
-             #f
-             (loop))))))
+(define (read-event queue display timeout)
+  (let* ((empty "empty")
+        (event* (with-thread-events-blocked
+                 (lambda ()
+                   (if (queue-empty? queue)
+                       empty
+                       (dequeue!/unsafe queue)))))
+        (event (if (eq? event* empty)
+                   (block-for-event display timeout)
+                   event*)))
+    (if (and event trace-port)
+       (write-line event trace-port))
+    event))
 
 (define trace-port #f)
 
@@ -472,22 +460,31 @@ USA.
                          (vector-ref event 4)
                          (vector-ref event 5))))
 
-(define (block-for-event display)
+(define (block-for-event display timeout)
   display
   (let ((queue x-display-events)
        (output-available? #f)
+       (timed-out? #f)
+       (thread (current-thread))
+       (timer)
        (registrations))
     (let loop ()
-      ;; Test-select-registry does not detect input in port buffers.
-      ;; Drain them before suspending.
+      ;; IO events are not delivered when input lingers in port buffers.
+      ;; Incrementally drain the ports before suspending.
       (set! output-available? (accept-process-output))
+
       (dynamic-wind
        (lambda ()
+        (set! timer
+              (and timeout
+                   (register-time-event timeout
+                                        (lambda ()
+                                          (set! timed-out? #t)))))
         (set! registrations
               (if output-available?
                   '()
                   (register-process-output-events
-                   (current-thread)
+                   thread
                    (lambda (mode)
                      mode
                      (set! output-available? #t))))))
@@ -507,17 +504,25 @@ USA.
 
            (if (and (queue-empty? queue)
                     (not output-available?)
+                    (not timed-out?)
                     (not (process-status-changes?))
                     (not inferior-thread-changes?))
                (suspend-current-thread)))))
        (lambda ()
-        (for-each deregister-io-thread-event registrations)
-        (set! registrations)))
+        (if (eq? (current-thread) thread)
+            (begin
+              (if timer (deregister-time-event timer))
+              (set! timer)
+              (for-each deregister-io-thread-event registrations)
+              (set! registrations)))))
+
       (or (with-thread-events-blocked
           (lambda ()
             (and (not (queue-empty? queue))
                  (dequeue!/unsafe queue))))
-         (cond ((process-status-changes?)
+         (cond (timed-out?
+                #f)
+               ((process-status-changes?)
                 event:process-status)
                (output-available?
                 event:process-output)