From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 11 Jan 2017 05:31:32 +0000 (-0800)
Subject: Implement {input,output}-port-channel.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~160
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c7c7bbd9741625b332175bf0ca60985d10cff289;p=mit-scheme.git

Implement {input,output}-port-channel.
---

diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 049df54ea..6d0939a25 100644
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -67,14 +67,14 @@ USA.
 (define-guarantee i/o-port "I/O port")
 
 (define (input-port-open? port)
-  (cond ((binary-port? port) (binary-input-port-open? port))
-	((textual-port? port) (textual-input-port-open? port))
-	(else (error:not-a port? port 'input-port-open?))))
+  (cond ((binary-input-port? port) (binary-input-port-open? port))
+	((textual-input-port? port) (textual-input-port-open? port))
+	(else (error:not-a input-port? port 'input-port-open?))))
 
 (define (output-port-open? port)
-  (cond ((binary-port? port) (binary-output-port-open? port))
-	((textual-port? port) (textual-output-port-open? port))
-	(else (error:not-a port? port 'output-port-open?))))
+  (cond ((binary-output-port? port) (binary-output-port-open? port))
+	((textual-output-port? port) (textual-output-port-open? port))
+	(else (error:not-a output-port? port 'output-port-open?))))
 
 (define (close-port port)
   (cond ((binary-port? port) (close-binary-port port))
@@ -82,14 +82,24 @@ USA.
 	(else (error:not-a port? port 'close-port))))
 
 (define (close-input-port port)
-  (cond ((binary-port? port) (close-binary-input-port port))
-	((textual-port? port) (close-textual-input-port port))
-	(else (error:not-a port? port 'close-input-port))))
+  (cond ((binary-input-port? port) (close-binary-input-port port))
+	((textual-input-port? port) (close-textual-input-port port))
+	(else (error:not-a input-port? port 'close-input-port))))
 
 (define (close-output-port port)
-  (cond ((binary-port? port) (close-binary-output-port port))
-	((textual-port? port) (close-textual-output-port port))
-	(else (error:not-a port? port 'close-output-port))))
+  (cond ((binary-output-port? port) (close-binary-output-port port))
+	((textual-output-port? port) (close-textual-output-port port))
+	(else (error:not-a output-port? port 'close-output-port))))
+
+(define (input-port-channel port)
+  (cond ((binary-input-port? port) (binary-input-port-channel port))
+	((textual-input-port? port) (textual-input-port-channel port))
+	(else (error:not-a input-port? port 'input-port-channel))))
+
+(define (output-port-channel port)
+  (cond ((binary-output-port? port) (binary-output-port-channel port))
+	((textual-output-port? port) (textual-output-port-channel port))
+	(else (error:not-a output-port? port 'output-port-channel))))
 
 ;;;; Port type
 
@@ -557,33 +567,25 @@ USA.
 		 (textual-output-port-open? port)
 		 #t)))))
 
-(define (port/input-open? port)
-  (and (textual-input-port? port)
-       (textual-input-port-open? port)))
-
 (define (textual-input-port-open? port)
   (let ((open? (port/operation port 'INPUT-OPEN?)))
     (if open?
 	(open? port)
 	#t)))
 
-(define (port/output-open? port)
-  (and (textual-output-port? port)
-       (textual-output-port-open? port)))
-
 (define (textual-output-port-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)))
+(define (textual-port-input-channel port)
+  (let ((operation (port/operation port 'input-port-channel)))
     (and operation
 	 (operation port))))
 
-(define (port/output-channel port)
-  (let ((operation (port/operation port 'OUTPUT-CHANNEL)))
+(define (textual-port-output-channel port)
+  (let ((operation (port/operation port 'output-port-channel)))
     (and operation
 	 (operation port))))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 57b1f6f08..c06e68b6c 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2471,12 +2471,14 @@ USA.
   (files "port")
   (parent (runtime))
   (export ()
-	  (port/input-open? input-port-open?)
-	  (port/output-open? output-port-open?)
+	  ;; BEGIN legacy bindings
+	  (port/input-channel input-port-channel)
+	  (port/output-channel output-port-channel)
 	  (port/state textual-port-state)
 	  (port/thread-mutex textual-port-thread-mutex)
 	  (port/type textual-port-type)
 	  (set-port/state! set-textual-port-state!)
+	  ;; END legacy bindings
 	  close-input-port
 	  close-output-port
 	  close-port
@@ -2487,10 +2489,12 @@ USA.
 	  guarantee-output-port
 	  guarantee-port
 	  i/o-port?
+	  input-port-channel
 	  input-port-open?
 	  input-port?
 	  interaction-i/o-port
 	  notification-output-port
+	  output-port-channel
 	  output-port-open?
 	  output-port?
 	  port-position