Implement textual->binary-port.

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 8728dd6712c657d8d9d72d9acbffa0e05f7dd7fa..10edd2410f88e6dbf4e8caa3f253022918ce27e0 100644 (file)
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -189,6 +189,47 @@ USA.
     (procedure port)
     (get-output-bytevector port)))
 \f
+;;;; 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)))
+\f
 ;;;; Closing operations
 
 (define (close-binary-port port)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d160f1dc835e18d003d947c2ef493ffbcb223ca4..ac938e528a03cd514adc629609e144707dd14d08 100644 (file)
--- 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)