From: Chris Hanson Date: Wed, 26 Apr 2017 05:46:22 +0000 (-0700) Subject: Implement binary->textual-port. X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~136 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d09c978f159220b94a120a22f6f6a45a4a0fcc6e;p=mit-scheme.git 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 2c31a8145..d453b4ac7 100644 --- 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)) diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index c7199f54a..7a0310887 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -29,15 +29,14 @@ USA. (declare (usual-integrations)) -(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))) -(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 (%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 62b7d6b90..d5a36ff6e 100644 --- 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 8d37bbcec..9e3ec659f 100644 --- 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 a7b447297..f47fb561f 100644 --- 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 ea30480fd..34d637aea 100644 --- 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 81812ef21..effd7c306 100644 --- 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)