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 f660c2fe5cd7a41024b247dea12370e32fb1a2f5..d598b8479ec492239a15155ce436279d23f17d12 100644 (file)
--- 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 6fe13971bf54526e30a20b6e8cc2101a8e69c3de..1a497594bc7294a776cd090e965491c1da4e6eff 100644 (file)
--- 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 1cebe9f8c9b940038b86b3eff5cecb90a14a7110..00fab67a78281399331401864f20d81757f45449 100644 (file)
--- 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 a2b2288574c00d19330462cadbb8e9208f1e5dd8..aef42c1191329ac3e6c7f28ff2527d624b1bb1ef 100644 (file)
--- 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))