From: Chris Hanson Date: Wed, 25 Jan 2017 03:15:03 +0000 (-0800) Subject: Major refactor of textual I/O ports. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~89 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c8280070ab890a463cec633049ed05a7836c47c2;p=mit-scheme.git Major refactor of textual I/O ports. New design uses a binary port to do actual I/O, so is mostly about coding. --- diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm index ad6ce1127..b0945903e 100644 --- a/src/runtime/binary-port.scm +++ b/src/runtime/binary-port.scm @@ -29,8 +29,18 @@ USA. (declare (usual-integrations)) -(define (make-binary-port input-buffer output-buffer) - (%make-binary-port input-buffer output-buffer (make-alist-metadata-table))) +(define (make-binary-port source sink #!optional caller) + (if (not (or source sink)) + (error "Must provide either a source or a sink")) + (let ((port + (%make-binary-port (and source (make-input-buffer source caller)) + (and sink (make-output-buffer sink caller)) + (make-alist-metadata-table)))) + (if source + (set-source/sink-port! source port)) + (if sink + (set-source/sink-port! sink port)) + port)) (define-record-type (%make-binary-port input-buffer output-buffer metadata) @@ -39,28 +49,6 @@ USA. (output-buffer port-output-buffer) (metadata binary-port-metadata)) -(define (make-binary-input-port source caller) - (let ((port - (make-binary-port (make-input-buffer source caller) - #f))) - (set-source/sink-port! source port) - port)) - -(define (make-binary-output-port sink caller) - (let ((port - (make-binary-port #f - (make-output-buffer sink caller)))) - (set-source/sink-port! sink port) - port)) - -(define (make-binary-i/o-port source sink caller) - (let ((port - (make-binary-port (make-input-buffer source caller) - (make-output-buffer sink caller)))) - (set-source/sink-port! source port) - (set-source/sink-port! sink port) - port)) - (define (binary-input-port? object) (and (binary-port? object) (port-input-buffer object) @@ -115,7 +103,7 @@ USA. (if (not (fix:<= start end)) (error:bad-range-argument start 'open-input-bytevector)) start)))) - (make-binary-input-port + (make-binary-port (make-non-channel-input-source (lambda () (fix:<= start end)) @@ -127,6 +115,7 @@ USA. (set! start start*)) n) 0))) + #f 'open-input-bytevector))) ;;;; Bytevector output ports @@ -141,7 +130,8 @@ USA. initial-size))) (bytevector (make-bytevector size)) (index 0)) - (make-binary-output-port + (make-binary-port + #f (make-non-channel-output-sink (lambda (bv bs be) (let ((index* (fix:+ index (fix:- be bs)))) @@ -185,7 +175,7 @@ USA. (define (call-with-output-bytevector procedure) (let ((port (open-output-bytevector))) - (port port) + (procedure port) (get-output-bytevector port))) ;;;; Closing operations @@ -225,14 +215,67 @@ USA. (buffer-marked-closed? ib))))) (channel-close oc))))) +;;;; Positioning + +(define (positionable-binary-port? object) + (and (binary-port? object) + (binary-port-positionable? object))) + +(define (binary-port-positionable? port) + (let ((ib (port-input-buffer port)) + (ob (port-output-buffer port))) + (let ((ic (and ib (buffer-channel ib))) + (oc (and ob (buffer-channel ob)))) + (and (or ic oc) + (if (and ic oc) + (and (eq? ic oc) + (channel-type=file? ic)) + (channel-type=file? (or ic oc))))))) + +(add-boot-init! + (lambda () + (register-predicate! positionable-binary-port? 'positionable-binary-port + '<= binary-port?))) + +(define (binary-port-length port) + (guarantee positionable-binary-port? port 'port-length) + (channel-file-length (or (let ((ib (port-input-buffer port))) + (and ib + (buffer-channel ib))) + (buffer-channel (port-output-buffer port))))) + +(define (binary-port-position port) + (guarantee positionable-binary-port? port 'port-position) + (let ((ib (port-input-buffer port))) + (if ib + (- (channel-file-position (buffer-channel ib)) + (fix:- (buffer-end ib) (buffer-start ib))) + (channel-file-position (buffer-channel (port-output-buffer port)))))) + +(define (set-binary-port-position! port position) + (guarantee positionable-binary-port? port 'set-port-position!) + (let ((ib (port-input-buffer port)) + (ob (port-output-buffer port))) + (if ib (clear-input-buffer ib)) + (if ob (flush-output-buffer ob)) + (channel-file-set-position (or (and ib (buffer-channel ib)) + (and ob (buffer-channel ob))) + position))) + ;;;; Input operations (define (binary-input-port-open? port) (buffer-open? (port-input-buffer port))) +(define (binary-input-port-source port) + (buffer-source/sink (port-input-buffer port))) + (define (binary-input-port-channel port) (buffer-channel (port-input-buffer port))) +(define (binary-input-port-at-eof? port #!optional caller) + (eq? 'eof (input-buffer-state (port-input-buffer port) caller))) + (define (check-input-port port caller) (let* ((port (if (default-object? port) (current-input-port) port)) (ib (port-input-buffer port))) @@ -271,7 +314,7 @@ USA. ((eof) (eof-object)) (else #f))))) -(define (binary-input-port:buffer-contents port) +(define (binary-input-port-buffer-contents port) (let ((ib (check-input-port port 'input-port-buffer-contents))) (if (eq? 'filled (input-buffer-state ib 'input-port-buffer-contents)) (bytevector-copy (buffer-bytes ib) @@ -279,7 +322,7 @@ USA. (buffer-end ib)) (make-bytevector 0)))) -(define (binary-input-port:set-buffer-contents! port contents) +(define (set-binary-input-port-buffer-contents! port contents) (let ((ib (check-input-port port 'set-input-port-buffer-contents!))) (if (eq? 'unfilled (input-buffer-state ib 'set-input-port-buffer-contents!)) (let ((bv (buffer-bytes ib))) @@ -381,6 +424,10 @@ USA. (close-buffer ib) (mark-buffer-closed! ib)))) +(define (clear-input-buffer ib) + (set-buffer-start! ib 0) + (set-buffer-end! ib 0)) + (define (input-buffer-state ib caller) (if (buffer-marked-closed? ib) (error:bad-range-argument (buffer-port ib) caller)) @@ -410,15 +457,12 @@ USA. (define (binary-output-port-open? port) (buffer-open? (port-output-buffer port))) +(define (binary-output-port-sink port) + (buffer-source/sink (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 (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)) (ob (port-output-buffer port))) @@ -428,6 +472,13 @@ USA. (error:bad-range-argument port caller)) ob)) +(define (flush-binary-output-port port) + (flush-output-buffer (check-output-port port 'flush-output-port))) + +(define (binary-output-port-buffered-byte-count port) + (let ((ob (check-output-port port 'output-port-buffered-byte-count))) + (fix:- (buffer-end ob) (buffer-start ob)))) + (define (write-u8 byte #!optional port) (guarantee byte? byte 'write-u8) (let ((ob (check-output-port port 'write-u8))) @@ -649,7 +700,7 @@ USA. (define (make-channel-ss flavor channel . custom) (make-source/sink flavor - (lambda () channel) + channel (lambda () (channel-port channel)) (lambda (port) (set-channel-port! channel port)) (lambda () (channel-open? channel)) @@ -660,7 +711,7 @@ USA. (let ((port #f) (open? #t)) (make-source/sink flavor - (lambda () #f) + #f (lambda () port) (lambda (port*) (set! port port*) unspecific) (lambda () open?) diff --git a/src/runtime/fileio.scm b/src/runtime/fileio.scm index 236ce1203..31dc1ee69 100644 --- a/src/runtime/fileio.scm +++ b/src/runtime/fileio.scm @@ -50,55 +50,23 @@ USA. unspecific) (define (operation/pathname port) - (port-property 'pathname)) + (port-property port 'pathname)) (define (set-port-pathname! port pathname) (set-port-property! port 'pathname pathname)) (define (operation/length port) - (channel-file-length - (or (input-port-channel port) - (output-port-channel port)))) + (binary-port-length (generic-i/o-port->binary-port port))) (define (operation/write-self port output-port) (write-string " for file: " output-port) (write (->namestring (operation/pathname port)) output-port)) (define (operation/position port) - (guarantee-positionable-port port 'OPERATION/POSITION) - (if (output-port? port) - (flush-output port)) - (if (input-port? port) - (let ((input-buffer (port-input-buffer port))) - (- (channel-file-position (input-port-channel port)) - (input-buffer-free-bytes input-buffer))) - (channel-file-position (output-port-channel port)))) + (binary-port-position (generic-i/o-port->binary-port port))) (define (operation/set-position! port position) - (guarantee-positionable-port port 'OPERATION/SET-POSITION!) - (guarantee-exact-nonnegative-integer position 'OPERATION/SET-POSITION!) - (if (output-port? port) - (flush-output port)) - (if (input-port? port) - (clear-input-buffer (port-input-buffer port))) - (channel-file-set-position (if (input-port? port) - (input-port-channel port) - (output-port-channel port)) - position)) - -(define (guarantee-positionable-port port caller) - (guarantee textual-port? port caller) - (if (and (i/o-port? port) - (not (eq? (input-port-channel port) (output-port-channel port)))) - (error:bad-range-argument port caller)) - (if (and (input-port? port) - (not (input-buffer-using-binary-normalizer? - (port-input-buffer port)))) - (error:bad-range-argument port caller)) - (if (and (output-port? port) - (not (output-buffer-using-binary-denormalizer? - (port-output-buffer port)))) - (error:bad-range-argument port caller))) + (set-binary-port-position! (generic-i/o-port->binary-port port) position)) (define (input-file-opener caller make-port) (lambda (filename) @@ -129,26 +97,30 @@ USA. (channel (file-open-io-channel (->namestring pathname)))) (make-port channel channel pathname caller)))) -(define (make-textual-port input-channel output-channel pathname caller) +(define (make-textual-file-port input-channel output-channel pathname caller) caller - (let ((port (%make-textual-port input-channel output-channel pathname))) + (let ((port (%make-textual-file-port input-channel output-channel pathname))) (port/set-line-ending port (file-line-ending pathname)) port)) -(define (make-legacy-binary-port input-channel output-channel pathname caller) +(define (make-legacy-binary-file-port input-channel output-channel pathname + caller) caller - (let ((port (%make-textual-port input-channel output-channel pathname))) + (let ((port (%make-textual-file-port input-channel output-channel pathname))) (port/set-coding port 'BINARY) (port/set-line-ending port 'BINARY) port)) -(define (%make-textual-port input-channel output-channel pathname) +(define (%make-textual-file-port input-channel output-channel pathname) (let ((port - (make-generic-i/o-port input-channel - output-channel - (cond ((not input-channel) output-file-type) - ((not output-channel) input-file-type) - (else i/o-file-type))))) + (make-generic-i/o-port + (and input-channel + (make-channel-input-source input-channel)) + (and output-channel + (make-channel-output-sink output-channel)) + (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))) @@ -156,59 +128,56 @@ USA. port)) (define open-input-file - (input-file-opener 'open-input-file make-textual-port)) + (input-file-opener 'open-input-file make-textual-file-port)) (define open-output-file - (output-file-opener 'open-output-file make-textual-port)) + (output-file-opener 'open-output-file make-textual-file-port)) (define open-exclusive-output-file - (exclusive-output-file-opener 'open-exclusive-output-file make-textual-port)) + (exclusive-output-file-opener 'open-exclusive-output-file + make-textual-file-port)) (define open-i/o-file - (i/o-file-opener 'open-i/o-file make-textual-port)) + (i/o-file-opener 'open-i/o-file make-textual-file-port)) (define open-legacy-binary-input-file - (input-file-opener 'open-legacy-binary-input-file make-legacy-binary-port)) + (input-file-opener 'open-legacy-binary-input-file + make-legacy-binary-file-port)) (define open-legacy-binary-output-file - (output-file-opener 'open-legacy-binary-output-file make-legacy-binary-port)) + (output-file-opener 'open-legacy-binary-output-file + make-legacy-binary-file-port)) (define open-exclusive-legacy-binary-output-file (exclusive-output-file-opener 'open-exclusive-legacy-binary-output-file - make-legacy-binary-port)) + make-legacy-binary-file-port)) (define open-legacy-binary-i/o-file - (i/o-file-opener 'open-legacy-binary-i/o-file make-legacy-binary-port)) + (i/o-file-opener 'open-legacy-binary-i/o-file make-legacy-binary-file-port)) -(define (make-binary-port input-channel output-channel pathname caller) - (let ((port (%make-binary-port input-channel output-channel caller))) +(define (make-binary-file-port input-channel output-channel pathname caller) + (let ((port (%make-binary-file-port input-channel output-channel caller))) (set-port-pathname! port pathname) port)) -(define (%make-binary-port input-channel output-channel caller) - (cond ((not input-channel) - (make-binary-output-port (make-channel-output-sink output-channel) - caller)) - ((not output-channel) - (make-binary-input-port (make-channel-input-source input-channel) - caller)) - (else - (make-binary-i/o-port (make-channel-input-source input-channel) - (make-channel-output-sink output-channel) - caller)))) +(define (%make-binary-file-port input-channel output-channel caller) + (make-binary-port + (and input-channel (make-channel-input-source input-channel)) + (and output-channel (make-channel-output-sink output-channel)) + caller)) (define open-binary-input-file - (input-file-opener 'open-binary-input-file make-binary-port)) + (input-file-opener 'open-binary-input-file make-binary-file-port)) (define open-binary-output-file - (output-file-opener 'open-binary-output-file make-binary-port)) + (output-file-opener 'open-binary-output-file make-binary-file-port)) (define open-exclusive-binary-output-file (exclusive-output-file-opener 'open-exclusive-binary-output-file - make-binary-port)) + make-binary-file-port)) (define open-binary-i/o-file - (i/o-file-opener 'open-binary-i/o-file make-binary-port)) + (i/o-file-opener 'open-binary-i/o-file make-binary-file-port)) (define ((make-call-with-file open) input-specifier receiver) (let ((port (open input-specifier))) diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index 60213f456..80d70a4e8 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -27,8 +27,7 @@ USA. ;;;; Generic I/O Ports ;;; package: (runtime generic-i/o-port) -(declare (usual-integrations) - (integrate-external "port")) +(declare (usual-integrations)) (define (make-generic-i/o-port source sink #!optional type . extra-state) (if (not (or source sink)) @@ -42,20 +41,20 @@ USA. extra-state)))) (let ((ib (port-input-buffer port))) (if ib - ((source/set-port (input-buffer-source ib)) port))) + (set-input-buffer-port! ib port))) (let ((ob (port-output-buffer port))) (if ob - ((sink/set-port (output-buffer-sink ob)) port))) + (set-output-buffer-port! ob port))) port)) (define (source-type source) (cond ((not source) #f) - ((or (channel? source) ((source/get-channel source))) 'CHANNEL) + ((input-source-channel source) 'CHANNEL) (else #t))) (define (sink-type sink) (cond ((not sink) #f) - ((or (channel? sink) ((sink/get-channel sink))) 'CHANNEL) + ((output-sink-channel sink) 'CHANNEL) (else #t))) (define (generic-i/o-port-type source sink) @@ -75,104 +74,54 @@ USA. ((#F) generic-type10) ((CHANNEL) generic-type12) (else generic-type11))))) - -(define-structure (gstate (constructor %make-gstate)) - (input-buffer #f read-only #t) - (output-buffer #f read-only #t) - coding - line-ending - (extra #f read-only #t)) +(define (generic-i/o-port->binary-port port) + (or (let ((ib (port-input-buffer port))) + (and ib + (input-buffer-binary-port ib))) + (output-buffer-binary-port (port-output-buffer port)))) + (define (make-gstate source sink coder-name normalizer-name . extra) - (%make-gstate (and source - (make-input-buffer (->source source 'MAKE-GSTATE) - coder-name - normalizer-name)) - (and sink - (make-output-buffer (->sink sink 'MAKE-GSTATE) - coder-name - normalizer-name)) - coder-name - normalizer-name - (list->vector extra))) - -(define-integrable (port-input-buffer port) + (let ((binary-port (make-binary-port source sink))) + (%make-gstate (and source + (make-input-buffer binary-port + coder-name + normalizer-name)) + (and sink + (make-output-buffer binary-port + coder-name + normalizer-name)) + coder-name + normalizer-name + (list->vector extra)))) + +(define-record-type + (%make-gstate input-buffer output-buffer coder-name normalizer-name extra) + gstate? + (input-buffer gstate-input-buffer) + (output-buffer gstate-output-buffer) + (coder-name gstate-coder-name + set-gstate-coder-name!) + (normalizer-name gstate-normalizer-name + set-gstate-normalizer-name!) + (extra gstate-extra)) + +(define (port-input-buffer port) (gstate-input-buffer (textual-port-state port))) -(define-integrable (port-output-buffer port) +(define (port-output-buffer port) (gstate-output-buffer (textual-port-state port))) (define (generic-i/o-port-accessor index) - (guarantee-index-fixnum index 'GENERIC-I/O-PORT-ACCESSOR) + (guarantee index-fixnum? index 'generic-i/o-port-accessor) (lambda (port) - (let ((extra (gstate-extra (textual-port-state port)))) - (if (not (fix:< index (vector-length extra))) - (error "Accessor index out of range:" index)) - (vector-ref extra index)))) + (vector-ref (gstate-extra (textual-port-state port)) index))) (define (generic-i/o-port-modifier index) - (guarantee-index-fixnum index 'GENERIC-I/O-PORT-MODIFIER) + (guarantee index-fixnum? index 'generic-i/o-port-modifier) (lambda (port object) - (let ((extra (gstate-extra (textual-port-state port)))) - (if (not (fix:< index (vector-length extra))) - (error "Accessor index out of range:" index)) - (vector-set! extra index object)))) + (vector-set! (gstate-extra (textual-port-state port)) index object))) -(define (initialize-package!) - (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))) - (ops:in2 - `((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))) - (ops:out2 - `((OUTPUT-CHANNEL ,generic-io/output-channel) - (SYNCHRONIZE-OUTPUT ,generic-io/synchronize-output))) - (other-operations - `((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) - other-operations) - #f)))) - (set! generic-type00 (make-type)) - (set! generic-type10 (make-type ops:in1)) - (set! generic-type20 (make-type ops:in1 ops:in2)) - (set! generic-type01 (make-type ops:out1)) - (set! generic-type02 (make-type ops:out1 ops:out2)) - (set! generic-type11 (make-type ops:in1 ops:out1)) - (set! generic-type21 (make-type ops:in1 ops:in2 ops:out1)) - (set! generic-type12 (make-type ops:in1 ops:out1 ops:out2)) - (set! generic-type22 (make-type ops:in1 ops:in2 ops:out1 ops:out2)))) - (initialize-name-maps!) - (initialize-conditions!)) - (define generic-type00) (define generic-type10) (define generic-type20) @@ -182,47 +131,109 @@ USA. (define generic-type21) (define generic-type12) (define generic-type22) +(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))) + (ops:in2 + `((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))) + (ops:out2 + `((OUTPUT-CHANNEL ,generic-io/output-channel) + (SYNCHRONIZE-OUTPUT ,generic-io/synchronize-output))) + (other-operations + `((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) + other-operations) + #f)))) + (set! generic-type00 (make-type)) + (set! generic-type10 (make-type ops:in1)) + (set! generic-type20 (make-type ops:in1 ops:in2)) + (set! generic-type01 (make-type ops:out1)) + (set! generic-type02 (make-type ops:out1 ops:out2)) + (set! generic-type11 (make-type ops:in1 ops:out1)) + (set! generic-type21 (make-type ops:in1 ops:in2 ops:out1)) + (set! generic-type12 (make-type ops:in1 ops:out1 ops:out2)) + (set! generic-type22 (make-type ops:in1 ops:in2 ops:out1 ops:out2)))))) ;;;; Input operations (define (generic-io/char-ready? port) - (buffer-has-input? (port-input-buffer port))) + (let ((ib (port-input-buffer port))) + (or (input-buffer-peeked ib) + (u8-ready? (input-buffer-binary-port ib))))) (define (generic-io/peek-char port) - (let* ((ib (port-input-buffer port)) - (line (input-buffer-line ib)) - (char (generic-io/read-char port))) - (if (char? char) - ;; Undo effect of read-char. - (begin - (set-input-buffer-line! ib line) - (set-input-buffer-start! ib (input-buffer-prev ib)))) - char)) + (let ((ib (port-input-buffer port))) + (or (input-buffer-peeked ib) + (let ((char ((input-buffer-normalizer ib) ib))) + (if (char? char) + (set-input-buffer-peeked! ib char)) + char)))) (define (generic-io/read-char port) (let ((ib (port-input-buffer port))) - (reset-prev-char ib) - (let loop () - (or (read-next-char ib) - (let ((r (fill-input-buffer ib))) - (case r - ((OK) (loop)) - ((WOULD-BLOCK) #f) - ((EOF) (eof-object)) - (else (error "Unknown result:" r)))))))) + (let ((char (input-buffer-peeked ib))) + (if char + (begin + (set-input-buffer-peeked! ib #f) + char) + (let ((char ((input-buffer-normalizer ib) ib))) + (if (eq? char #\newline) + (let ((line (input-buffer-line ib))) + (if line + (set-input-buffer-line! ib (fix:+ line 1))))) + char))))) (define (generic-io/unread-char port char) (let ((ib (port-input-buffer port))) - (let ((bp (input-buffer-prev ib))) - (if (not (fix:< bp (input-buffer-start ib))) - (error "No char to unread:" port)) - ;; If unreading a newline, decrement the line count. - (if (char=? char #\newline) - (set-input-buffer-line! ib (fix:- (input-buffer-line ib) 1))) - (set-input-buffer-start! ib bp)))) + (guarantee char? char 'unread-char) + (if (input-buffer-peeked ib) + (error "Can't unread another char:" char (input-buffer-port ib))) + (set-input-buffer-peeked! ib char) + ;; If unreading a newline, decrement the line count. + (if (char=? char #\newline) + (set-input-buffer-line! ib (fix:- (input-buffer-line ib) 1))))) (define (generic-io/read-substring port string start end) - (read-substring (port-input-buffer port) string start end)) + (let loop ((index start)) + (if (fix:< index end) + (let ((char (generic-io/read-char port))) + (cond ((not char) #f) + ((eof-object? char) (fix:- index start)) + (else + (xstring-set! string index char) + (loop (fix:+ index 1))))) + (fix:- end start)))) (define (generic-io/input-line port) (input-buffer-line (port-input-buffer port))) @@ -239,20 +250,21 @@ USA. ;;;; Output operations (define (generic-io/write-char port char) - (let ((ob (port-output-buffer port))) - (let loop () - (if (write-next-char ob char) - 1 - (let ((n (drain-output-buffer ob))) - (if (and n (fix:> n 0)) - (loop) - n)))))) + (guarantee char? char) + (write-next-char (port-output-buffer port) char)) (define (generic-io/write-substring port string start end) - (write-substring (port-output-buffer port) string start end)) + (let ((ob (port-output-buffer port))) + (let loop ((index start)) + (if (fix:< index end) + (let ((n (write-next-char ob (xstring-ref string index)))) + (cond ((and n (fix:> n 0)) (loop (fix:+ index 1))) + ((fix:< start index) (fix:- index start)) + (else n))) + (fix:- end start))))) (define (generic-io/flush-output port) - (force-drain-output-buffer (port-output-buffer port))) + (flush-output-buffer (port-output-buffer port))) (define (generic-io/output-column port) (output-buffer-column (port-output-buffer port))) @@ -269,7 +281,8 @@ USA. (channel-synchronize channel)))) (define (generic-io/buffered-output-bytes port) - (output-buffer-start (port-output-buffer port))) + (binary-output-port-buffered-byte-count + (output-buffer-binary-port (port-output-buffer port)))) (define (generic-io/bytes-written port) (output-buffer-total (port-output-buffer port))) @@ -277,52 +290,23 @@ USA. ;;;; Non-specific operations (define (generic-io/close port) - (maybe-close-input port) - (maybe-close-output port) - (maybe-close-channels port)) - -(define (generic-io/close-output port) - (maybe-close-output port) - (maybe-close-channels port)) - -(define (generic-io/close-input port) - (maybe-close-input port) - (maybe-close-channels port)) - -(define (maybe-close-input port) - (let ((ib (port-input-buffer port))) - (if ib - (close-input-buffer ib)))) - -(define (maybe-close-output port) - (let ((ob (port-output-buffer port))) - (if ob - (close-output-buffer ob)))) - -(define (maybe-close-channels port) (let ((ib (port-input-buffer port)) (ob (port-output-buffer port))) - (let ((ic (and ib (input-buffer-channel ib))) - (oc (and ob (output-buffer-channel ob)))) - (if (and ic (eq? ic oc)) - (if (and (not (%input-buffer-open? ib)) - (not (%output-buffer-open? ob))) - (channel-close ic)) - (begin - (if (and ic (not (%input-buffer-open? ib))) - (channel-close ic)) - (if (and oc (not (%output-buffer-open? ob))) - (channel-close oc))))))) + (cond ((and ib + ob + (eq? (input-buffer-binary-port ib) + (output-buffer-binary-port ob))) + (close-binary-port (input-buffer-binary-port ib))) + (ib (close-binary-input-port (input-buffer-binary-port ib))) + (ob (close-binary-output-port (output-buffer-binary-port ob)))))) -(define (generic-io/output-open? port) - (let ((ob (port-output-buffer port))) - (and ob - (output-buffer-open? ob)))) +(define (generic-io/close-input port) + (close-binary-input-port + (input-buffer-binary-port (port-input-buffer port)))) -(define (generic-io/input-open? port) - (let ((ib (port-input-buffer port))) - (and ib - (input-buffer-open? ib)))) +(define (generic-io/close-output port) + (close-binary-output-port + (output-buffer-binary-port (port-output-buffer port)))) (define (generic-io/open? port) (and (let ((ib (port-input-buffer port))) @@ -334,6 +318,16 @@ USA. (output-buffer-open? ob) #t)))) +(define (generic-io/input-open? port) + (let ((ib (port-input-buffer port))) + (and ib + (input-buffer-open? ib)))) + +(define (generic-io/output-open? port) + (let ((ob (port-output-buffer port))) + (and ob + (output-buffer-open? ob)))) + (define (generic-io/write-self port output-port) (cond ((i/o-port? port) (write-string " for channels: " output-port) @@ -352,17 +346,16 @@ USA. #t) (define (generic-io/coding port) - (gstate-coding (textual-port-state port))) + (gstate-coder-name (textual-port-state port))) (define (generic-io/set-coding port name) - (let ((state (textual-port-state port))) - (let ((ib (gstate-input-buffer state))) - (if ib - (set-input-buffer-coding! ib name))) - (let ((ob (gstate-output-buffer state))) - (if ob - (set-output-buffer-coding! ob name))) - (set-gstate-coding! state name))) + (let ((ib (port-input-buffer port))) + (if ib + (set-input-buffer-coding! ib name))) + (let ((ob (port-output-buffer port))) + (if ob + (set-output-buffer-coding! ob name))) + (set-gstate-coder-name! (textual-port-state port) name)) (define (generic-io/known-coding? port coding) (and (if (input-port? port) (known-input-port-coding? coding) #t) @@ -370,28 +363,28 @@ USA. (define (generic-io/known-codings port) (cond ((i/o-port? port) - (eq-intersection (known-input-port-codings) - (known-output-port-codings))) + (lset-intersection eq? + (known-input-port-codings) + (known-output-port-codings))) ((input-port? port) (known-input-port-codings)) ((output-port? port) (known-output-port-codings)) (else '()))) (define (generic-io/line-ending port) - (gstate-line-ending (textual-port-state port))) + (gstate-normalizer-name (textual-port-state port))) (define (generic-io/set-line-ending port name) - (let ((state (textual-port-state port))) - (let ((ib (gstate-input-buffer state))) - (if ib - (set-input-buffer-line-ending! - ib - (line-ending (input-buffer-channel ib) name #f)))) - (let ((ob (gstate-output-buffer state))) - (if ob - (set-output-buffer-line-ending! - ob - (line-ending (output-buffer-channel ob) name #t)))) - (set-gstate-line-ending! state name))) + (let ((ib (port-input-buffer port))) + (if ib + (set-input-buffer-line-ending! + ib + (line-ending (input-buffer-channel ib) name #f)))) + (let ((ob (port-output-buffer port))) + (if ob + (set-output-buffer-line-ending! + ob + (line-ending (output-buffer-channel ob) name #t)))) + (set-gstate-normalizer-name! (textual-port-state port) name)) (define (generic-io/known-line-ending? port line-ending) (and (if (input-port? port) (known-input-line-ending? line-ending) #t) @@ -399,8 +392,9 @@ USA. (define (generic-io/known-line-endings port) (cond ((i/o-port? port) - (eq-intersection (known-input-line-endings) - (known-output-line-endings))) + (lset-intersection eq? + (known-input-line-endings) + (known-output-line-endings))) ((input-port? port) (known-input-line-endings)) ((output-port? port) (known-output-line-endings)) (else '()))) @@ -410,16 +404,11 @@ USA. (if (and for-output? (known-input-line-ending? name) (not (known-output-line-ending? name))) - (if (and channel (eq? (channel-type channel) 'TCP-STREAM-SOCKET)) + (if (and channel + (eq? (channel-type channel) 'TCP-STREAM-SOCKET)) 'CRLF (default-line-ending)) name)) - -(define (eq-intersection a b) - (let loop ((a a)) - (cond ((not (pair? a)) '()) - ((memq (car a) b) (cons (car a) (loop (cdr a)))) - (else (loop (cdr a)))))) ;;;; Name maps @@ -463,7 +452,6 @@ USA. (define-name-map decoder) (define-name-map encoder) -(define-name-map sizer) (define-name-map normalizer) (define-name-map denormalizer) @@ -499,63 +487,59 @@ USA. (append (hash-table/key-list denormalizer-aliases) (hash-table/key-list denormalizers))) -(define (initialize-name-maps!) - (let ((convert-reverse - (lambda (alist) - (let ((table (make-strong-eq-hash-table))) - (for-each (lambda (n.d) - (hash-table/put! table (cdr n.d) (car n.d))) - alist) - table))) - (convert-forward - (lambda (alist) - (let ((table (make-strong-eq-hash-table))) - (for-each (lambda (n.d) - (hash-table/put! table (car n.d) (cdr n.d))) - alist) - table)))) - (let-syntax - ((initialize-name-map - (sc-macro-transformer - (lambda (form environment) - environment - (if (syntax-match? '(SYMBOL) (cdr form)) - (let ((sing (cadr form))) - (let ((plur (symbol sing 'S)) - (aliases (symbol sing '-ALIASES)) - (proc (symbol 'DEFINE- sing))) - (let ((aproc (symbol proc '-ALIAS))) - `(BEGIN - (SET! ,(symbol plur '-REVERSE) - (CONVERT-REVERSE ,plur)) - (SET! ,plur (CONVERT-FORWARD ,plur)) - (SET! ,proc ,(symbol proc '/POST-BOOT)) - (SET! ,aliases (CONVERT-FORWARD ,aliases)) - (SET! ,aproc ,(symbol aproc '/POST-BOOT)))))) - (ill-formed-syntax form)))))) - (initialize-name-map decoder) - (initialize-name-map encoder) - (initialize-name-map sizer) - (initialize-name-map normalizer) - (initialize-name-map denormalizer))) - (set! binary-decoder (name->decoder 'BINARY)) - (set! binary-encoder (name->encoder 'BINARY)) - (set! binary-sizer (name->sizer 'BINARY)) - (set! binary-normalizer (name->normalizer 'BINARY)) - (set! binary-denormalizer (name->denormalizer 'BINARY)) - unspecific) - (define binary-decoder) (define binary-encoder) -(define binary-sizer) (define binary-normalizer) (define binary-denormalizer) +(add-boot-init! + (lambda () + (let ((convert-reverse + (lambda (alist) + (let ((table (make-strong-eq-hash-table))) + (for-each (lambda (n.d) + (hash-table/put! table (cdr n.d) (car n.d))) + alist) + table))) + (convert-forward + (lambda (alist) + (let ((table (make-strong-eq-hash-table))) + (for-each (lambda (n.d) + (hash-table/put! table (car n.d) (cdr n.d))) + alist) + table)))) + (let-syntax + ((initialize-name-map + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(SYMBOL) (cdr form)) + (let ((sing (cadr form))) + (let ((plur (symbol sing 'S)) + (aliases (symbol sing '-ALIASES)) + (proc (symbol 'DEFINE- sing))) + (let ((aproc (symbol proc '-ALIAS))) + `(BEGIN + (SET! ,(symbol plur '-REVERSE) + (CONVERT-REVERSE ,plur)) + (SET! ,plur (CONVERT-FORWARD ,plur)) + (SET! ,proc ,(symbol proc '/POST-BOOT)) + (SET! ,aliases (CONVERT-FORWARD ,aliases)) + (SET! ,aproc ,(symbol aproc '/POST-BOOT)))))) + (ill-formed-syntax form)))))) + (initialize-name-map decoder) + (initialize-name-map encoder) + (initialize-name-map normalizer) + (initialize-name-map denormalizer))) + (set! binary-decoder (name->decoder 'BINARY)) + (set! binary-encoder (name->encoder 'BINARY)) + (set! binary-normalizer (name->normalizer 'BINARY)) + (set! binary-denormalizer (name->denormalizer 'BINARY)) + unspecific)) (define (define-coding-aliases name aliases) (for-each (lambda (alias) (define-decoder-alias alias name) - (define-encoder-alias alias name) - (define-sizer-alias alias name)) + (define-encoder-alias alias name)) aliases)) (define (primary-input-port-codings) @@ -563,483 +547,233 @@ USA. (define (primary-output-port-codings) (cons 'US-ASCII (hash-table/key-list encoders))) - -;;;; Byte sources - -(define-structure (source (constructor make-gsource) (conc-name source/)) - (get-channel #f read-only #t) - (get-port #f read-only #t) - (set-port #f read-only #t) - (open? #f read-only #t) - (close #f read-only #t) - (has-bytes? #f read-only #t) - (read #f read-only #t)) - -(define-guarantee source "byte source") - -(define (->source object #!optional caller) - (if (channel? object) - (make-channel-source object) - (begin - (guarantee-source object caller) - object))) - -(define (make-channel-source channel) - (make-gsource (lambda () channel) - (lambda () (channel-port channel)) - (lambda (port) (set-channel-port! channel port)) - (lambda () (channel-open? channel)) - (lambda () ;; channel-close provided by maybe-close-channels - unspecific) - (lambda () (channel-has-input? channel)) - (lambda (string start end) - (channel-read channel string start end)))) - -(define (make-non-channel-port-source has-bytes? read-bytes) - (let ((port #f) - (open? #t)) - (make-gsource (lambda () #f) - (lambda () port) - (lambda (port*) (set! port port*) unspecific) - (lambda () open?) - (lambda () (set! open? #f) unspecific) - has-bytes? - read-bytes))) - -;;;; Byte Sinks - -(define-structure (sink (constructor make-gsink) (conc-name sink/)) - (get-channel #f read-only #t) - (get-port #f read-only #t) - (set-port #f read-only #t) - (open? #f read-only #t) - (close #f read-only #t) - (write #f read-only #t)) - -(define-guarantee sink "byte sink") - -(define (->sink object #!optional caller) - (if (channel? object) - (make-channel-sink object) - (begin - (guarantee-sink object caller) - object))) - -(define (make-channel-sink channel) - (make-gsink (lambda () channel) - (lambda () (channel-port channel)) - (lambda (port) (set-channel-port! channel port)) - (lambda () (channel-open? channel)) - (lambda () ;; channel-close provided by maybe-close-channels - unspecific) - (lambda (string start end) - (channel-write channel string start end)))) - -(define (make-non-channel-port-sink write-bytes) - (let ((port #f) - (open? #t)) - (make-gsink (lambda () #f) - (lambda () port) - (lambda (port*) (set! port port*) unspecific) - (lambda () open?) - (lambda () (set! open? #f) unspecific) - write-bytes))) + +(define max-char-bytes 4) ;;;; Input buffer -(define-integrable page-size #x1000) -(define-integrable max-char-bytes 4) - -(define-integrable byte-buffer-length - (fix:+ page-size - (fix:- (fix:* max-char-bytes 4) 1))) - -(define-structure (input-buffer (constructor %make-input-buffer)) - (source #f read-only #t) - (bytes #f read-only #t) - prev - start - end - decode - normalize - line - compute-encoded-character-size) - -(define (make-input-buffer source coder-name normalizer-name) - (%make-input-buffer source - (make-string byte-buffer-length) - byte-buffer-length - byte-buffer-length - byte-buffer-length +(define (make-input-buffer binary-port coder-name normalizer-name) + (%make-input-buffer binary-port (name->decoder coder-name) (name->normalizer - (line-ending ((source/get-channel source)) + (line-ending (binary-input-port-channel binary-port) normalizer-name #f)) - 0 - (name->sizer coder-name))) + (make-bytevector max-char-bytes) + #f + '() + 0)) + +(define-record-type + (%make-input-buffer binary-port decoder normalizer + bytes peeked decoded-chars line) + input-buffer? + (binary-port input-buffer-binary-port) + (decoder input-buffer-decoder + set-input-buffer-decoder!) + (normalizer input-buffer-normalizer + set-input-buffer-normalizer!) + (bytes input-buffer-bytes) + (peeked input-buffer-peeked + set-input-buffer-peeked!) + (decoded-chars input-buffer-decoded-chars + set-input-buffer-decoded-chars!) + (line input-buffer-line + set-input-buffer-line!)) (define (input-buffer-open? ib) - (and (%input-buffer-open? ib) - ((source/open? (input-buffer-source ib))))) - -(define (%input-buffer-open? ib) - (fix:>= (input-buffer-end ib) 0)) - -(define (clear-input-buffer ib) - (set-input-buffer-prev! ib byte-buffer-length) - (set-input-buffer-start! ib byte-buffer-length) - (set-input-buffer-end! ib byte-buffer-length)) - -(define (close-input-buffer ib) - ((source/close (input-buffer-source ib))) - (set-input-buffer-line! ib -1) - (set-input-buffer-prev! ib -1) - (set-input-buffer-start! ib -1) - (set-input-buffer-end! ib -1)) - + (binary-input-port-open? (input-buffer-binary-port ib))) + (define (input-buffer-channel ib) - ((source/get-channel (input-buffer-source ib)))) + (input-source-channel (%input-buffer-source ib))) (define (input-buffer-port ib) - ((source/get-port (input-buffer-source ib)))) - -(define (input-buffer-at-eof? ib) - (or (fix:<= (input-buffer-end ib) 0) - (and (fix:= (input-buffer-prev ib) 0) - (fix:= (input-buffer-start ib) (input-buffer-end ib))))) - -(define (input-buffer-encoded-character-size ib char) - ((input-buffer-compute-encoded-character-size ib) ib char)) - -(define (read-next-char ib) - (let ((char ((input-buffer-normalize ib) ib))) - (if (and (char? char) - (char=? char #\newline)) - (let ((line (input-buffer-line ib))) - (if line - (set-input-buffer-line! ib (fix:+ line 1))))) - char)) + (input-source-port (%input-buffer-source ib))) -(define (decode-char ib) - (and (fix:< (input-buffer-start ib) (input-buffer-end ib)) - (let ((cp ((input-buffer-decode ib) ib))) - (and cp - (integer->char cp))))) +(define (set-input-buffer-port! ib port) + (set-input-source-port! (%input-buffer-source ib) port)) -(define (reset-prev-char ib) - (set-input-buffer-prev! ib (input-buffer-start ib))) +(define (%input-buffer-source ib) + (binary-input-port-source (input-buffer-binary-port ib))) +(define (input-buffer-at-eof? ib) + (binary-input-port-at-eof? (input-buffer-binary-port ib))) + (define (set-input-buffer-coding! ib coding) - (reset-prev-char ib) - (set-input-buffer-decode! ib (name->decoder coding))) + (set-input-buffer-decoder! ib (name->decoder coding))) (define (set-input-buffer-line-ending! ib name) - (reset-prev-char ib) - (set-input-buffer-normalize! ib (name->normalizer name))) - -(define (input-buffer-using-binary-normalizer? ib) - (eq? (input-buffer-normalize ib) binary-normalizer)) - -(define (input-buffer-contents ib) - (substring (input-buffer-bytes ib) - (input-buffer-start ib) - (input-buffer-end ib))) - -(define (set-input-buffer-contents! ib contents) - (guarantee-string contents 'SET-INPUT-BUFFER-CONTENTS!) - (let ((bv (input-buffer-bytes ib))) - (let ((n (fix:min (string-length contents) (string-length bv)))) - (substring-move! contents 0 n bv 0) - (set-input-buffer-prev! ib 0) - (set-input-buffer-start! ib 0) - (set-input-buffer-end! ib n)))) - -(define (input-buffer-free-bytes ib) - (fix:- (input-buffer-end ib) - (input-buffer-start ib))) - -(define (fill-input-buffer ib) - (if (input-buffer-at-eof? ib) - 'EOF - (let ((n (read-bytes ib))) - (cond ((not n) 'WOULD-BLOCK) - ((fix:> n 0) 'OK) - (else 'EOF))))) - -(define (buffer-has-input? ib) - (or (next-char-ready? ib) - (input-buffer-at-eof? ib) - (and ((source/has-bytes? (input-buffer-source ib))) - (begin - (read-bytes ib) - (next-char-ready? ib))))) - -(define (next-char-ready? ib) - (let ((bl (input-buffer-line ib)) - (bs (input-buffer-start ib))) - (and (read-next-char ib) - (begin - (set-input-buffer-line! ib bl) - (set-input-buffer-start! ib bs) - #t)))) - -(define (read-bytes ib) - ;; assumption: (not (input-buffer-at-eof? ib)) - (reset-prev-char ib) - (let ((bv (input-buffer-bytes ib))) - (let ((do-read - (lambda (be) - (let ((be* (fix:+ be page-size))) - (if (not (fix:<= be* (vector-8b-length bv))) - (error "Input buffer overflow:" ib)) - ((source/read (input-buffer-source ib)) bv be be*))))) - (let ((bs (input-buffer-start ib)) - (be (input-buffer-end ib))) - (if (fix:< bs be) - (begin - (if (fix:> bs 0) - (do ((i bs (fix:+ i 1)) - (j 0 (fix:+ j 1))) - ((not (fix:< i be)) - (set-input-buffer-prev! ib 0) - (set-input-buffer-start! ib 0) - (set-input-buffer-end! ib j)) - (string-set! bv j (string-ref bv i)))) - (let ((be (input-buffer-end ib))) - (let ((n (do-read be))) - (if n - (set-input-buffer-end! ib (fix:+ be n))) - n))) - (let ((n (do-read 0))) - (if n - (begin - (set-input-buffer-prev! ib 0) - (set-input-buffer-start! ib 0) - (set-input-buffer-end! ib n))) - n)))))) - -(define (read-substring ib string start end) - (reset-prev-char ib) - (cond ((string? string) - (if (input-buffer-in-8-bit-mode? ib) - (let ((bv (input-buffer-bytes ib)) - (bs (input-buffer-start ib)) - (be (input-buffer-end ib))) - (if (fix:< bs be) - (let ((n (fix:min (fix:- be bs) (fix:- end start)))) - (let ((be (fix:+ bs n))) - (%substring-move! bv bs be string start) - (set-input-buffer-prev! ib be) - (set-input-buffer-start! ib be) - n)) - ((source/read (input-buffer-source ib)) string start end))) - (read-to-8-bit ib string start end))) - ((wide-string? string) - (let ((v (wide-string-contents string))) - (let loop ((i start)) - (cond ((not (fix:< i end)) - (fix:- i start)) - ((read-next-char ib) - => (lambda (char) - (vector-set! v i char) - (loop (fix:+ i 1)))) - ((fix:> i start) - (fix:- i start)) - (else - (let ((r (fill-input-buffer ib))) - (case r - ((OK) (loop i)) - ((WOULD-BLOCK) #f) - ((EOF) 0) - (else (error "Unknown result:" r))))))))) - (else - (error:not-string string 'INPUT-PORT/READ-SUBSTRING!)))) - -(define (input-buffer-in-8-bit-mode? ib) - (and (eq? (input-buffer-decode ib) binary-decoder) - (eq? (input-buffer-normalize ib) binary-normalizer))) - -(define (read-to-8-bit ib string start end) - (let ((n - (let loop ((i start)) - (if (fix:< i end) - (let ((char (read-next-char ib))) - (if char - (if (fix:< (char->integer char) #x100) - (begin - (string-set! string i char) - (loop (fix:+ i 1))) - (error "Character too large for 8-bit string:" char)) - (fix:- i start))) - (fix:- i start))))) - (if (fix:> n 0) - n - (let ((r (fill-input-buffer ib))) - (case r - ((OK) (read-to-8-bit ib string start end)) - ((WOULD-BLOCK) #f) - ((EOF) 0) - (else (error "Unknown result:" r))))))) + (set-input-buffer-normalizer! ib (name->normalizer name))) + +(define (generic-input-port-buffer-contents port) + (binary-input-port-buffer-contents + (input-buffer-binary-port (port-input-buffer port)))) + +(define (set-generic-input-port-buffer-contents! port contents) + (set-binary-input-port-buffer-contents! + (input-buffer-binary-port (port-input-buffer port)) + contents)) + +;; Next two for use only in normalizers. + +(define (decode-char ib) + (let ((chars (input-buffer-decoded-chars ib))) + (if (pair? chars) + (let ((char (car chars))) + (set-input-buffer-decoded-chars! ib (cdr chars)) + char) + (let ((u8 (peek-byte ib))) + (if (fix:fixnum? u8) + ((input-buffer-decoder ib) ib) + u8))))) + +(define (unread-decoded-char ib char) + (set-input-buffer-decoded-chars! + ib + (cons char (input-buffer-decoded-chars ib)))) + +;;; Next three for use only in decoders. + +(define (peek-byte ib) + (peek-u8 (input-buffer-binary-port ib))) + +(define (read-byte ib) + (read-u8 (input-buffer-binary-port ib))) + +(define (read-bytes! ib start end) + (let loop ((index start)) + (if (fix:< index end) + (let ((n + (read-bytevector! (input-buffer-bytes ib) + (input-buffer-binary-port ib) + index + end))) + (if (not (and (fix:fixnum? n) (fix:> n 0))) + (error:char-decoding ib)) + (loop (fix:+ index n)))))) ;;;; Output buffer -(define-structure (output-buffer (constructor %make-output-buffer)) - (sink #f read-only #t) - (bytes #f read-only #t) - start - total - encode - denormalize - column) - -(define (make-output-buffer sink coder-name normalizer-name) - (%make-output-buffer sink - (make-string byte-buffer-length) - 0 - 0 +(define (make-output-buffer binary-port coder-name normalizer-name) + (%make-output-buffer binary-port (name->encoder coder-name) (name->denormalizer - (line-ending ((sink/get-channel sink)) + (line-ending (binary-output-port-channel binary-port) normalizer-name #t)) + (make-bytevector max-char-bytes) + 0 + 0 0)) -(define (output-buffer-open? ob) - (and (%output-buffer-open? ob) - ((sink/open? (output-buffer-sink ob))))) - -(define (%output-buffer-open? ob) - (fix:>= (output-buffer-start ob) 0)) +(define-record-type + (%make-output-buffer binary-port encoder denormalizer + bytes line column total) + output-buffer? + (binary-port output-buffer-binary-port) + (encoder output-buffer-encoder + set-output-buffer-encoder!) + (denormalizer output-buffer-denormalizer + set-output-buffer-denormalizer!) + (bytes output-buffer-bytes) + (line output-buffer-line + set-output-buffer-line!) + (column output-buffer-column + set-output-buffer-column!) + (total output-buffer-total + set-output-buffer-total!)) -(define (close-output-buffer ob) - (if (output-buffer-open? ob) - (begin - (force-drain-output-buffer ob) - ((sink/close (output-buffer-sink ob))) - (set-output-buffer-start! ob -1)))) +(define (output-buffer-open? ob) + (binary-output-port-open? (output-buffer-binary-port ob))) (define (output-buffer-channel ob) - ((sink/get-channel (output-buffer-sink ob)))) + (output-sink-channel (%output-buffer-sink ob))) (define (output-buffer-port ob) - ((sink/get-port (output-buffer-sink ob)))) + (output-sink-port (%output-buffer-sink ob))) -(define-integrable (output-buffer-end ob) - (string-length (output-buffer-bytes ob))) +(define (set-output-buffer-port! ob port) + (set-output-sink-port! (%output-buffer-sink ob) port)) -(define (flush-output-buffer buffer) - (set-output-buffer-start! buffer 0)) +(define (%output-buffer-sink ob) + (binary-output-port-sink (output-buffer-binary-port ob))) -(define (force-drain-output-buffer ob) +(define (flush-output-buffer ob) (let ((channel (output-buffer-channel ob)) - (drain-buffer + (do-flush (lambda () - (let loop () - (drain-output-buffer ob) - (if (fix:> (output-buffer-start ob) 0) - (loop)))))) + (flush-binary-output-port (output-buffer-binary-port ob))))) (if channel - (with-channel-blocking channel #t drain-buffer) - (drain-buffer)))) + (with-channel-blocking channel #t do-flush) + (do-flush)))) -(define (drain-output-buffer ob) - (let ((bs (output-buffer-start ob))) - (if (fix:> bs 0) - (let ((bv (output-buffer-bytes ob))) - (let ((n - ((sink/write (output-buffer-sink ob)) - bv - 0 - (fix:min bs page-size)))) - (if (and n (fix:> n 0)) - (do ((bi n (fix:+ bi 1)) - (bj 0 (fix:+ bj 1))) - ((not (fix:< bi bs)) - (set-output-buffer-start! ob bj)) - (vector-8b-set! bv bj (vector-8b-ref bv bi)))) - n)) - 0))) +(define (set-output-buffer-coding! ob coding) + (set-output-buffer-encoder! ob (name->encoder coding))) -(define (write-next-char ob char) - (and (fix:< (output-buffer-start ob) page-size) - (begin - ((output-buffer-denormalize ob) ob char) - (if (char=? char #\newline) - (set-output-buffer-column! ob 0) - (let ((column (output-buffer-column ob))) - (if column - (set-output-buffer-column! - ob - (cond ((char=? char #\tab) - (fix:+ column (fix:- 8 (fix:remainder column 8)))) - ((and (fix:<= #x20 (char->integer char)) - (fix:<= (char->integer char) #x7E)) - (fix:+ column 1)) - (else #f)))))) - #t))) - -(define (output-buffer-in-8-bit-mode? ob) - (and (eq? (output-buffer-encode ob) binary-encoder) - (eq? (output-buffer-denormalize ob) binary-denormalizer))) +(define (set-output-buffer-line-ending! ob name) + (set-output-buffer-denormalizer! ob (name->denormalizer name))) (define (output-buffer-using-binary-denormalizer? ob) - (eq? (output-buffer-denormalize ob) binary-denormalizer)) + (eq? (output-buffer-denormalizer ob) binary-denormalizer)) +;; Returns >0 if the character was written in its entirety. +;; Returns 0 if the character wasn't written at all. +;; Returns #f if the write would block. +;; Throws an error if there was a short write. +(define (write-next-char ob char) + (let ((n ((output-buffer-denormalizer ob) ob char))) + (if (and n (fix:> n 0)) + (if (char=? char #\newline) + (begin + (set-output-buffer-column! ob 0) + (set-output-buffer-line! ob (fix:+ (output-buffer-line ob) 1))) + (let ((column (output-buffer-column ob))) + (if column + (set-output-buffer-column! + ob + (cond ((char=? char #\tab) + (fix:+ column (fix:- 8 (fix:remainder column 8)))) + ((and (fix:<= #x20 (char->integer char)) + (fix:<= (char->integer char) #x7E)) + (fix:+ column 1)) + (else #f))))))) + n)) + +;; For use only in denormalizers. +;; Returns 1 if the character was written in its entirety. +;; Returns 0 if the character wasn't written at all. +;; Returns #f if the write would block. +;; Throws an error if there was a short write. (define (encode-char ob char) - (let ((n-bytes ((output-buffer-encode ob) ob (char->integer char)))) - (set-output-buffer-start! ob (fix:+ (output-buffer-start ob) n-bytes)) - (set-output-buffer-total! ob (fix:+ (output-buffer-total ob) n-bytes)))) - -(define (set-output-buffer-coding! ob coding) - (set-output-buffer-encode! ob (name->encoder coding))) - -(define (set-output-buffer-line-ending! ob name) - (set-output-buffer-denormalize! ob (name->denormalizer name))) - -(define (write-substring ob string start end) - (cond ((string? string) - (let loop ((i start)) - (if (fix:< i end) - (if (write-next-char ob (string-ref string i)) - (loop (fix:+ i 1)) - (let ((n (drain-output-buffer ob))) - (cond ((not n) (and (fix:> i start) (fix:- i start))) - ((fix:> n 0) (loop i)) - (else (fix:- i start))))) - (fix:- end start)))) - ((wide-string? string) - (let ((v (wide-string-contents string))) - (let loop ((i start)) - (if (fix:< i end) - (if (write-next-char ob (vector-ref v i)) - (loop (fix:+ i 1)) - (let ((n (drain-output-buffer ob))) - (cond ((not n) (and (fix:> i start) (fix:- i start))) - ((fix:> n 0) (loop i)) - (else (fix:- i start))))) - (fix:- end start))))) - (else - (error:not-string string 'OUTPUT-PORT/WRITE-SUBSTRING)))) + (let ((n ((output-buffer-encoder ob) ob char))) + (let ((m + (write-bytevector (output-buffer-bytes ob) + (output-buffer-binary-port ob) + 0 + n))) + (if (and m (fix:> m 0)) + (begin + (if (fix:< m n) + (error:char-encoding ob char)) + (set-output-buffer-total! ob (fix:+ (output-buffer-total ob) n)) + 1) + m)))) ;;;; 8-bit codecs (define-decoder 'ISO-8859-1 (lambda (ib) - (let ((cp (vector-8b-ref (input-buffer-bytes ib) (input-buffer-start ib)))) - (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1)) - cp))) + (let ((sv (read-byte ib))) + (if (fix:fixnum? sv) + (integer->char sv) + sv)))) (define-encoder 'ISO-8859-1 - (lambda (ob cp) - (if (not (fix:< cp #x100)) - (error:char-encoding ob cp)) - (vector-8b-set! (output-buffer-bytes ob) (output-buffer-start ob) cp) - 1)) - -(define-sizer 'ISO-8859-1 - (lambda (ib cp) - ib cp + (lambda (ob char) + (let ((cp (char->integer char))) + (if (not (fix:< cp #x100)) + (error:char-encoding ob cp)) + (bytevector-u8-set! (output-buffer-bytes ob) 0 cp)) 1)) (define-coding-aliases 'ISO-8859-1 @@ -1061,69 +795,61 @@ USA. (let ((name (cadr form)) (start (caddr form)) (code-points (cdddr form))) - `(BEGIN - (DEFINE-DECODER ',name - (LET ((TABLE - #(,@(let loop ((i 0)) - (if (fix:< i start) - (cons i (loop (fix:+ i 1))) - code-points))))) - (LAMBDA (IB) - (DECODE-8-BIT IB TABLE)))) - (DEFINE-ENCODER ',name - (RECEIVE (LHS RHS) (REVERSE-ISO-8859-MAP ,start ',code-points) - (LAMBDA (OB CP) - (ENCODE-8-BIT OB CP ,start LHS RHS)))) - (DEFINE-SIZER-ALIAS ',name 'ISO-8859-1))) + (let ((alist + (sort (filter-map (lambda (cp byte) + (and cp + (cons cp byte))) + code-points + (iota (length code-points) start)) + (lambda (a b) + (fix:< (car a) (car b)))))) + (let ((lhs (list->vector (map car alist))) + (rhs (map cdr alist))) + `(BEGIN + (DEFINE-DECODER ',name + (LET ((TABLE + #(,@(map (lambda (cp) + (and cp + (integer->char cp))) + (let loop ((i 0)) + (if (fix:< i start) + (cons i (loop (fix:+ i 1))) + code-points)))))) + (LAMBDA (IB) + (DECODE-8-BIT IB TABLE)))) + (DEFINE-ENCODER ',name + (LET ((LHS ',lhs) + (RHS (APPLY BYTEVECTOR ',rhs))) + (LAMBDA (OB CHAR) + (ENCODE-8-BIT OB CHAR ,start LHS RHS)))))))) (ill-formed-syntax form))))) (define (decode-8-bit ib table) - (let ((cp - (vector-ref table - (vector-8b-ref (input-buffer-bytes ib) - (input-buffer-start ib))))) - (if cp - (begin - (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1)) - cp) - (error:char-decoding ib)))) - -(define (encode-8-bit ob cp start map-lhs map-rhs) - (vector-8b-set! (input-buffer-bytes ob) - (input-buffer-start ob) - (if (fix:< cp start) - cp - (let loop ((low 0) (high (vector-length map-lhs))) - (if (not (fix:< low high)) - (error:char-encoding ob cp)) - (let ((i (fix:quotient (fix:+ low high) 2))) - (cond ((fix:< cp (vector-ref map-lhs i)) - (loop low i)) - ((fix:> cp (vector-ref map-lhs i)) - (loop (fix:+ i 1) high)) - (else - (vector-8b-ref map-rhs i))))))) + (let ((u8 (read-byte ib))) + (if (fix:fixnum? u8) + (let ((char (vector-ref table u8))) + (if (not char) + (error:char-decoding ib)) + char) + u8))) + +(define (encode-8-bit ob char start map-lhs map-rhs) + (bytevector-u8-set! (output-buffer-bytes ob) + 0 + (let ((cp (char->integer char))) + (if (fix:< cp start) + cp + (let loop ((low 0) (high (vector-length map-lhs))) + (if (not (fix:< low high)) + (error:char-encoding ob cp)) + (let ((i (fix:quotient (fix:+ low high) 2))) + (cond ((fix:< cp (vector-ref map-lhs i)) + (loop low i)) + ((fix:> cp (vector-ref map-lhs i)) + (loop (fix:+ i 1) high)) + (else + (bytevector-u8-ref map-rhs i)))))))) 1) - -(define (reverse-iso-8859-map start code-points) - (let ((n (length code-points))) - (let ((lhs (make-vector n)) - (rhs (make-vector-8b n))) - (do ((alist (sort (let loop ((code-points code-points) (i start)) - (if (pair? code-points) - (if (car code-points) - (cons (cons (car code-points) i) - (loop (cdr code-points) (fix:+ i 1))) - (loop (cdr code-points) (fix:+ i 1))) - '())) - (lambda (a b) - (fix:< (car a) (car b)))) - (cdr alist)) - (i 0 (fix:+ i 1))) - ((not (pair? alist))) - (vector-set! lhs i (caar alist)) - (vector-8b-set! rhs i (cdar alist))) - (values lhs rhs)))) (define-8-bit-codecs iso-8859-2 #xA1 #x0104 #x02D8 #x0141 #x00A4 #x013D #x015A #x00A7 #x00A8 @@ -1586,187 +1312,46 @@ USA. (define-decoder 'UTF-8 (lambda (ib) + (let ((n (initial-byte->utf8-char-length (peek-byte ib)))) + (read-bytes! ib 0 n) + (decode-utf8-char (input-buffer-bytes ib) 0)))) - (define-integrable (done cp bs) - (set-input-buffer-start! ib bs) - cp) - - (let ((bv (input-buffer-bytes ib)) - (bs (input-buffer-start ib))) - (let ((b0 (get-byte bv bs 0))) - (cond ((fix:< b0 #x80) - (done b0 (fix:+ bs 1))) - ((fix:< b0 #xE0) - (and (fix:<= (fix:+ bs 2) (input-buffer-end ib)) - (let ((b1 (get-byte bv bs 1))) - (if (and (fix:> b0 #xC1) - (trailing-byte? b1)) - (done (fix:or (extract b0 #x1F 6) - (extract b1 #x3F 0)) - (fix:+ bs 2)) - (error:char-decoding ib))))) - ((fix:< b0 #xF0) - (and (fix:<= (fix:+ bs 3) (input-buffer-end ib)) - (let ((b1 (get-byte bv bs 1)) - (b2 (get-byte bv bs 2))) - (if (and (or (fix:> b0 #xE0) (fix:> b1 #x9F)) - (trailing-byte? b1) - (trailing-byte? b2)) - (let ((cp - (fix:or (fix:or (extract b0 #x0F 12) - (extract b1 #x3F 6)) - (extract b2 #x3F 0)))) - (if (illegal-low? cp) - (error:char-decoding ib) - (done cp (fix:+ bs 3)))) - (error:char-decoding ib))))) - ((fix:< b0 #xF8) - (and (fix:<= (fix:+ bs 4) (input-buffer-end ib)) - (let ((b1 (get-byte bv bs 1)) - (b2 (get-byte bv bs 2)) - (b3 (get-byte bv bs 3))) - (if (and (or (fix:> b0 #xF0) (fix:> b1 #x8F)) - (trailing-byte? b1) - (trailing-byte? b2) - (trailing-byte? b3)) - (let ((cp - (fix:or (fix:or (extract b0 #x07 18) - (extract b1 #x3F 12)) - (fix:or (extract b2 #x3F 6) - (extract b3 #x3F 0))))) - (if (fix:< cp #x110000) - (done cp (fix:+ bs 4)) - (error:char-decoding ib))) - (error:char-decoding ib))))) - (else - (error:char-decoding ib))))))) - (define-encoder 'UTF-8 - (lambda (ob cp) - (let ((bv (output-buffer-bytes ob)) - (bs (output-buffer-start ob))) - - (define-integrable (initial-byte n-bits offset) - (fix:or (fix:and (fix:lsh #xFF (fix:+ n-bits 1)) #xFF) - (fix:lsh cp (fix:- 0 offset)))) - - (define-integrable (trailing-byte offset) - (fix:or #x80 (fix:and (fix:lsh cp (fix:- 0 offset)) #x3F))) - - (cond ((fix:< cp #x00000080) - (put-byte bv bs 0 cp) - 1) - ((fix:< cp #x00000800) - (put-byte bv bs 0 (initial-byte 5 6)) - (put-byte bv bs 1 (trailing-byte 0)) - 2) - ((fix:< cp #x00010000) - (put-byte bv bs 0 (initial-byte 4 12)) - (put-byte bv bs 1 (trailing-byte 6)) - (put-byte bv bs 2 (trailing-byte 0)) - 3) - ((fix:< cp #x00110000) - (put-byte bv bs 0 (initial-byte 3 18)) - (put-byte bv bs 1 (trailing-byte 12)) - (put-byte bv bs 2 (trailing-byte 6)) - (put-byte bv bs 3 (trailing-byte 0)) - 4) - (else - (error:char-encoding ob cp)))))) - -(define-sizer 'UTF-8 - (lambda (ib cp) - (cond ((fix:< cp #x00000080) 1) - ((fix:< cp #x00000800) 2) - ((fix:< cp #x00010000) 3) - ((fix:< cp #x00110000) 4) - (else (error:char-encoding ib cp))))) - -(define-integrable (get-byte bv base offset) - (vector-8b-ref bv (fix:+ base offset))) - -(define-integrable (put-byte bv base offset byte) - (vector-8b-set! bv (fix:+ base offset) byte)) - -(define-integrable (extract b m n) - (fix:lsh (fix:and b m) n)) - -(define-integrable (trailing-byte? b) - (fix:= (fix:and #xC0 b) #x80)) - -(define-integrable (illegal-low? n) - (or (fix:= (fix:and #xF800 n) #xD800) - (fix:= (fix:and #xFFFE n) #xFFFE))) - + (lambda (ob char) + (encode-utf8-char! (output-buffer-bytes ob) 0 char))) + (let ((alias (lambda () (if (host-big-endian?) 'UTF-16BE 'UTF-16LE)))) (define-decoder-alias 'UTF-16 alias) (define-encoder-alias 'UTF-16 alias)) -(define-decoder 'UTF-16BE (lambda (ib) (decode-utf-16 ib be-bytes->digit16))) -(define-decoder 'UTF-16LE (lambda (ib) (decode-utf-16 ib le-bytes->digit16))) - -(define-integrable (decode-utf-16 ib combine) - - (define-integrable (done cp bs) - (set-input-buffer-start! ib bs) - cp) - - (let ((bv (input-buffer-bytes ib)) - (bs (input-buffer-start ib))) - (and (fix:<= (fix:+ bs 2) (input-buffer-end ib)) - (let ((d0 - (combine (get-byte bv bs 0) - (get-byte bv bs 1)))) - (if (utf16-high-surrogate? d0) - (and (fix:<= (fix:+ bs 4) (input-buffer-end ib)) - (let ((d1 - (combine (get-byte bv bs 2) - (get-byte bv bs 3)))) - (if (utf16-low-surrogate? d1) - (done (combine-utf16-surrogates d0 d1) (fix:+ bs 4)) - (error:char-decoding ib)))) - (if (illegal-low? d0) - (error:char-decoding ib) - (done d0 (fix:+ bs 2)))))))) +(define-decoder 'utf-16be + (lambda (ib) + (read-bytes! ib 0 2) + (let ((n + (initial-u16->utf16-char-length + (bytevector-u16be-ref (input-buffer-bytes ib) 0)))) + (if (fix:> n 2) + (read-bytes! ib 2 n)) + (decode-utf16be-char (input-buffer-bytes ib) 0)))) + +(define-decoder 'utf-16le + (lambda (ib) + (read-bytes! ib 0 2) + (let ((n + (initial-u16->utf16-char-length + (bytevector-u16le-ref (input-buffer-bytes ib) 0)))) + (if (fix:> n 2) + (read-bytes! ib 2 n)) + (decode-utf16le-char (input-buffer-bytes ib) 0)))) (define-encoder 'UTF-16BE - (lambda (ob cp) - (encode-utf-16 ob cp high-byte low-byte))) + (lambda (ob char) + (encode-utf16be-char! (output-buffer-bytes ob) 0 char))) (define-encoder 'UTF-16LE - (lambda (ob cp) - (encode-utf-16 ob cp low-byte high-byte))) - -(define-integrable (encode-utf-16 ob cp first-byte second-byte) - (let ((bv (output-buffer-bytes ob)) - (bs (output-buffer-start ob))) - (cond ((fix:< cp #x10000) - (put-byte bv bs 0 (first-byte cp)) - (put-byte bv bs 1 (second-byte cp)) - 2) - ((fix:< cp #x110000) - (receive (h l) (split-into-utf16-surrogates cp) - (put-byte bv bs 0 (first-byte h)) - (put-byte bv bs 1 (second-byte h)) - (put-byte bv bs 2 (first-byte l)) - (put-byte bv bs 3 (second-byte l))) - 4) - (else - (error:char-encoding ob cp))))) - -(define-sizer 'UTF-16 - (lambda (ib cp) - (cond ((fix:< cp #x00010000) 2) - ((fix:< cp #x00110000) 4) - (else (error:char-encoding ib cp))))) -(define-sizer-alias 'UTF-16BE 'UTF-16) -(define-sizer-alias 'UTF-16LE 'UTF-16) - -(define-integrable (be-bytes->digit16 b0 b1) (fix:or (fix:lsh b0 8) b1)) -(define-integrable (le-bytes->digit16 b0 b1) (fix:or b0 (fix:lsh b1 8))) -(define-integrable (high-byte d) (fix:lsh d -8)) -(define-integrable (low-byte d) (fix:and d #xFF)) - + (lambda (ob char) + (encode-utf16le-char! (output-buffer-bytes ob) 0 char))) + (let ((alias (lambda () (if (host-big-endian?) @@ -1775,68 +1360,23 @@ USA. (define-decoder-alias 'UTF-32 alias) (define-encoder-alias 'UTF-32 alias)) -(define-decoder 'UTF-32BE +(define-decoder 'utf-32be (lambda (ib) - (let ((bv (input-buffer-bytes ib)) - (bs (input-buffer-start ib))) - (and (fix:<= (fix:+ bs 4) (input-buffer-end ib)) - (let ((cp - (+ (* (get-byte bv bs 0) #x1000000) - (* (get-byte bv bs 1) #x10000) - (* (get-byte bv bs 2) #x100) - (get-byte bv bs 3)))) - (if (unicode-scalar-value? cp) - (begin - (set-input-buffer-start! ib (fix:+ bs 4)) - cp) - (error:char-decoding ib))))))) - -(define-decoder 'UTF-32LE + (read-bytes! ib 0 4) + (decode-utf32be-char (input-buffer-bytes ib) 0))) + +(define-decoder 'utf-32le (lambda (ib) - (let ((bv (input-buffer-bytes ib)) - (bs (input-buffer-start ib))) - (and (fix:<= (fix:+ bs 4) (input-buffer-end ib)) - (let ((cp - (+ (* (get-byte bv bs 3) #x1000000) - (* (get-byte bv bs 2) #x10000) - (* (get-byte bv bs 1) #x100) - (get-byte bv bs 0)))) - (if (unicode-scalar-value? cp) - (begin - (set-input-buffer-start! ib (fix:+ bs 4)) - cp) - (error:char-decoding ib))))))) + (read-bytes! ib 0 4) + (decode-utf32le-char (input-buffer-bytes ib) 0))) (define-encoder 'UTF-32BE - (lambda (ob cp) - (if (fix:< cp #x110000) - (let ((bv (output-buffer-bytes ob)) - (bs (output-buffer-start ob))) - (put-byte bv bs 0 #x00) - (put-byte bv bs 1 (fix:and (fix:lsh cp -16) #xFF)) - (put-byte bv bs 2 (fix:and (fix:lsh cp -8) #xFF)) - (put-byte bv bs 3 (fix:and cp #xFF)) - 4) - (error:char-encoding ob cp)))) + (lambda (ob char) + (encode-utf32be-char! (output-buffer-bytes ob) 0 char))) (define-encoder 'UTF-32LE - (lambda (ob cp) - (if (fix:< cp #x110000) - (let ((bv (output-buffer-bytes ob)) - (bs (output-buffer-start ob))) - (put-byte bv bs 0 (fix:and cp #xFF)) - (put-byte bv bs 1 (fix:and (fix:lsh cp -8) #xFF)) - (put-byte bv bs 2 (fix:and (fix:lsh cp -16) #xFF)) - (put-byte bv bs 3 #x00) - 4) - (error:char-encoding ob cp)))) - -(define-sizer 'UTF-32 - (lambda (ib cp) - (cond ((fix:< cp #x110000) 4) - (else (error:char-encoding ib cp))))) -(define-sizer-alias 'UTF-32BE 'UTF-32) -(define-sizer-alias 'UTF-32LE 'UTF-32) + (lambda (ob char) + (encode-utf32le-char! (output-buffer-bytes ob) 0 char))) ;;;; Normalizers @@ -1861,67 +1401,69 @@ USA. (define-normalizer 'CRLF (lambda (ib) - (let* ((bs0 (input-buffer-start ib)) - (c0 (decode-char ib))) - (if (eq? c0 #\U+000D) - (let* ((bs1 (input-buffer-start ib)) - (c1 (decode-char ib))) - (case c1 - ((#\U+000A) - #\newline) - ((#f) - (set-input-buffer-start! ib bs0) - #f) - (else - (set-input-buffer-start! ib bs1) - c0))) - c0)))) + (let ((c0 (decode-char ib))) + (case c0 + ((#\U+000D) + (let ((c1 (decode-char ib))) + (case c1 + ((#\U+000A) + #\newline) + ((#f) + (unread-decoded-char ib c1) + (unread-decoded-char ib c0) + #f) + (else + (unread-decoded-char ib c1) + c0)))) + (else c0))))) (define-denormalizer 'CRLF (lambda (ob char) (if (char=? char #\newline) - (begin - (encode-char ob #\U+000D) - (encode-char ob #\U+000A)) + (let ((n1 (encode-char ob #\U+000D))) + (if (eq? n1 1) + (let ((n2 (encode-char ob #\U+000A))) + (if (not (eq? n2 1)) + (error:char-encoding ob char)) + 2) + n1)) (encode-char ob char)))) (define-normalizer 'XML-1.0 (lambda (ib) - (let* ((bs0 (input-buffer-start ib)) - (c0 (decode-char ib))) + (let ((c0 (decode-char ib))) (case c0 ((#\U+000D) - (let* ((bs1 (input-buffer-start ib)) - (c1 (decode-char ib))) + (let ((c1 (decode-char ib))) (case c1 ((#\U+000A) - #\U+000A) + #\newline) ((#f) - (set-input-buffer-start! ib bs0) + (unread-decoded-char ib c1) + (unread-decoded-char ib c0) #f) (else - (set-input-buffer-start! ib bs1) - #\U+000A)))) + (unread-decoded-char ib c1) + #\newline)))) (else c0))))) (define-normalizer 'XML-1.1 (lambda (ib) - (let* ((bs0 (input-buffer-start ib)) - (c0 (decode-char ib))) + (let ((c0 (decode-char ib))) (case c0 ((#\U+000D) - (let* ((bs1 (input-buffer-start ib)) - (c1 (decode-char ib))) + (let ((c1 (decode-char ib))) (case c1 ((#\U+000A #\U+0085) - #\U+000A) + #\newline) ((#f) - (set-input-buffer-start! ib bs0) + (unread-decoded-char ib c1) + (unread-decoded-char ib c0) #f) (else - (set-input-buffer-start! ib bs1) - #\U+000A)))) - ((#\U+0085 #\U+2028) #\U+000A) + (unread-decoded-char ib c1) + #\newline)))) + ((#\U+0085 #\U+2028) #\newline) (else c0))))) (define-normalizer-alias 'TEXT 'XML-1.0) @@ -1934,34 +1476,40 @@ USA. ;;;; Conditions +(define (error:char-decoding ib) + (%error:char-decoding (input-buffer-port ib))) + +(define (error:char-encoding ob cp) + (%error:char-encoding (output-buffer-port ob) (integer->char cp))) + (define condition-type:char-decoding-error) (define condition-type:char-encoding-error) -(define error:char-decoding) -(define error:char-encoding) - -(define (initialize-conditions!) - (set! condition-type:char-decoding-error - (make-condition-type 'CHAR-DECODING-ERROR condition-type:port-error '() - (lambda (condition port) - (write-string "The input port " port) - (write (access-condition condition 'PORT) port) - (write-string " was unable to decode a character." port) - (newline port)))) - (set! error:char-decoding - (condition-signaller condition-type:char-decoding-error - '(PORT) - standard-error-handler)) - (set! condition-type:char-encoding-error - (make-condition-type 'CHAR-ENCODING-ERROR condition-type:port-error - '(CHAR) - (lambda (condition port) - (write-string "The output port " port) - (write (access-condition condition 'PORT) port) - (write-string " was unable to encode the character " port) - (write (access-condition condition 'CHAR) port) - (newline port)))) - (set! error:char-encoding - (condition-signaller condition-type:char-encoding-error - '(PORT CHAR) - standard-error-handler)) - unspecific) \ No newline at end of file +(define %error:char-decoding) +(define %error:char-encoding) +(add-boot-init! + (lambda () + (set! condition-type:char-decoding-error + (make-condition-type 'CHAR-DECODING-ERROR condition-type:port-error '() + (lambda (condition port) + (write-string "The input port " port) + (write (access-condition condition 'PORT) port) + (write-string " was unable to decode a character." port) + (newline port)))) + (set! %error:char-decoding + (condition-signaller condition-type:char-decoding-error + '(PORT) + standard-error-handler)) + (set! condition-type:char-encoding-error + (make-condition-type 'CHAR-ENCODING-ERROR condition-type:port-error + '(CHAR) + (lambda (condition port) + (write-string "The output port " port) + (write (access-condition condition 'PORT) port) + (write-string " was unable to encode the character " port) + (write (access-condition condition 'CHAR) port) + (newline port)))) + (set! %error:char-encoding + (condition-signaller condition-type:char-encoding-error + '(PORT CHAR) + standard-error-handler)) + unspecific)) \ No newline at end of file diff --git a/src/runtime/process.scm b/src/runtime/process.scm index be5571747..b12b16456 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -87,7 +87,11 @@ USA. (let ((input-channel (subprocess-input-channel process)) (output-channel (subprocess-output-channel process))) (and (or input-channel output-channel) - (make-generic-i/o-port 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))))))) (set-subprocess-%i/o-port! process port) port))))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 4812643d5..1add920e4 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2303,23 +2303,14 @@ USA. known-output-port-coding? known-output-port-codings make-generic-i/o-port - make-non-channel-port-sink - make-non-channel-port-source primary-input-port-codings primary-output-port-codings) (export (runtime console-i/o-port) - input-buffer-contents + generic-input-port-buffer-contents make-gstate - port-input-buffer - set-input-buffer-contents!) + set-generic-input-port-buffer-contents!) (export (runtime file-i/o-port) - clear-input-buffer - input-buffer-encoded-character-size - input-buffer-free-bytes - input-buffer-using-binary-normalizer? - output-buffer-using-binary-denormalizer? - port-input-buffer - port-output-buffer) + generic-i/o-port->binary-port) (initialization (initialize-package!))) (define-package (runtime gensym) @@ -2534,9 +2525,7 @@ USA. input-source-open? input-source-port input-source? - make-binary-i/o-port - make-binary-input-port - make-binary-output-port + make-binary-port make-channel-input-source make-channel-output-sink make-non-channel-input-source @@ -2549,8 +2538,6 @@ USA. (export (runtime port) binary-input-port-channel binary-input-port-open? - binary-input-port:buffer-contents - binary-input-port:set-buffer-contents! binary-output-port-channel binary-output-port-open? binary-port-metadata @@ -2558,15 +2545,32 @@ USA. close-binary-output-port close-binary-port) (export (runtime generic-i/o-port) - close-input-source - close-output-sink + binary-input-port-at-eof? + binary-input-port-channel + binary-input-port-open? + binary-input-port-source + binary-input-port-buffer-contents + binary-output-port-buffered-byte-count + binary-output-port-channel + binary-output-port-open? + binary-output-port-sink + close-binary-input-port + close-binary-output-port + close-binary-port + flush-binary-output-port input-source-has-bytes? input-source-open? input-source-read-bytes! output-sink-open? output-sink-write-bytes + set-binary-input-port-buffer-contents! set-input-source-port! set-output-sink-port!) + (export (runtime file-i/o-port) + binary-port-length + binary-port-position + binary-port-positionable? + set-binary-port-position!) (export (runtime output-port) flush-binary-output-port)) diff --git a/src/runtime/socket.scm b/src/runtime/socket.scm index ff6d226c6..8e23dffe8 100644 --- a/src/runtime/socket.scm +++ b/src/runtime/socket.scm @@ -145,7 +145,9 @@ USA. ((ucode-primitive new-open-unix-stream-socket 2) filename p)))))) (define (make-socket-port channel) - (make-generic-i/o-port channel channel socket-port-type)) + (make-generic-i/o-port (make-channel-input-source channel) + (make-channel-output-sink channel) + socket-port-type)) (define socket-port-type) (define (initialize-package!) diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm index d73602dd3..6c1be3c1d 100644 --- a/src/runtime/stringio.scm +++ b/src/runtime/stringio.scm @@ -244,20 +244,24 @@ USA. (make-generic-i/o-port (make-octets-source octets start end) #f octets-input-type))) - (port/set-coding port 'ISO-8859-1) - (port/set-line-ending port 'NEWLINE) + (port/set-coding port 'BINARY) + (port/set-line-ending port 'BINARY) port))) (define (make-octets-source string start end) (let ((index start)) - (make-non-channel-port-source + (make-non-channel-input-source (lambda () (< index end)) - (lambda (string* start* end*) + (lambda (bv start* end*) (let ((n (min (- end index) (- end* start*)))) (let ((limit (+ index n))) - (xsubstring-move! string index limit string* start*) - (set! index limit)) + (do ((i index (+ i 1)) + (j start* (+ j 1))) + ((not (< i limit)) + (set! index i)) + (bytevector-u8-set! bv j + (char->ascii (xstring-ref string i))))) n))))) (define (make-octets-input-type) @@ -473,8 +477,8 @@ USA. port)) (define (make-byte-sink os) - (make-non-channel-port-sink - (lambda (octets start end) + (make-non-channel-output-sink + (lambda (bv start end) (let ((index (ostate-index os))) (let ((n (fix:+ index (fix:- end start)))) (let ((buffer (ostate-buffer os))) @@ -489,7 +493,11 @@ USA. (loop (fix:+ m m))))))) (substring-move! buffer 0 index new 0) new)))) - (substring-move! octets start end (ostate-buffer os) index) + (let ((buffer (ostate-buffer os))) + (do ((i start (fix:+ i 1)) + (j index (fix:+ j 1))) + ((not (fix:< i end))) + (vector-8b-set! buffer j (bytevector-u8-ref bv j)))) (set-ostate-index! os n) (fix:- end start)))))) diff --git a/src/runtime/ttyio.scm b/src/runtime/ttyio.scm index 36de538b6..0a47a04b8 100644 --- a/src/runtime/ttyio.scm +++ b/src/runtime/ttyio.scm @@ -65,23 +65,22 @@ USA. (define (save-console-input) ((ucode-primitive reload-save-string 1) - (input-buffer-contents (port-input-buffer console-input-port)))) + (generic-input-port-buffer-contents console-input-port))) (define (reset-console) (let ((input-channel (tty-input-channel)) (output-channel (tty-output-channel))) (set-textual-port-state! the-console-port (make-cstate input-channel output-channel)) - (let ((s ((ucode-primitive reload-retrieve-string 0)))) - (if s - (set-input-buffer-contents! (port-input-buffer the-console-port) - s))) + (let ((contents ((ucode-primitive reload-retrieve-string 0)))) + (if contents + (set-generic-input-port-buffer-contents! the-console-port contents))) (set-channel-port! input-channel the-console-port) (set-channel-port! output-channel the-console-port))) (define (make-cstate input-channel output-channel) - (make-gstate input-channel - output-channel + (make-gstate (make-channel-input-source input-channel) + (make-channel-output-sink output-channel) 'TEXT 'TEXT (channel-type=file? input-channel)))