From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 11 Jan 2017 05:29:25 +0000 (-0800)
Subject: Trim type checks from operations that are dispatched.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~161
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7507d952f1c587fc482c872df0740630372b4405;p=mit-scheme.git

Trim type checks from operations that are dispatched.

Also implement channel accessors.
---

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index d6f5bf621..d7d619ce9 100644
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -186,9 +186,6 @@ USA.
 
 (define (close-binary-input-port port)
   (let ((ib (port-input-buffer port)))
-    (if (not ib)
-	(error:not-a binary-input-port? port 'close-input-port))
-    (close-input-buffer ib)
     (let ((ic (buffer-channel ib)))
       (if (and ic
 	       (let ((ob (port-output-buffer port)))
@@ -199,8 +196,6 @@ USA.
 
 (define (close-binary-output-port port)
   (let ((ob (port-output-buffer port)))
-    (if (not ob)
-	(error:not-a binary-output-port? port 'close-output-port))
     (close-output-buffer ob)
     (let ((oc (buffer-channel ob)))
       (if (and oc
@@ -213,10 +208,10 @@ USA.
 ;;;; Input operations
 
 (define (binary-input-port-open? port)
-  (let ((ib (port-input-buffer port)))
-    (if (not ib)
-	(error:not-a binary-input-port? port 'input-port-open?))
-    (buffer-open? ib)))
+  (buffer-open? (port-input-buffer port)))
+
+(define (binary-input-port-channel port)
+  (buffer-channel (port-input-buffer port)))
 
 (define (check-input-port port caller)
   (let* ((port (if (default-object? port) (current-input-port) port))
@@ -393,10 +388,16 @@ USA.
 ;;;; Output operations
 
 (define (binary-output-port-open? port)
+  (buffer-open? (port-output-buffer port)))
+
+(define (binary-output-port-channel port)
+  (buffer-channel (port-output-buffer port)))
+
+(define (flush-binary-output-port port)
   (let ((ob (port-output-buffer port)))
-    (if (not ob)
-	(error:not-a binary-output-port? port 'output-port-open?))
-    (buffer-open? ob)))
+    (if (not (buffer-open? ob))
+	(error:bad-range-argument port 'flush-output-port))
+    (flush-output-buffer ob)))
 
 (define (check-output-port port caller)
   (let* ((port (if (default-object? port) (current-output-port) port))
@@ -407,9 +408,6 @@ USA.
 	(error:bad-range-argument port caller))
     ob))
 
-(define (flush-binary-output-port #!optional port)
-  (flush-output-buffer (check-output-port port 'flush-output-port)))
-
 (define (write-u8 byte #!optional port)
   (guarantee byte? byte 'write-u8)
   (let ((ob (check-output-port port 'write-u8)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 83ee3fc74..57b1f6f08 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2453,10 +2453,12 @@ USA.
 	  output-sink?)
   (export (runtime port)
 	  binary-i/o-port?
+	  binary-input-port-channel
 	  binary-input-port-open?
 	  binary-input-port:buffer-contents
 	  binary-input-port:set-buffer-contents!
 	  binary-input-port?
+	  binary-output-port-channel
 	  binary-output-port-open?
 	  binary-output-port?
 	  close-binary-input-port