From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 8 Jan 1998 05:58:22 +0000 (+0000)
Subject: Fix bug in Windows 95: when a subprocess exits, close its I/O ports.
X-Git-Tag: 20090517-FFI~4902
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ae2cdf67ab0110f0573e8b34428fef0c60ec3b60;p=mit-scheme.git

Fix bug in Windows 95: when a subprocess exits, close its I/O ports.
This is necessary because our code can get into a state where it is
trying to read from a subprocess pipe and needs to be told that the
other end of the pipe was closed.  This indication is supplied by
Windows NT, but does not appear to work properly under Windows 95.
---

diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index fda662aa3..75d17d652 100644
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: io.scm,v 14.51 1997/11/01 19:12:16 cph Exp $
+$Id: io.scm,v 14.52 1998/01/08 05:58:22 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -245,20 +245,25 @@ MIT in each case. |#
   (let ((do-read
 	 (lambda ()
 	   ((ucode-primitive channel-read 4) (channel-descriptor channel)
-					     buffer start end)))
-	(do-test
-	 (lambda ()
-	   (eq? 'INPUT-AVAILABLE (test-for-input-on-channel channel)))))
-    (declare (integrate-operator do-read do-test))
+					     buffer start end))))
+    (declare (integrate-operator do-read))
     (if (and have-select? (not (channel-type=file? channel)))
 	(let ((block-events? (block-thread-events)))
 	  (let ((result
-		 (if (channel-blocking? channel)
-		     (begin
-		       (do () ((do-test)))
-		       (do-read))
-		     (and (do-test)
-			  (do-read)))))
+		 (let ((do-test
+			(lambda (k)
+			  (let ((result (test-for-input-on-channel channel)))
+			    (case result
+			      ((INPUT-AVAILABLE)
+			       (do-read))
+			      ((PROCESS-STATUS-CHANGE)
+			       (handle-subprocess-status-change)
+			       (if (channel-closed? channel) 0 (k)))
+			      (else
+			       (k)))))))
+		   (if (channel-blocking? channel)
+		       (let loop () (do-test loop))
+		       (do-test (lambda () #f))))))
 	    (if (not block-events?)
 		(unblock-thread-events))
 	    result))