x11-screen: Backport fixes to edwin/xterm.scm.

In block-for-event, drain X events and subprocess output.  In preview-
event-stream, use dynamic-wind to re-register.

diff --git a/src/x11-screen/x11-screen.scm b/src/x11-screen/x11-screen.scm
index 506bc1511533c1e1b1853793a9acf7579847a392..17be1a0d1b15bf3944116f48a6e26fb081106158 100644 (file)
--- a/src/x11-screen/x11-screen.scm
+++ b/src/x11-screen/x11-screen.scm
@@ -477,36 +477,54 @@ USA.
   (let ((queue x-display-events)
        (output-available? #f)
        (registrations))
-    (dynamic-wind
-     (lambda ()
-       (set! registrations
-            (register-process-output-events
-             (current-thread)
-             (lambda (mode)
-               mode
-               (set! output-available? #t)))))
-     (lambda ()
-       (let loop ()
+    (let loop ()
+      ;; Test-select-registry does not detect input in port buffers.
+      ;; Drain them before suspending.
+      (set! output-available? (accept-process-output))
+      (dynamic-wind
+       (lambda ()
+        (set! registrations
+              (if output-available?
+                  '()
+                  (register-process-output-events
+                   (current-thread)
+                   (lambda (mode)
+                     mode
+                     (set! output-available? #t))))))
+       (lambda ()
         (with-thread-events-blocked
          (lambda ()
+
+           ;; Drain X event queue before suspending.  Wait-for-event
+           ;; and throws from the previewer (aborts) may leave events
+           ;; in buffers.
+           (let drain ()
+             (let ((event (x-display-process-events x-display-data 2)))
+               (if event
+                   (begin (if (not (eq? #t event))
+                              (preview-event event queue))
+                          (drain)))))
+
            (if (and (queue-empty? queue)
                     (not output-available?)
                     (not (process-status-changes?))
                     (not inferior-thread-changes?))
-               (suspend-current-thread))))
-        (cond ((not (queue-empty? queue))
-               (dequeue!/unsafe queue))
-              ((process-status-changes?)
-               event:process-status)
-              (output-available?
-               event:process-output)
-              (inferior-thread-changes?
-               event:inferior-thread-output)
-              (else
-               (loop)))))
-     (lambda ()
-       (for-each deregister-io-thread-event registrations)
-       (set! registrations)))))
+               (suspend-current-thread)))))
+       (lambda ()
+        (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?)
+                event:process-status)
+               (output-available?
+                event:process-output)
+               (inferior-thread-changes?
+                event:inferior-thread-output)
+               (else
+                (loop)))))))
 
 (define (preview-event-stream)
   (with-thread-events-blocked
@@ -520,14 +538,18 @@ USA.
 
      (define (preview-events mode)
        mode
-       (if previewer-registration
-          (register!))
-       (let loop ()
-        (let ((event (x-display-process-events x-display-data 2)))
-          (if event
-              (begin (if (not (eq? #t event))
-                         (preview-event event x-display-events))
-                     (loop))))))
+       (dynamic-wind
+       (lambda () unspecific)
+       (lambda ()
+         (let loop ()
+           (let ((event (x-display-process-events x-display-data 2)))
+             (if event
+                 (begin (if (not (eq? #t event))
+                            (preview-event event x-display-events))
+                        (loop))))))
+       (lambda ()
+         (if previewer-registration
+             (register!)))))
 
      (register!))))
 
@@ -605,7 +627,9 @@ USA.
 \f
 (define (process-change-event event)
   (cond ((fix:= event event:process-status) (handle-process-status-changes))
-       ((fix:= event event:process-output) (accept-process-output))
+       ((fix:= event event:process-output)
+        (accept-process-output)
+        #t)
        ((fix:= event event:inferior-thread-output) (accept-thread-output))
        (else (error "Illegal change event:" event))))