From 7382587ea31b0543aca50f85e26e114936866a29 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 7 Jan 2007 09:11:23 +0000
Subject: [PATCH] Implement PORT/OPEN?, PORT/INPUT-OPEN?, and
PORT/OUTPUT-OPEN?.
---
v7/src/runtime/genio.scm | 15 +++++++++++----
v7/src/runtime/port.scm | 29 ++++++++++++++++++++++++++++-
v7/src/runtime/runtime.pkg | 6 ++++--
v7/src/runtime/socket.scm | 6 +++---
4 files changed, 46 insertions(+), 10 deletions(-)
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))
--
2.25.1