From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sun, 7 Aug 2016 18:09:45 +0000 (-0700)
Subject: x11-screen: Backport fixes to edwin/xterm.scm.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~5
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=80ba689a060bae55438424365b827b1f40a4c7f8;p=mit-scheme.git

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 506bc1511..17be1a0d1 100644
--- 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.
 
 (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))))