From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 26 Apr 2017 07:34:32 +0000 (-0700)
Subject: Implement textual->binary-port.
X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~127
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c06823d9362f6e56f6c11877546f91be00b4b83e;p=mit-scheme.git

Implement textual->binary-port.
---

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 8728dd671..10edd2410 100644
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -189,6 +189,47 @@ USA.
     (procedure port)
     (get-output-bytevector port)))
 
+;;;; Conversion from textual port
+
+(define (textual->binary-port textual-port codec-name)
+  (let ((codec (get-char-codec codec-name)))
+    (make-binary-port
+     (and (textual-input-port? textual-port)
+	  (make-non-channel-input-source
+	   (lambda ()
+	     (char-ready? textual-port))
+	   (lambda (bv bs be)
+	     (let loop ((bi bs))
+	       (if (fix:< bi be)
+		   (let ((char (peek-char textual-port)))
+		     (if (or (not char) (eof-object? char))
+			 (if (fix:> bi bs)
+			     (fix:- bi bs)
+			     char)
+			 (let ((bi* ((char-codec-encoder codec) bv bi be char)))
+			   (if bi*
+			       (loop bi*)
+			       (fix:- bi bs)))))
+		   (fix:- bi bs))))
+	   (lambda ()
+	     (close-input-port textual-port))))
+     (and (textual-output-port? textual-port)
+	  (make-non-channel-output-sink
+	   (lambda (bv bs be)
+	     (let loop ((bi bs))
+	       (if (fix:< bi be)
+		   ((char-codec-decoder codec) bv bi be
+		    (lambda (char bi*)
+		      (if char
+			  (begin
+			    (write-char char textual-port)
+			    (loop bi*))
+			  (fix:- bi bs))))
+		   (fix:- bi bs))))
+	   (lambda ()
+	     (close-output-port textual-port))))
+     'textual-port->binary)))
+
 ;;;; Closing operations
 
 (define (close-binary-port port)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d160f1dc8..ac938e528 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2502,6 +2502,7 @@ USA.
 	  read-bytevector
 	  read-bytevector!
 	  read-u8
+	  textual->binary-port
 	  u8-ready?
 	  write-bytevector
 	  write-u8)