From fb5b85e4e65860924b6540dfa49f97a2c0b846e1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 1 Nov 2006 05:09:42 +0000
Subject: [PATCH] When an I/O port shares the same channel for input and
 output, don't close the channel unless both the input and output sides of the
 port are closed.

---
 v7/src/runtime/genio.scm | 65 +++++++++++++++++++++++++++++-----------
 1 file changed, 47 insertions(+), 18 deletions(-)

diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm
index 9eb077587..3fd0afbbf 100644
--- a/v7/src/runtime/genio.scm
+++ b/v7/src/runtime/genio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: genio.scm,v 1.45 2006/10/25 03:15:09 cph Exp $
+$Id: genio.scm,v 1.46 2006/11/01 05:09:42 cph Exp $
 
 Copyright 1991,1993,1995,1996,1999,2002 Massachusetts Institute of Technology
 Copyright 2003,2004,2005,2006 Massachusetts Institute of Technology
@@ -259,7 +259,6 @@ USA.
 (define (generic-io/flush-output port)
   (force-drain-output-buffer (port-output-buffer port)))
 
-
 (define (generic-io/output-column port)
   (output-buffer-column (port-output-buffer port)))
 
@@ -307,19 +306,43 @@ USA.
 ;;;; Non-specific operations
 
 (define (generic-io/close port)
-  (generic-io/close-input port)
-  (generic-io/close-output port))
+  (maybe-close-input port)
+  (maybe-close-output port)
+  (maybe-close-channels port))
 
 (define (generic-io/close-output port)
-  (let ((ob (port-output-buffer port)))
-    (if ob
-	(close-output-buffer ob))))
+  (maybe-close-output port)
+  (maybe-close-channels port))
 
 (define (generic-io/close-input port)
+  (maybe-close-input port)
+  (maybe-close-channels port))
+
+(define (maybe-close-input port)
   (let ((ib (port-input-buffer port)))
     (if ib
 	(close-input-buffer ib))))
 
+(define (maybe-close-output port)
+  (let ((ob (port-output-buffer port)))
+    (if ob
+	(close-output-buffer ob))))
+
+(define (maybe-close-channels port)
+  (let ((ib (port-input-buffer port))
+	(ob (port-output-buffer port)))
+    (let ((ic (and ib (input-buffer-channel ib)))
+	  (oc (and ob (output-buffer-channel ob))))
+      (if (and ic (eq? ic oc))
+	  (if (and (not (%input-buffer-open? ib))
+		   (not (%output-buffer-open? ob)))
+	      (channel-close ic))
+	  (begin
+	    (if (and ic (not (%input-buffer-open? ib)))
+		(channel-close ic))
+	    (if (and oc (not (%output-buffer-open? ob)))
+		(channel-close oc)))))))
+
 (define (generic-io/output-open? port)
   (let ((ob (port-output-buffer port)))
     (and ob
@@ -654,16 +677,19 @@ USA.
 		      (name->sizer coder-name)))
 
 (define (input-buffer-open? ib)
-  ((source/open? (input-buffer-source ib))))
+  (and (%input-buffer-open? ib)
+       ((source/open? (input-buffer-source ib)))))
+
+(define (%input-buffer-open? ib)
+  (fix:>= (input-buffer-end ib) 0))
 
 (define (clear-input-buffer ib)
   (set-input-buffer-start! ib byte-buffer-length)
   (set-input-buffer-end! ib byte-buffer-length))
 
 (define (close-input-buffer ib)
-  (set-input-buffer-start! ib 0)
-  (set-input-buffer-end! ib 0)
-  ((source/close (input-buffer-source ib))))
+  (set-input-buffer-start! ib -1)
+  (set-input-buffer-end! ib -1))
 
 (define (input-buffer-channel ib)
   ((source/get-channel (input-buffer-source ib))))
@@ -672,7 +698,7 @@ USA.
   ((source/get-port (input-buffer-source ib))))
 
 (define-integrable (input-buffer-at-eof? ib)
-  (fix:= (input-buffer-end ib) 0))
+  (fix:<= (input-buffer-end ib) 0))
 
 (define-integrable (input-buffer-byte-count ib)
   (fix:- (input-buffer-end ib) (input-buffer-start ib)))
@@ -877,14 +903,17 @@ USA.
       (string-prefix-ci? "ISO-8859-" (symbol-name coder-name))))
 
 (define (output-buffer-open? ob)
-  ((sink/open? (output-buffer-sink ob))))
+  (and (%output-buffer-open? ob)
+       ((sink/open? (output-buffer-sink ob)))))
+
+(define (%output-buffer-open? ob)
+  (fix:>= (output-buffer-start ob) 0))
 
 (define (close-output-buffer ob)
-  (let ((sink (output-buffer-sink ob)))
-    (if ((sink/open? sink))
-	(begin
-	  (force-drain-output-buffer ob)
-	  ((sink/close sink))))))
+  (if (output-buffer-open? ob)
+      (begin
+	(force-drain-output-buffer ob)
+	(set-output-buffer-start! ob -1))))
 
 (define (output-buffer-channel ob)
   ((sink/get-channel (output-buffer-sink ob))))
-- 
2.25.1