From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 7 Jan 2007 09:11:23 +0000 (+0000)
Subject: Implement PORT/OPEN?, PORT/INPUT-OPEN?, and PORT/OUTPUT-OPEN?.
X-Git-Tag: 20090517-FFI~813
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7382587ea31b0543aca50f85e26e114936866a29;p=mit-scheme.git

Implement PORT/OPEN?, PORT/INPUT-OPEN?, and PORT/OUTPUT-OPEN?.
---

diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm
index f660c2fe5..d598b8479 100644
--- a/v7/src/runtime/genio.scm
+++ b/v7/src/runtime/genio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: genio.scm,v 1.49 2007/01/05 21:19:28 cph Exp $
+$Id: genio.scm,v 1.50 2007/01/07 09:11:07 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -144,6 +144,7 @@ USA.
 	   (KNOWN-LINE-ENDING? ,generic-io/known-line-ending?)
 	   (KNOWN-LINE-ENDINGS ,generic-io/known-line-endings)
 	   (LINE-ENDING ,generic-io/line-ending)
+	   (OPEN? ,generic-io/open?)
 	   (SET-CODING ,generic-io/set-coding)
 	   (SET-LINE-ENDING ,generic-io/set-line-ending)
 	   (SUPPORTS-CODING? ,generic-io/supports-coding?)
@@ -356,9 +357,15 @@ USA.
     (and ib
 	 (input-buffer-open? ib))))
 
-(define (generic-io/io-open? port)
-  (and (generic-io/input-open? port)
-       (generic-io/output-open? port)))
+(define (generic-io/open? port)
+  (and (let ((ib (port-input-buffer port)))
+	 (if ib
+	     (input-buffer-open? ib)
+	     #t))
+       (let ((ob (port-output-buffer port)))
+	 (if ob
+	     (output-buffer-open? ob)
+	     #t))))
 
 (define (generic-io/write-self port output-port)
   (cond ((i/o-port? port)
diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index 6fe13971b..1a497594b 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.48 2007/01/05 21:19:28 cph Exp $
+$Id: port.scm,v 1.49 2007/01/07 09:11:11 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -627,6 +627,33 @@ USA.
     (if close-output
 	(close-output port))))
 
+(define (port/open? port)
+  (let ((open? (port/operation port 'OPEN?)))
+    (if open?
+	(open? port)
+	(and (if (input-port? port) (%input-open? port) #t)
+	     (if (output-port? port) (%output-open? port) #t)))))
+
+(define (port/input-open? port)
+  (and (input-port? port)
+       (%input-open? port)))
+
+(define (%input-open? port)
+  (let ((open? (port/operation port 'INPUT-OPEN?)))
+    (if open?
+	(open? port)
+	#t)))
+
+(define (port/output-open? port)
+  (and (output-port? port)
+       (%output-open? port)))
+
+(define (%output-open? port)
+  (let ((open? (port/operation port 'OUTPUT-OPEN?)))
+    (if open?
+	(open? port)
+	#t)))
+
 (define (port/input-channel port)
   (let ((operation (port/operation port 'INPUT-CHANNEL)))
     (and operation
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 1cebe9f8c..00fab67a7 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.608 2007/01/05 21:19:28 cph Exp $
+$Id: runtime.pkg,v 14.609 2007/01/07 09:11:18 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1744,7 +1744,6 @@ USA.
 	  generic-io/close-input
 	  generic-io/close-output
 	  generic-io/flush-output
-	  generic-io/io-open?
 	  generic-io/read-char
 	  make-generic-i/o-port)
   (export (runtime console-i/o-port)
@@ -1958,6 +1957,7 @@ USA.
 	  port/get-property
 	  port/input-blocking-mode
 	  port/input-channel
+	  port/input-open?
 	  port/input-terminal-mode
 	  port/intern-property!
 	  port/known-coding?
@@ -1965,10 +1965,12 @@ USA.
 	  port/known-line-ending?
 	  port/known-line-endings
 	  port/line-ending
+	  port/open?
 	  port/operation
 	  port/operation-names
 	  port/output-blocking-mode
 	  port/output-channel
+	  port/output-open?
 	  port/output-terminal-mode
 	  port/remove-property!
 	  port/set-coding
diff --git a/v7/src/runtime/socket.scm b/v7/src/runtime/socket.scm
index a2b228857..aef42c119 100644
--- a/v7/src/runtime/socket.scm
+++ b/v7/src/runtime/socket.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: socket.scm,v 1.31 2007/01/05 21:19:28 cph Exp $
+$Id: socket.scm,v 1.32 2007/01/07 09:11:23 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -138,14 +138,14 @@ USA.
   unspecific)
 
 (define (socket/close-input port)
-  (if (generic-io/io-open? port)
+  (if (port/open? port)
       ((ucode-primitive shutdown-socket 2)
        (channel-descriptor (port/input-channel port))
        1))
   (generic-io/close-input port))
 
 (define (socket/close-output port)
-  (if (generic-io/io-open? port)
+  (if (port/open? port)
       ((ucode-primitive shutdown-socket 2)
        (channel-descriptor (port/input-channel port))
        2))