Implement binary->textual-port.

Also change make-generic-i/o-port to take a binary port as argument.

diff --git a/src/runtime/fileio.scm b/src/runtime/fileio.scm
index 2c31a81458c464dfa4693d01ea6e4091ab752280..d453b4ac706786b277a3241b304d28b504f90ec3 100644 (file)
--- a/src/runtime/fileio.scm
+++ b/src/runtime/fileio.scm
@@ -115,18 +115,16 @@ USA.
 
 (define (%make-textual-file-port input-channel output-channel pathname caller)
   (let ((port
-        (make-generic-i/o-port
-           (and input-channel
-                (make-channel-input-source input-channel))
-           (and output-channel
-                (make-channel-output-sink output-channel))
-           caller
-           (cond ((not input-channel) output-file-type)
-                 ((not output-channel) input-file-type)
-                 (else i/o-file-type)))))
-    ;; If both channels are set they are the same.
-    (cond (input-channel (set-channel-port! input-channel port))
-         (output-channel (set-channel-port! output-channel port)))
+        (make-generic-i/o-port (make-binary-port
+                                (and input-channel
+                                     (make-channel-input-source input-channel))
+                                (and output-channel
+                                     (make-channel-output-sink output-channel))
+                                caller)
+                               (cond ((not input-channel) output-file-type)
+                                     ((not output-channel) input-file-type)
+                                     (else i/o-file-type))
+                               caller)))
     (set-port-pathname! port pathname)
     port))
 \f

diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm
index c7199f54a278cb46222505aa968854d219ec3e35..7a0310887e3c57f943d1af50942e5ca53cfb2dd7 100644 (file)
--- a/src/runtime/genio.scm
+++ b/src/runtime/genio.scm
@@ -29,15 +29,14 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (make-generic-i/o-port source sink caller #!optional type . extra-state)
-  (if (not (or source sink))
-      (error "Missing arguments."))
+(define (make-generic-i/o-port binary-port #!optional type caller . extra-state)
   (let ((port
         (make-textual-port (if (default-object? type)
-                               (generic-i/o-port-type (source-type source)
-                                                      (sink-type sink))
+                               (generic-i/o-port-type
+                                (source-type (binary-port-source binary-port))
+                                (sink-type (binary-port-sink binary-port)))
                                type)
-                           (apply make-gstate source sink 'TEXT 'TEXT caller
+                           (apply make-gstate binary-port 'text 'text caller
                                   extra-state)
                            caller)))
     (let ((ib (port-input-buffer port)))
@@ -48,32 +47,35 @@ USA.
          (set-output-buffer-port! ob port)))
     port))
 
+(define (binary->textual-port binary-port)
+  (make-generic-i/o-port binary-port))
+
 (define (source-type source)
   (cond ((not source) #f)
-       ((input-source-channel source) 'CHANNEL)
+       ((input-source-channel source) 'channel)
        (else #t)))
 
 (define (sink-type sink)
   (cond ((not sink) #f)
-       ((output-sink-channel sink) 'CHANNEL)
+       ((output-sink-channel sink) 'channel)
        (else #t)))
 
 (define (generic-i/o-port-type source sink)
   (case source
-    ((#F)
+    ((#f)
      (case sink
-       ((#F) generic-type00)
-       ((CHANNEL) generic-type02)
+       ((#f) generic-type00)
+       ((channel) generic-type02)
        (else generic-type01)))
-    ((CHANNEL)
+    ((channel)
      (case sink
-       ((#F) generic-type20)
-       ((CHANNEL) generic-type22)
+       ((#f) generic-type20)
+       ((channel) generic-type22)
        (else generic-type21)))
     (else
      (case sink
-       ((#F) generic-type10)
-       ((CHANNEL) generic-type12)
+       ((#f) generic-type10)
+       ((channel) generic-type12)
        (else generic-type11)))))
 
 (define (generic-i/o-port->binary-port port)
@@ -87,21 +89,20 @@ USA.
 (define (output-port->binary-port port)
   (output-buffer-binary-port (port-output-buffer port)))
 \f
-(define (make-gstate source sink coder-name normalizer-name caller . extra)
-  (let ((binary-port (make-binary-port source sink caller)))
-    (%make-gstate (and source
-                      (make-input-buffer binary-port
-                                         coder-name
-                                         normalizer-name
-                                         caller))
-                 (and sink
-                      (make-output-buffer binary-port
-                                          coder-name
-                                          normalizer-name
-                                          caller))
-                 coder-name
-                 normalizer-name
-                 (list->vector extra))))
+(define (make-gstate binary-port coder-name normalizer-name caller . extra)
+  (%make-gstate (and (binary-input-port? binary-port)
+                    (make-input-buffer binary-port
+                                       coder-name
+                                       normalizer-name
+                                       caller))
+               (and (binary-output-port? binary-port)
+                    (make-output-buffer binary-port
+                                        coder-name
+                                        normalizer-name
+                                        caller))
+               coder-name
+               normalizer-name
+               (list->vector extra)))
 
 (define-record-type <gstate>
     (%make-gstate input-buffer output-buffer coder-name normalizer-name extra)
@@ -142,43 +143,43 @@ USA.
 (add-boot-init!
  (lambda ()
    (let ((ops:in1
-         `((CHAR-READY? ,generic-io/char-ready?)
-           (CLOSE-INPUT ,generic-io/close-input)
-           (EOF? ,generic-io/eof?)
-           (INPUT-LINE ,generic-io/input-line)
-           (INPUT-OPEN? ,generic-io/input-open?)
-           (PEEK-CHAR ,generic-io/peek-char)
-           (READ-CHAR ,generic-io/read-char)
-           (READ-SUBSTRING ,generic-io/read-substring)
-           (UNREAD-CHAR ,generic-io/unread-char)))
+         `((char-ready? ,generic-io/char-ready?)
+           (close-input ,generic-io/close-input)
+           (eof? ,generic-io/eof?)
+           (input-line ,generic-io/input-line)
+           (input-open? ,generic-io/input-open?)
+           (peek-char ,generic-io/peek-char)
+           (read-char ,generic-io/read-char)
+           (read-substring ,generic-io/read-substring)
+           (unread-char ,generic-io/unread-char)))
         (ops:in2
-         `((INPUT-CHANNEL ,generic-io/input-channel)))
+         `((input-channel ,generic-io/input-channel)))
         (ops:out1
-         `((BUFFERED-OUTPUT-BYTES ,generic-io/buffered-output-bytes)
-           (BYTES-WRITTEN ,generic-io/bytes-written)
-           (CLOSE-OUTPUT ,generic-io/close-output)
-           (FLUSH-OUTPUT ,generic-io/flush-output)
-           (OUTPUT-COLUMN ,generic-io/output-column)
-           (OUTPUT-OPEN? ,generic-io/output-open?)
-           (WRITE-CHAR ,generic-io/write-char)
-           (WRITE-SUBSTRING ,generic-io/write-substring)))
+         `((buffered-output-bytes ,generic-io/buffered-output-bytes)
+           (bytes-written ,generic-io/bytes-written)
+           (close-output ,generic-io/close-output)
+           (flush-output ,generic-io/flush-output)
+           (output-column ,generic-io/output-column)
+           (output-open? ,generic-io/output-open?)
+           (write-char ,generic-io/write-char)
+           (write-substring ,generic-io/write-substring)))
         (ops:out2
-         `((OUTPUT-CHANNEL ,generic-io/output-channel)
-           (SYNCHRONIZE-OUTPUT ,generic-io/synchronize-output)))
+         `((output-channel ,generic-io/output-channel)
+           (synchronize-output ,generic-io/synchronize-output)))
         (other-operations
-         `((CHAR-SET ,generic-io/char-set)
-           (CLOSE ,generic-io/close)
-           (CODING ,generic-io/coding)
-           (KNOWN-CODING? ,generic-io/known-coding?)
-           (KNOWN-CODINGS ,generic-io/known-codings)
-           (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?)
-           (WRITE-SELF ,generic-io/write-self))))
+         `((char-set ,generic-io/char-set)
+           (close ,generic-io/close)
+           (coding ,generic-io/coding)
+           (known-coding? ,generic-io/known-coding?)
+           (known-codings ,generic-io/known-codings)
+           (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?)
+           (write-self ,generic-io/write-self))))
      (let ((make-type
            (lambda ops
              (make-textual-port-type (append (apply append ops)

diff --git a/src/runtime/process.scm b/src/runtime/process.scm
index 62b7d6b9066c2017e24cd00d308db3bb8f93e18f..d5a36ff6ef63e3d8364624fa82bcc7e3770efc55 100644 (file)
--- a/src/runtime/process.scm
+++ b/src/runtime/process.scm
@@ -101,10 +101,13 @@ USA.
                      (output-channel (subprocess-output-channel process)))
                  (and (or input-channel output-channel)
                       (make-generic-i/o-port
-                       (and input-channel
-                            (make-channel-input-source input-channel))
-                       (and output-channel
-                            (make-channel-output-sink output-channel))
+                       (make-binary-port
+                        (and input-channel
+                             (make-channel-input-source input-channel))
+                        (and output-channel
+                             (make-channel-output-sink output-channel))
+                        caller)
+                       (default-object)
                        caller)))))
           (set-subprocess-%i/o-port! process port)
           port)))))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8d37bbcecf6c0b38b77e134f67f4027967a25ee2..9e3ec659f355e02d94aee8d7a72fcd8d64049ba2 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2255,6 +2255,7 @@ USA.
   (files "genio")
   (parent (runtime))
   (export ()
+         binary->textual-port
          char-set:iso-8859-1
          char-set:iso-8859-10
          char-set:iso-8859-11

diff --git a/src/runtime/socket.scm b/src/runtime/socket.scm
index a7b4472979d01517e9ee8a5cd3206ca2a2c4479c..f47fb561f2ea1787e600f811f61561c88e2c3889 100644 (file)
--- a/src/runtime/socket.scm
+++ b/src/runtime/socket.scm
@@ -151,10 +151,11 @@ USA.
           ((ucode-primitive new-open-unix-stream-socket 2) filename p)))))))
 
 (define (make-socket-port channel caller)
-  (make-generic-i/o-port (make-channel-input-source channel)
-                        (make-channel-output-sink channel)
-                        caller
-                        socket-port-type))
+  (make-generic-i/o-port (make-binary-port (make-channel-input-source channel)
+                                          (make-channel-output-sink channel)
+                                          caller)
+                        socket-port-type
+                        caller))
 
 (define socket-port-type)
 (define (initialize-package!)

diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm
index ea30480fd8bb7a0c008d78f2dfcee40404353215..34d637aea8522ccf02e1ca507c572f768ef947bf 100644 (file)
--- a/src/runtime/stringio.scm
+++ b/src/runtime/stringio.scm
@@ -122,10 +122,13 @@ USA.
   (let* ((end (fix:end-index end (string-length octets) 'open-input-octets))
         (start (fix:start-index start end 'open-input-octets))
         (port
-         (make-generic-i/o-port (make-octets-source octets start end)
-                                #f
-                                'open-input-octets
-                                octets-input-type)))
+         (make-generic-i/o-port (make-binary-port (make-octets-source octets
+                                                                      start
+                                                                      end)
+                                                  #f
+                                                  'open-input-octets)
+                                octets-input-type
+                                'open-input-octets)))
     (port/set-coding port 'binary)
     (port/set-line-ending port 'binary)
     port))
@@ -265,10 +268,11 @@ USA.
 (define (open-output-octets)
   (let ((port
         (let ((os (make-ostate (string-builder) #f)))
-          (make-generic-i/o-port #f
-                                 (make-byte-sink os)
-                                 'open-output-octets
+          (make-generic-i/o-port (make-binary-port #f
+                                                   (make-byte-sink os)
+                                                   'open-output-octets)
                                  octets-output-type
+                                 'open-output-octets
                                  os))))
     (port/set-line-ending port 'newline)
     port))

diff --git a/src/runtime/ttyio.scm b/src/runtime/ttyio.scm
index 81812ef21ce578decdbd35596e154c35547a1ef8..effd7c3069bc697d74916b2f895af272702d78cc 100644 (file)
--- a/src/runtime/ttyio.scm
+++ b/src/runtime/ttyio.scm
@@ -79,8 +79,8 @@ USA.
     (set-channel-port! output-channel the-console-port)))
 
 (define (make-cstate input-channel output-channel)
-  (make-gstate (make-channel-input-source input-channel)
-              (make-channel-output-sink output-channel)
+  (make-gstate (make-binary-port (make-channel-input-source input-channel)
+                                (make-channel-output-sink output-channel))
               'TEXT
               'TEXT
               (default-object)