6311 lines
285 KiB
Scheme
6311 lines
285 KiB
Scheme
;;; io.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; possible extensions:
|
|
;;; - mechanism for overriding default #o666 mode
|
|
;;; - user-defined handler records
|
|
;;; - say user-supplied handler procedures "should" return appropriate
|
|
;;; values (e.g., octet/eof for get on binary port), wrap procedures
|
|
;;; in return-value checkers, or allow user to choose whether
|
|
;;; procedures are wrapped in return-value checkers
|
|
|
|
;;; r6rs custom ports are fubar:
|
|
;;; - binary and textual output ports: no known problems
|
|
;;; - binary input ports: no problem except just after a
|
|
;;; lookahead-u8 returns #!eof or just after unget-u8 of #!eof,
|
|
;;; at which point port position is ill-defined.
|
|
;;; - binary input/output ports: can't work without working
|
|
;;; get-position and set-position! procedures to switch between
|
|
;;; input and output mode
|
|
;;; - textual input ports: no way to implement port-position,
|
|
;;; since get-position returns an arbitrary object, no way to adjust for
|
|
;;; amount we've buffered, and we must buffer at least one character to
|
|
;;; support lookahead-char. also same problem as custom binary input
|
|
;;; ports with #!eof.
|
|
;;; - textual input/output ports: no way to switch between input
|
|
;;; and output modes, since we cannot implement port-position.
|
|
;;;
|
|
;;; all problems derive from need to buffer at least one element to
|
|
;;; support lookahead-u8 and lookahead-char.
|
|
;;;
|
|
;;; our workarounds:
|
|
;;; - custom binary and textual output ports:
|
|
;;; - none
|
|
;;; - custom binary input ports:
|
|
;;; - treat eof as zero width
|
|
;;; - assume sequential indices from get-position to compute port-position
|
|
;;; with adjustment for buffered characters
|
|
;;; - custom textual input ports:
|
|
;;; - treat eof as zero width
|
|
;;; - port-position undefined after read
|
|
;;; - no warning for port-position if:
|
|
;;; - no reads (including lookahead and port-eof?) have been done
|
|
;;; - a set-port-position! occurred after last read
|
|
;;; - buffer-mode is none and last read operation was not a lookahead,
|
|
;;; port-eof?, or unget
|
|
;;; - custom binary or textual input/output ports:
|
|
;;; - position for write undefined after read
|
|
;;; - port-position undefined after read
|
|
;;; - no warning for write or port-position if:
|
|
;;; - no reads (including lookahead and port-eof?) have been done
|
|
;;; - a write or set-port-position occurred after last read
|
|
;;; - buffer-mode is none and last read operation was not a lookahead,
|
|
;;; port-eof?, or unget (efficient input can be had with buffer-mode
|
|
;;; none if only get-bytevector operations are used. sequence of
|
|
;;; gets will relatively slow with buffer-mode none.)
|
|
;;; - exception: we use supplied get-position and
|
|
;;; set-position! on a custom binary input/output port to sync
|
|
;;; position and avoid issuing warnings under assumption that
|
|
;;; get-position indices are sequential
|
|
|
|
#|
|
|
implementation notes:
|
|
- for binary input/output file ports, we can always distinguish input
|
|
mode from output mode by the fact that output-size is zero iff port is
|
|
in input mode. this does not work for textual ports, because
|
|
output-size can be zero even in output mode for line-buffered ports.
|
|
so we instead use an input-mode flag in the port header.
|
|
|#
|
|
|
|
(begin
|
|
(set-who! file-buffer-size
|
|
($make-thread-parameter $c-bufsiz
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fx> x 0))
|
|
($oops who "~s is not a positive fixnum" x))
|
|
x)))
|
|
|
|
(set-who! custom-port-buffer-size
|
|
($make-thread-parameter 128
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fx> x 0))
|
|
($oops who "~s is not a positive fixnum" x))
|
|
x)))
|
|
|
|
(let ()
|
|
; choose whether to issue warnings when custom-port implementation
|
|
; cannot determine position for port-position or write operation
|
|
#;(define position-warning warning)
|
|
(define (position-warning who msg . args) (void))
|
|
|
|
(include "io-types.ss")
|
|
|
|
(define-syntax call-port-handler
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ msg who ?p arg ...)
|
|
(identifier? #'msg)
|
|
(with-syntax ([port-handler-msg (construct-name #'msg "port-handler-" #'msg)])
|
|
#'(let ([p ?p]) ((port-handler-msg ($port-handler p)) who p arg ...)))])))
|
|
|
|
(define-port-handler (codec make-codec codec?) #f
|
|
(name -> string)
|
|
(make-info who tx bp bv -> codec-info))
|
|
|
|
; ioffsets is an fxvector mapping character positions in a port's input buffer
|
|
; to byte offsets from the starting byte position for the buffer. ibytes
|
|
; is the byte offset of the character just beyond the end of the buffer,
|
|
; which is also the length in bytes of the data represented by the characters
|
|
; in the buffer. ioffsets and ibytes together allow port positions to be
|
|
; reported in bytes. ioffsets and ibytes are not consulted when a port's
|
|
; input buffer is empty, so there is no harm in modifying them when reading
|
|
; into a different string. since ioffsets might not have as many elements
|
|
; as the different string, however, a codec should usually avoid modifying
|
|
; ioffsets to prevent writes beyond the end of the vector. a codec's encode
|
|
; procedure is always called with start = 0 when string to fill is the port's
|
|
; input buffer, so ibytes should also start at 0.
|
|
|
|
(define-record-type codec-info
|
|
(nongenerative)
|
|
(opaque #t)
|
|
(fields
|
|
(immutable tx) ; transcoder
|
|
(mutable bp) ; binary port (clone)
|
|
(immutable bv) ; bytevector buffer (input or output, one at a time)
|
|
(mutable next) ; next pointer into buffer
|
|
(mutable iend) ; end of data (input only)
|
|
(immutable ioffsets) ; byte offset each char in port's buffer, relative to first (input only)
|
|
(mutable ibytes) ; byte offset of first char beyond port's buffer (input only)
|
|
(mutable icr) ; #\return seen when eol style is not none (input only)
|
|
(mutable bom) ; looking for byte-order-mark on input, or ready to write it on output
|
|
(mutable zbom) ; bom found or placed at position zero
|
|
(mutable big) ; big endian?
|
|
(immutable decode) ; input decoder
|
|
(immutable encode) ; output encoder
|
|
(immutable close)))
|
|
|
|
; keep make-fd in sync with types.h MAKE_FD
|
|
(define (make-fd intfd) intfd)
|
|
|
|
(define (port-oops who p msg)
|
|
($oops/c who
|
|
(make-i/o-port-error p)
|
|
"failed on ~s: ~(~a~)" p msg))
|
|
|
|
(define (read-oops who p msg)
|
|
($oops/c who
|
|
(condition (make-i/o-read-error) (make-i/o-port-error p))
|
|
"failed on ~s: ~(~a~)" p msg))
|
|
|
|
(define (write-oops who p msg)
|
|
($oops/c who
|
|
(condition (make-i/o-write-error) (make-i/o-port-error p))
|
|
"failed on ~s: ~(~a~)" p msg))
|
|
|
|
(define (position-oops who p pos msg)
|
|
($oops/c who
|
|
(condition
|
|
(make-i/o-invalid-position-error pos)
|
|
(make-i/o-port-error p))
|
|
"failed for position ~s on ~s: ~(~a~)" pos p msg))
|
|
|
|
(define (open-oops who filename file-options err.msg)
|
|
($oops/c who
|
|
(let ([err (car err.msg)])
|
|
(cond
|
|
[(eqv? err (constant OPEN-ERROR-PROTECTION))
|
|
(make-i/o-file-protection-error filename)]
|
|
[(eqv? err (constant OPEN-ERROR-EXISTS))
|
|
(make-i/o-file-already-exists-error filename)]
|
|
[(eqv? err (constant OPEN-ERROR-EXISTSNOT))
|
|
(make-i/o-file-does-not-exist-error filename)]
|
|
[else (make-i/o-filename-error filename)]))
|
|
"failed for ~a: ~(~a~)"
|
|
filename
|
|
(cdr err.msg)))
|
|
|
|
(define (unget-error who p x)
|
|
($oops who "cannot unget ~s on ~s" x p))
|
|
|
|
(define eol-char?
|
|
(lambda (c)
|
|
(memv c '(#\newline #\return #\nel #\ls))))
|
|
|
|
(define-syntax port-gz-mode
|
|
(syntax-rules ()
|
|
[(_ port) ($port-flags-set? port (constant port-flag-compressed))]))
|
|
(define-syntax port-flag-eof-set?
|
|
(syntax-rules ()
|
|
[(_ port) ($port-flags-set? port (constant port-flag-eof))]))
|
|
(define-syntax assert-not-closed
|
|
(syntax-rules ()
|
|
[(_ who port)
|
|
(when (port-closed? port)
|
|
($oops who "not permitted on closed port ~s" port))]))
|
|
|
|
(define-syntax file-options-list
|
|
(syntax-rules ()
|
|
[(_)
|
|
'(no-create no-fail no-truncate compressed replace exclusive append
|
|
perm-set-user-id perm-set-group-id perm-sticky
|
|
perm-no-user-read perm-no-user-write perm-user-execute
|
|
perm-no-group-read perm-no-group-write perm-group-execute
|
|
perm-no-other-read perm-no-other-write perm-other-execute)]))
|
|
|
|
(define-syntax eol-style-list
|
|
(syntax-rules ()
|
|
[(_) '(lf cr crlf nel crnel ls none)]))
|
|
|
|
(define-syntax error-handling-mode-list
|
|
(syntax-rules ()
|
|
[(_) '(ignore raise replace)]))
|
|
|
|
(define ($textual-port-bol? p)
|
|
(let ([index (textual-port-output-index p)])
|
|
(if (fx= index 0)
|
|
($port-flags-set? p (constant port-flag-bol))
|
|
(eol-char? (string-ref (textual-port-output-buffer p) (fx- index 1))))))
|
|
|
|
(define-record-type (transcoder $make-transcoder $transcoder?)
|
|
(nongenerative)
|
|
(opaque #t)
|
|
(sealed #t)
|
|
(fields
|
|
(immutable codec $transcoder-codec)
|
|
(immutable eol-style $transcoder-eol-style)
|
|
(immutable error-handling-mode $transcoder-error-handling-mode)))
|
|
|
|
;; minimum-file-buffer-length is not 0 because of lookahead-u8 and
|
|
;; unget-u8 and to simplify the logic for setting size and index based
|
|
;; on length. the single byte will never be used for output ports.
|
|
(define minimum-file-buffer-length 1)
|
|
(define bytevector-buffer-length 128)
|
|
(define string-buffer-length 16)
|
|
(define buffered-transcoded-port-buffer-length 1024)
|
|
(define unbuffered-transcoded-port-buffer-length 1)
|
|
(define codec-buffer-length 1024)
|
|
|
|
(define check-option ; for Chez Scheme list-based file open options
|
|
(lambda (who x y)
|
|
(when (and x (not (eq? x y)))
|
|
($oops who "incompatible options ~s and ~s" x y))))
|
|
|
|
;; Foreign calls to file system
|
|
;; use critical-section to increment/decrement disable count.
|
|
;; once we arrive in C code (e.g., bytevector-write) allow deactivation if
|
|
;; disable-count == 1. this makes our port operations multitasking
|
|
;; safe (within a single posix thread if threaded).
|
|
(define $open-input-fd
|
|
(foreign-procedure "(cs)new_open_input_fd"
|
|
(string boolean) scheme-object))
|
|
(define $open-output-fd
|
|
(foreign-procedure "(cs)new_open_output_fd"
|
|
(string int
|
|
boolean boolean boolean
|
|
boolean boolean boolean boolean)
|
|
scheme-object))
|
|
(define $open-input/output-fd
|
|
(foreign-procedure "(cs)new_open_input_output_fd"
|
|
(string int
|
|
boolean boolean boolean
|
|
boolean boolean boolean boolean)
|
|
scheme-object))
|
|
(define $close-fd
|
|
(foreign-procedure "(cs)close_fd"
|
|
(scheme-object boolean) scheme-object))
|
|
(define $bytevector-read
|
|
(foreign-procedure "(cs)bytevector_read"
|
|
(scheme-object scheme-object iptr iptr boolean) scheme-object))
|
|
(define $bytevector-read-nb
|
|
(foreign-procedure "(cs)bytevector_read_nb"
|
|
(scheme-object scheme-object iptr iptr boolean) scheme-object))
|
|
(define $bytevector-write
|
|
(foreign-procedure "(cs)bytevector_write"
|
|
(scheme-object scheme-object iptr iptr boolean) scheme-object))
|
|
(define $put-byte
|
|
(foreign-procedure "(cs)put_byte"
|
|
(scheme-object int boolean) scheme-object))
|
|
(define $set-fd-pos
|
|
(foreign-procedure "(cs)set_fd_pos"
|
|
(scheme-object scheme-object boolean) scheme-object))
|
|
(define $get-fd-pos
|
|
(foreign-procedure "(cs)get_fd_pos"
|
|
(scheme-object boolean) scheme-object))
|
|
(define $get-fd-nonblocking
|
|
(foreign-procedure "(cs)get_fd_non_blocking"
|
|
(scheme-object boolean) scheme-object))
|
|
(define $set-fd-nonblocking
|
|
(foreign-procedure "(cs)set_fd_non_blocking"
|
|
(scheme-object boolean boolean) scheme-object))
|
|
(define $get-fd-length
|
|
(foreign-procedure "(cs)get_fd_length"
|
|
(scheme-object boolean) scheme-object))
|
|
(define $set-fd-length
|
|
(foreign-procedure "(cs)set_fd_length"
|
|
(scheme-object scheme-object boolean) scheme-object))
|
|
(define $fd-regular?
|
|
(foreign-procedure "(cs)fd_regularp" (int) boolean))
|
|
(define $compress-input-fd
|
|
(foreign-procedure "(cs)compress_input_fd" (int integer-64) scheme-object))
|
|
(define $compress-output-fd
|
|
(foreign-procedure "(cs)compress_output_fd" (int) scheme-object))
|
|
(module (clear-open-files register-open-file registered-open-file? unregister-open-file)
|
|
(define open-files #f)
|
|
(define file-guardian)
|
|
(define clear-open-files
|
|
; called from single-threaded $scheme-init
|
|
(lambda ()
|
|
(set! open-files (make-weak-eq-hashtable))
|
|
(set! file-guardian (make-guardian))))
|
|
; should register only ports with known system handlers/transcoders
|
|
; we don't want to get into arbitrary user code when automatically
|
|
; closing. when files are closed, we close text ports first, then
|
|
; binary ports, so it won't generally work to register a text port that
|
|
; depends on another text port being open or a binary port that
|
|
; depends on another binary port being open.
|
|
(define register-open-file
|
|
(lambda (p)
|
|
(when open-files
|
|
(with-tc-mutex
|
|
(eq-hashtable-set! open-files p #t)
|
|
(file-guardian p)))))
|
|
(define registered-open-file?
|
|
(lambda (p)
|
|
(and open-files
|
|
(with-tc-mutex
|
|
(eq-hashtable-contains? open-files p)))))
|
|
(define unregister-open-file
|
|
(lambda (p)
|
|
(when open-files
|
|
(with-tc-mutex
|
|
(eq-hashtable-delete! open-files p)))))
|
|
(define silent-close
|
|
(lambda (pvec)
|
|
; do textual ports first, since they may encapsulate a binary port
|
|
(vector-for-each
|
|
(lambda (x)
|
|
(when (textual-port? x)
|
|
(guard (c [#t (void)]) (close-port x))))
|
|
pvec)
|
|
; now do binary ports
|
|
(vector-for-each
|
|
(lambda (x)
|
|
(when (binary-port? x)
|
|
(guard (c [#t (void)]) (close-port x))))
|
|
pvec)))
|
|
(set! $close-resurrected-files
|
|
; called from single-threaded docollect
|
|
(lambda ()
|
|
(when open-files
|
|
(silent-close
|
|
(let f ([i 0])
|
|
(let ([p (file-guardian)])
|
|
(if p
|
|
(let ([v (f (fx+ i 1))]) (vector-set! v i p) v)
|
|
(make-vector i))))))))
|
|
(set! $close-files
|
|
; called from Sscheme_deinit
|
|
(lambda ()
|
|
(with-tc-mutex
|
|
; don't attempt to close ports if other threads are still running, since the other threads might be
|
|
; using one or more of the ports up to the bitter end, and port operations are not thread-safe when
|
|
; two threads operate on the same port. in particular, trying to close a compressed port here and
|
|
; in one of the other threads concurrently can result in a double free in gzclose.
|
|
(when (and open-files (if-feature pthreads (= (length ($thread-list)) 1) #t))
|
|
(silent-close (hashtable-keys open-files)))))))
|
|
|
|
;; Helpers for binary-file-ports
|
|
(define (extract-permission-mask options)
|
|
(fxlogor
|
|
(if (enum-set-subset? (file-options perm-set-user-id) options) #o4000 0)
|
|
(if (enum-set-subset? (file-options perm-set-group-id) options) #o2000 0)
|
|
(if (enum-set-subset? (file-options perm-sticky) options) #o1000 0)
|
|
(if (enum-set-subset? (file-options perm-no-user-read) options) 0 #o400)
|
|
(if (enum-set-subset? (file-options perm-no-user-write) options) 0 #o200)
|
|
(if (enum-set-subset? (file-options perm-user-execute) options) #o100 0)
|
|
(if (enum-set-subset? (file-options perm-no-group-read) options) 0 #o40)
|
|
(if (enum-set-subset? (file-options perm-no-group-write) options) 0 #o20)
|
|
(if (enum-set-subset? (file-options perm-group-execute) options) #o10 0)
|
|
(if (enum-set-subset? (file-options perm-no-other-read) options) 0 #o4)
|
|
(if (enum-set-subset? (file-options perm-no-other-write) options) 0 #o2)
|
|
(if (enum-set-subset? (file-options perm-other-execute) options) #o1 0)))
|
|
|
|
(define-syntax do-read
|
|
(syntax-rules ()
|
|
[(_ read p_)
|
|
(let ([p p_])
|
|
(do-read read p
|
|
(binary-port-input-buffer p)
|
|
0 (bytevector-length (binary-port-input-buffer p))))]
|
|
[(_ read p_ buffer start count)
|
|
(let ([p p_])
|
|
(read ($port-info p) buffer start count (port-gz-mode p)))]))
|
|
(define-syntax bytevector-read
|
|
(syntax-rules ()
|
|
[(_ args ...) (do-read $bytevector-read args ...)]))
|
|
(define-syntax bytevector-read-nb
|
|
(syntax-rules ()
|
|
[(_ args ...) (do-read $bytevector-read-nb args ...)]))
|
|
|
|
(define bytevector-write
|
|
(lambda (who p buffer start count)
|
|
(let ([n ($bytevector-write ($port-info p) buffer start count (port-gz-mode p))])
|
|
(unless (fixnum? n) (write-oops who p n))
|
|
n)))
|
|
|
|
(define bytevector-flush
|
|
(lambda (who p buffer start count)
|
|
(let ([fd ($port-info p)] [gz (port-gz-mode p)])
|
|
(let loop ([start start] [count count])
|
|
(unless (eq? 0 count)
|
|
(let ([n ($bytevector-write fd buffer start count gz)])
|
|
(unless (fixnum? n) (write-oops who p n))
|
|
(loop (fx+ start n) (fx- count n))))))))
|
|
|
|
(define binary-file-port-flush
|
|
(lambda (who p)
|
|
(bytevector-flush who p (binary-port-output-buffer p) 0
|
|
(binary-port-output-index p))
|
|
(set-binary-port-output-index! p 0)))
|
|
|
|
(define binary-file-port-ready?
|
|
(lambda (who p)
|
|
(or (not (port-input-empty? p))
|
|
(port-flag-eof-set? p)
|
|
(let ([n (bytevector-read-nb p)])
|
|
(cond
|
|
[(fixnum? n) (set-binary-port-input-size! p n) (not (eq? n 0))]
|
|
[(eof-object? n) (set-port-eof! p #t) #t]
|
|
[(equal? n "interrupt") 'interrupt]
|
|
[else (read-oops who p n)])))))
|
|
|
|
(define binary-file-port-lookahead
|
|
(lambda (who p)
|
|
(cond
|
|
[(not (port-input-empty? p))
|
|
(bytevector-u8-ref (binary-port-input-buffer p)
|
|
(binary-port-input-index p))]
|
|
[(port-flag-eof-set? p) (eof-object)]
|
|
[else (let loop ()
|
|
(let ([n (bytevector-read p)])
|
|
(cond
|
|
[(eq? 0 n) (loop)]
|
|
[(fixnum? n)
|
|
(set-binary-port-input-size! p n)
|
|
(bytevector-u8-ref (binary-port-input-buffer p) 0)]
|
|
[(eof-object? n) (set-port-eof! p #t) n]
|
|
[(equal? n "interrupt") 'interrupt]
|
|
[else (read-oops who p n)])))])))
|
|
|
|
(define binary-file-port-unget
|
|
(lambda (who p x)
|
|
(when (port-flag-eof-set? p) (unget-error who p x))
|
|
(if (eof-object? x)
|
|
(let ()
|
|
(unless (port-input-empty? p) (unget-error who p x))
|
|
(set-port-eof! p #t))
|
|
(let ([index (binary-port-input-index p)])
|
|
(when (eq? 0 index) (unget-error who p x))
|
|
(set-binary-port-input-index! p (fx1- index))))))
|
|
|
|
(define binary-file-port-get
|
|
(lambda (who p)
|
|
(cond
|
|
[(not (port-input-empty? p))
|
|
(let ([index (binary-port-input-index p)])
|
|
(set-binary-port-input-index! p (fx1+ index))
|
|
(bytevector-u8-ref (binary-port-input-buffer p) index))]
|
|
[(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
|
|
[else (let loop ()
|
|
(let ([n (bytevector-read p)])
|
|
(cond
|
|
[(eq? 0 n) (loop)]
|
|
[(fixnum? n)
|
|
(set-binary-port-input-size! p n)
|
|
(set-binary-port-input-index! p 1)
|
|
(bytevector-u8-ref (binary-port-input-buffer p) 0)]
|
|
[(eof-object? n) n]
|
|
[(equal? n "interrupt") 'interrupt]
|
|
[else (read-oops who p n)])))])))
|
|
|
|
(define binary-file-port-get-some
|
|
(lambda (who p bv start count)
|
|
(let ([port-count (binary-port-input-count p)])
|
|
(cond
|
|
[(not (eq? 0 port-count))
|
|
(let ([count (fxmin count port-count)]
|
|
[index (binary-port-input-index p)])
|
|
(bytevector-copy! (binary-port-input-buffer p) index bv start count)
|
|
(set-binary-port-input-index! p (fx+ index count))
|
|
count)]
|
|
[(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
|
|
[(and (fx<= count max-get-copy) (fx<= count (bytevector-length (binary-port-input-buffer p))))
|
|
(let ([n (bytevector-read p)])
|
|
(cond
|
|
[(fixnum? n)
|
|
(let ([count (fxmin n count)])
|
|
(set-binary-port-input-size! p n)
|
|
(set-binary-port-input-index! p count)
|
|
(bytevector-copy! (binary-port-input-buffer p) 0 bv start count)
|
|
count)]
|
|
[(eof-object? n) n]
|
|
[(equal? n "interrupt") 'interrupt]
|
|
[else (read-oops who p n)]))]
|
|
[else (let ([n (bytevector-read p bv start count)])
|
|
(cond
|
|
[(fixnum? n) n]
|
|
[(eof-object? n) n]
|
|
[(equal? n "interrupt") 'interrupt]
|
|
[else (read-oops who p n)]))]))))
|
|
|
|
(define binary-file-port-clear-input
|
|
(lambda (who p)
|
|
(set-binary-port-input-size! p 0)))
|
|
|
|
(define binary-file-port-put
|
|
(lambda (who p x)
|
|
(let ([index (binary-port-output-index p)]
|
|
[buffer (binary-port-output-buffer p)])
|
|
(cond
|
|
[(not (port-output-full? p))
|
|
(bytevector-u8-set! buffer index x)
|
|
(set-binary-port-output-index! p (fx1+ index))]
|
|
[(fx= index 0) ; since full, => size is 0 => unbuffered
|
|
(let loop ()
|
|
(let ([n ($put-byte ($port-info p) x (port-gz-mode p))])
|
|
(unless (fixnum? n) (write-oops who p n))
|
|
(when (fx= n 0) (loop))))]
|
|
[else
|
|
(bytevector-u8-set! buffer index x)
|
|
(bytevector-flush who p buffer 0 (fx1+ index))
|
|
(set-binary-port-output-index! p 0)]))))
|
|
|
|
;; The following diagram shows the control flow of put-some.
|
|
;; It is complicated because it must handle nonblocking ports
|
|
;; while also trying to minimize the number of operating system calls and
|
|
;; being smart about when to buffer.
|
|
;;
|
|
;; Arrows marked with "@" are guarded with a try-fill that
|
|
;; will try to exit the function early by copying the new bytevector
|
|
;; into the old bytevector. Arrows marked with "@@" are the same
|
|
;; but in future versions might be willing to partially copy
|
|
;; the old buffer where as the "@" lines will only copy if
|
|
;; the entire new data fits in the old buffer.
|
|
;;
|
|
;; old is the port's buffer
|
|
;; new is the byte vector being passed in
|
|
;;
|
|
;; len(x)=0 tests whether x is empty and returns #t or #f
|
|
;; write(x) writes the old buffer to the operating system and
|
|
;; returns either ALL if all data was written or PARTIAL if
|
|
;; one part of the data was written
|
|
;; shift(old) bytevector copies to the front of old
|
|
;; the part of old that wasn't written
|
|
|
|
#|
|
|
--@-> len(old)=0 --(#f)--> write(old) --(PARTIAL)--> shift(old) --@@--> DONE
|
|
| |
|
|
| |
|
|
(#t) <---@---(ALL)---+
|
|
|
|
|
V
|
|
len(new)=0 --(#f)--> write(new) --(PARTIAL)-----------------@@--> DONE
|
|
| |
|
|
| |
|
|
(#t) (ALL)
|
|
| |
|
|
V V
|
|
DONE DONE
|
|
|#
|
|
|
|
(define binary-file-port-put-some
|
|
(lambda (who p bv start count)
|
|
;; from-start: where to fill from
|
|
;; from-count: how much to fill from (i.e. how much we want to put)
|
|
;; to-start: where to fill to
|
|
;; to-count: how much to fill to (i.e. how much room we have)
|
|
;; body: what to do if not filling
|
|
(define-syntax try-fill
|
|
(syntax-rules ()
|
|
[(_ from-start from-count to-start to-count body)
|
|
(if (and (fx<= from-count max-put-copy)
|
|
(fx<= from-count to-count))
|
|
(begin
|
|
(bytevector-copy! bv from-start
|
|
(binary-port-output-buffer p) to-start
|
|
from-count)
|
|
(set-binary-port-output-index! p (fx+ to-start from-count))
|
|
(fx+ (fx- from-start start) from-count))
|
|
body)]))
|
|
|
|
;; buffer: what to write from
|
|
;; start: where to write from
|
|
;; count: how much to write from
|
|
;; (n): var to bind to how many written
|
|
;; zero: what to do if count is zero
|
|
;; normal: what to do if all count written
|
|
;; interrupted: what to do not all count written
|
|
(define-syntax try-write
|
|
(syntax-rules ()
|
|
[(_ buffer start count (n) zero normal partial)
|
|
(if (eq? 0 count)
|
|
zero
|
|
(let ([n (bytevector-write who p buffer start count)])
|
|
(if (eq? n count)
|
|
normal
|
|
partial)))]))
|
|
|
|
;; On entry: old buffer has been completely written
|
|
;; and we need to write the new buffer
|
|
(define (write-new)
|
|
(try-write bv start count (n) 0 count
|
|
(try-fill (fx+ start n) (fx- count n) 0 (binary-port-output-size p) n)))
|
|
|
|
(let ([port-index (binary-port-output-index p)]
|
|
[port-count (binary-port-output-count p)]
|
|
[port-size (binary-port-output-size p)]
|
|
[port-buffer (binary-port-output-buffer p)])
|
|
(try-fill start count port-index port-count
|
|
(try-write port-buffer 0 port-index (n)
|
|
(write-new)
|
|
(try-fill start count 0 port-size
|
|
(begin
|
|
(set-binary-port-output-index! p 0) ;; may be reset by try-fill
|
|
(write-new)))
|
|
(let ([new-index (fx- port-index n)])
|
|
(bytevector-copy! port-buffer n port-buffer 0 new-index)
|
|
(set-binary-port-output-index! p new-index)
|
|
(try-fill start count new-index (fx- port-size new-index) 0)))))))
|
|
|
|
(define binary-file-port-clear-output
|
|
(lambda (who p)
|
|
(set-binary-port-output-index! p 0)))
|
|
|
|
(define binary-file-port-close-port
|
|
(lambda (who p)
|
|
(when (input-port? p)
|
|
(set-port-eof! p #f)
|
|
(set-binary-port-input-size! p 0))
|
|
(when (output-port? p) (set-binary-port-output-size! p 0))
|
|
(unregister-open-file p)
|
|
; mark port closed before closing fd. if an interrupt occurs, we'd prefer
|
|
; that the fd's resources never be freed than to have an open port floating
|
|
; around with fd resources that have already been freed.
|
|
(mark-port-closed! p)
|
|
(let ([msg ($close-fd ($port-info p) (port-gz-mode p))])
|
|
(unless (eq? #t msg) (port-oops who p msg)))))
|
|
|
|
(define-syntax binary-file-port-port-position
|
|
(syntax-rules ()
|
|
[(_ mode who ?p)
|
|
(member (datum mode) '(in out in/out))
|
|
(let ([p ?p])
|
|
(let ([n ($get-fd-pos ($port-info p) (port-gz-mode p))])
|
|
(unless (or (fixnum? n) (bignum? n)) (port-oops who p n))
|
|
(- (+ n (if (eq? 'mode 'in) 0 (binary-port-output-index p)))
|
|
(if (eq? 'mode 'out) 0 (binary-port-input-count p)))))]))
|
|
|
|
(define binary-file-port-set-port-position!
|
|
(lambda (who p x)
|
|
(unless (and (integer? x) (exact? x) (<= 0 x (- (expt 2 63) 1)))
|
|
($oops who "~s is not a valid position" x))
|
|
(let ([n ($set-fd-pos ($port-info p) x (port-gz-mode p))])
|
|
(unless (eq? n #t) (position-oops who p x n)))))
|
|
|
|
(define binary-file-port-port-nonblocking?
|
|
(lambda (who p)
|
|
(let ([n ($get-fd-nonblocking ($port-info p) (port-gz-mode p))])
|
|
(unless (boolean? n) (port-oops who p n))
|
|
n)))
|
|
|
|
(define binary-file-port-set-port-nonblocking!
|
|
(lambda (who p x)
|
|
(let ([n ($set-fd-nonblocking ($port-info p) x (port-gz-mode p))])
|
|
(unless (eq? n #t) (port-oops who p n)))))
|
|
|
|
(define binary-file-port-port-length
|
|
(lambda (who p)
|
|
(let ([n ($get-fd-length ($port-info p) (port-gz-mode p))])
|
|
(unless (or (fixnum? n) (bignum? n)) (port-oops who p n))
|
|
n)))
|
|
|
|
(define binary-file-port-set-port-length!
|
|
(lambda (who p x)
|
|
(unless (and (integer? x) (exact? x) (<= 0 x (- (expt 2 63) 1)))
|
|
($oops who "~s is not a valid length" x))
|
|
(let ([n ($set-fd-length ($port-info p) x (port-gz-mode p))])
|
|
(unless (eq? n #t) (port-oops who p n)))))
|
|
|
|
;; Helpers for binary-custom-ports
|
|
(define (bv-read! who p read! bv start count)
|
|
(let ([n (read! bv start count)])
|
|
(unless (and (fixnum? n) (fx<= 0 n count))
|
|
($oops who "invalid result ~s from read! on ~s" n p))
|
|
n))
|
|
|
|
(define (binary-port-read! who p read!)
|
|
(let ([bv (binary-port-input-buffer p)])
|
|
(let ([n (bv-read! who p read! bv 0 (bytevector-length bv))])
|
|
(if (eq? 0 n)
|
|
(eof-object)
|
|
(begin
|
|
(set-binary-port-input-size! p n)
|
|
(bytevector-u8-ref bv 0))))))
|
|
|
|
(define bv-write! ;; loops until count written
|
|
(lambda (who p write! bv start count)
|
|
(let loop ([start start]
|
|
[count count])
|
|
(unless (eq? 0 count)
|
|
(let ([result (write! bv start count)])
|
|
(unless (and (fixnum? result) (fx<= 0 result count))
|
|
($oops who "invalid result ~s from write! on ~s" result p))
|
|
(loop (fx+ start result) (fx- count result)))))))
|
|
|
|
(define binary-custom-port-lookahead
|
|
(lambda (who p read!)
|
|
(cond
|
|
[(not (port-input-empty? p))
|
|
(bytevector-u8-ref (binary-port-input-buffer p)
|
|
(binary-port-input-index p))]
|
|
[(port-flag-eof-set? p) (eof-object)]
|
|
[else (let ([x (binary-port-read! who p read!)])
|
|
(when (eof-object? x)
|
|
(set-port-eof! p #t))
|
|
x)])))
|
|
|
|
(define binary-custom-port-unget
|
|
(lambda (who p x)
|
|
(when (port-flag-eof-set? p) (unget-error who p x))
|
|
(if (eof-object? x)
|
|
(let ()
|
|
(unless (port-input-empty? p) (unget-error who p x))
|
|
(set-port-eof! p #t))
|
|
(let ([index (binary-port-input-index p)])
|
|
(when (eq? 0 index) (unget-error who p x))
|
|
(set-binary-port-input-index! p (fx1- index))))))
|
|
|
|
(define binary-custom-port-get
|
|
(lambda (who p read!)
|
|
(cond
|
|
[(not (port-input-empty? p))
|
|
(let ([index (binary-port-input-index p)])
|
|
(set-binary-port-input-index! p (fx1+ index))
|
|
(bytevector-u8-ref (binary-port-input-buffer p) index))]
|
|
[(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
|
|
[else (let ([x (binary-port-read! who p read!)])
|
|
(unless (eof-object? x)
|
|
(set-binary-port-input-index! p 1))
|
|
x)])))
|
|
|
|
(define binary-custom-port-get-some
|
|
(lambda (who p read! bv start count)
|
|
(let ([port-count (binary-port-input-count p)])
|
|
(cond
|
|
[(not (eq? 0 port-count))
|
|
(let ([count (fxmin count port-count)]
|
|
[index (binary-port-input-index p)])
|
|
(bytevector-copy! (binary-port-input-buffer p) index bv start count)
|
|
(set-binary-port-input-index! p (fx+ index count))
|
|
count)]
|
|
[(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
|
|
[else (let ([n (bv-read! who p read! bv start count)])
|
|
(if (eq? 0 n)
|
|
(eof-object)
|
|
n))]))))
|
|
|
|
(define binary-custom-port-clear-input
|
|
(lambda (who p)
|
|
(set-binary-port-input-size! p 0)))
|
|
|
|
(define binary-custom-port-put
|
|
(lambda (who p write! x)
|
|
(let ([buffer (binary-port-output-buffer p)]
|
|
[index (binary-port-output-index p)])
|
|
(bytevector-u8-set! buffer index x)
|
|
(let ([new-index (fx1+ index)])
|
|
(if (port-output-full? p)
|
|
(begin
|
|
(bv-write! who p write! buffer 0 new-index)
|
|
(set-binary-port-output-index! p 0))
|
|
(set-binary-port-output-index! p new-index))))))
|
|
|
|
(define binary-custom-port-put-some
|
|
(lambda (who p write! bv start count)
|
|
(if (and (fx<= count max-put-copy) (fx<= count (binary-port-output-count p)))
|
|
(begin
|
|
(let ([index (binary-port-output-index p)])
|
|
(bytevector-copy! bv start
|
|
(binary-port-output-buffer p) index
|
|
count)
|
|
(set-binary-port-output-index! p (fx+ index count))
|
|
count))
|
|
(begin
|
|
(bv-write! who p write! (binary-port-output-buffer p)
|
|
0 (binary-port-output-index p))
|
|
(bv-write! who p write! bv start count)
|
|
(set-binary-port-output-index! p 0)
|
|
count))))
|
|
|
|
(define-syntax binary-custom-port-flush
|
|
(syntax-rules ()
|
|
[(_ who p_ write!)
|
|
(let ([p p_])
|
|
(bv-write! who p write! (binary-port-output-buffer p)
|
|
0 (binary-port-output-index p))
|
|
(set-binary-port-output-index! p 0))]))
|
|
|
|
(define binary-custom-port-clear-output
|
|
(lambda (who p)
|
|
(set-binary-port-output-index! p 0)))
|
|
|
|
(define binary-custom-port-close-port
|
|
(lambda (who p close)
|
|
(when close (close))
|
|
(mark-port-closed! p)
|
|
(when (input-port? p)
|
|
(set-port-eof! p #f)
|
|
(set-binary-port-input-size! p 0))
|
|
(when (output-port? p) (set-binary-port-output-size! p 0))))
|
|
|
|
(define-syntax binary-custom-port-port-position
|
|
(syntax-rules ()
|
|
[(_ mode who ?p get-position)
|
|
(member (datum mode) '(in out in/out))
|
|
(let ([p ?p])
|
|
(let ([n (get-position)])
|
|
(unless (or (and (fixnum? n) (fx>= n 0)) (and (bignum? n) (>= n 0)))
|
|
($oops who "invalid result ~s from get-position on ~s" n p))
|
|
(- (+ n (if (eq? 'mode 'in) 0 (binary-port-output-index p)))
|
|
(if (eq? 'mode 'out) 0 (binary-port-input-count p)))))]))
|
|
|
|
;; Helpers for textual-custom-ports
|
|
(define (str-read! who p read! str start count)
|
|
(let ([n (read! str start count)])
|
|
(unless (and (fixnum? n) (fx<= 0 n count))
|
|
($oops who "invalid result ~s from read! on ~s" n p))
|
|
n))
|
|
|
|
(define (textual-port-read! who p read!)
|
|
(let ([str (textual-port-input-buffer p)])
|
|
(let ([n (str-read! who p read! str 0 (string-length str))])
|
|
(if (fx= n 0)
|
|
(eof-object)
|
|
(begin
|
|
(set-textual-port-input-size! p n)
|
|
(string-ref str 0))))))
|
|
|
|
(define str-write! ;; loops until count written
|
|
(lambda (who p write! str start count)
|
|
(let loop ([start start] [count count])
|
|
(unless (fx= count 0)
|
|
(let ([result (write! str start count)])
|
|
(unless (and (fixnum? result) (fx<= 0 result count))
|
|
($oops who "invalid result ~s from write! on ~s" result p))
|
|
(loop (fx+ start result) (fx- count result)))))))
|
|
|
|
(define textual-custom-port-lookahead
|
|
(lambda (who p read!)
|
|
(cond
|
|
[(not (port-input-empty? p))
|
|
(string-ref
|
|
(textual-port-input-buffer p)
|
|
(textual-port-input-index p))]
|
|
[(port-flag-eof-set? p) (eof-object)]
|
|
[else
|
|
(let ([x (textual-port-read! who p read!)])
|
|
(when (eof-object? x) (set-port-eof! p #t))
|
|
x)])))
|
|
|
|
(define textual-custom-port-unget
|
|
(lambda (who p x)
|
|
(when (port-flag-eof-set? p) (unget-error who p x))
|
|
(if (eof-object? x)
|
|
(let ()
|
|
(unless (port-input-empty? p) (unget-error who p x))
|
|
(set-port-eof! p #t))
|
|
(let ([index (textual-port-input-index p)])
|
|
(when (eq? 0 index) (unget-error who p x))
|
|
(set-textual-port-input-index! p (fx1- index))))))
|
|
|
|
(define textual-custom-port-get
|
|
(lambda (who p read!)
|
|
(cond
|
|
[(not (port-input-empty? p))
|
|
(let ([index (textual-port-input-index p)])
|
|
(set-textual-port-input-index! p (fx1+ index))
|
|
(string-ref (textual-port-input-buffer p) index))]
|
|
[(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
|
|
[else (let ([x (textual-port-read! who p read!)])
|
|
(unless (eof-object? x)
|
|
(set-textual-port-input-index! p 1))
|
|
x)])))
|
|
|
|
(define textual-custom-port-get-some
|
|
(lambda (who p read! str start count)
|
|
(let ([port-count (textual-port-input-count p)])
|
|
(cond
|
|
[(not (fx= port-count 0))
|
|
(let ([count (fxmin count port-count)]
|
|
[index (textual-port-input-index p)])
|
|
(string-copy! (textual-port-input-buffer p) index str start count)
|
|
(set-textual-port-input-index! p (fx+ index count))
|
|
count)]
|
|
[(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
|
|
[else (let ([n (str-read! who p read! str start count)])
|
|
(if (eq? 0 n)
|
|
(eof-object)
|
|
n))]))))
|
|
|
|
(define textual-custom-port-clear-input
|
|
(lambda (who p)
|
|
(set-textual-port-input-size! p 0)))
|
|
|
|
(define textual-custom-port-put
|
|
(lambda (who p write! x)
|
|
(let ([buffer (textual-port-output-buffer p)]
|
|
[index (textual-port-output-index p)])
|
|
(string-set! buffer index x)
|
|
(let ([new-index (fx1+ index)])
|
|
(if (port-output-full? p)
|
|
(begin
|
|
(str-write! who p write! buffer 0 new-index)
|
|
(set-port-bol! p (eol-char? (string-ref buffer index)))
|
|
(set-textual-port-output-index! p 0))
|
|
(set-textual-port-output-index! p new-index))))))
|
|
|
|
(define textual-custom-port-put-some
|
|
(lambda (who p write! str start count)
|
|
(if (and (fx<= count max-put-copy) (fx<= count (textual-port-output-count p)))
|
|
(begin
|
|
(let ([index (textual-port-output-index p)])
|
|
(string-copy! str start
|
|
(textual-port-output-buffer p) index
|
|
count)
|
|
(set-textual-port-output-index! p (fx+ index count))
|
|
count))
|
|
(begin
|
|
(str-write! who p write! (textual-port-output-buffer p)
|
|
0 (textual-port-output-index p))
|
|
(str-write! who p write! str start count)
|
|
(set-textual-port-output-index! p 0)
|
|
(set-port-bol! p (eol-char? (string-ref str (fx- (fx+ start count) 1))))
|
|
count))))
|
|
|
|
(define textual-custom-port-flush
|
|
(lambda (who p write!)
|
|
(let ([n (textual-port-output-index p)])
|
|
(unless (fx= n 0)
|
|
(let ([buffer (textual-port-output-buffer p)])
|
|
(str-write! who p write! buffer 0 n)
|
|
(set-port-bol! p (eol-char? (string-ref buffer (fx- n 1))))
|
|
(set-textual-port-output-index! p 0))))))
|
|
|
|
(define textual-custom-port-clear-output
|
|
(lambda (who p)
|
|
(set-textual-port-output-index! p 0)))
|
|
|
|
(define textual-custom-port-close-port
|
|
(lambda (who p close)
|
|
(when close (close))
|
|
(mark-port-closed! p)
|
|
(when (input-port? p)
|
|
(set-port-eof! p #f)
|
|
(set-textual-port-input-size! p 0))
|
|
(when (output-port? p) (set-textual-port-output-size! p 0))))
|
|
|
|
(define-syntax check-interrupt
|
|
(syntax-rules ()
|
|
[(_ e)
|
|
(let loop ()
|
|
(let ([x e])
|
|
(if (eq? x 'interrupt)
|
|
(begin ($event) (loop))
|
|
x)))]))
|
|
|
|
(module (open-binary-fd-input-port)
|
|
;; NOTE: port-info stores the file descriptor number or gzFile object
|
|
(define (make-binary-file-input-handler regular?)
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(check-interrupt
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-ready? who p))))]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(check-interrupt
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-lookahead who p))))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-unget who p x)))]
|
|
[get
|
|
(lambda (who p)
|
|
(check-interrupt
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-get who p))))]
|
|
[get-some
|
|
(lambda (who p bv start count)
|
|
(check-interrupt
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-get-some who p bv start count))))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-clear-input who p)))]
|
|
[put #f]
|
|
[put-some #f]
|
|
[flush #f]
|
|
[clear-output #f]
|
|
[close-port
|
|
(lambda (who p)
|
|
(critical-section
|
|
(unless (port-closed? p)
|
|
(binary-file-port-close-port who p))))]
|
|
[port-position
|
|
(and regular?
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-port-position in who p))))]
|
|
[set-port-position!
|
|
(and regular?
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-set-port-position! who p x)
|
|
(set-binary-port-input-size! p 0) ;; junk the buffer data
|
|
(set-port-eof! p #f))))]
|
|
[port-length
|
|
(and regular?
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-port-length who p))))]
|
|
[set-port-length! #f]
|
|
[port-nonblocking?
|
|
(if-feature windows #f
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-port-nonblocking? who p))))]
|
|
[set-port-nonblocking!
|
|
(if-feature windows #f
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-set-port-nonblocking! who p x))))]))
|
|
|
|
(define open-binary-fd-input-port
|
|
(lambda (who name fd regular? mode gzflag)
|
|
(let ([buffer-length (if (eq? mode (buffer-mode none))
|
|
minimum-file-buffer-length
|
|
(file-buffer-size))])
|
|
(let ([p ($make-binary-input-port
|
|
name ;; name
|
|
(make-binary-file-input-handler regular?) ;; handler
|
|
(make-bytevector buffer-length) ;; buffer
|
|
fd)]) ;; info
|
|
(if (eq? mode (buffer-mode block))
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
(when (eq? mode (buffer-mode line))
|
|
($set-port-flags! p (constant port-flag-line-buffered))))
|
|
($set-port-flags! p (constant port-flag-file))
|
|
(when gzflag
|
|
($set-port-flags! p (constant port-flag-compressed)))
|
|
;; size is set by $make-binary-input-port, but
|
|
;; we want it to trip the handler the first time so
|
|
;; re-set the size to zero
|
|
(set-binary-port-input-size! p 0)
|
|
(register-open-file p)
|
|
p)))))
|
|
|
|
(module (open-binary-fd-output-port)
|
|
;; NOTE: output-size is one less than actual buffer size so
|
|
;; we always have a place to put data before calling write
|
|
(define (make-binary-file-output-handler regular?)
|
|
(make-port-handler
|
|
[ready? #f]
|
|
[lookahead #f]
|
|
[unget #f]
|
|
[get #f]
|
|
[get-some #f]
|
|
[clear-input #f]
|
|
[put
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-put who p x)))]
|
|
[put-some
|
|
(lambda (who p bv start count)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-put-some who p bv start count)))]
|
|
[flush
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-flush who p)))]
|
|
[clear-output
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-clear-output who p)))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(critical-section
|
|
(unless (port-closed? p)
|
|
(binary-file-port-flush who p)
|
|
(binary-file-port-close-port who p))))]
|
|
[port-position
|
|
(and regular?
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-port-position out who p))))]
|
|
[set-port-position!
|
|
(and regular?
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-flush who p)
|
|
(binary-file-port-set-port-position! who p x))))]
|
|
[port-length
|
|
(and regular?
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-flush who p)
|
|
(binary-file-port-port-length who p))))]
|
|
[set-port-length!
|
|
(and regular?
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-flush who p)
|
|
(binary-file-port-set-port-length! who p x))))]
|
|
[port-nonblocking?
|
|
(if-feature windows #f
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-port-nonblocking? who p))))]
|
|
[set-port-nonblocking!
|
|
(if-feature windows #f
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-set-port-nonblocking! who p x))))]))
|
|
|
|
(define open-binary-fd-output-port
|
|
(lambda (who name fd regular? b-mode lock compressed)
|
|
(let ([buffer-length (if (eq? b-mode (buffer-mode none))
|
|
minimum-file-buffer-length
|
|
(file-buffer-size))])
|
|
(let ([p ($make-binary-output-port
|
|
name ;; name
|
|
(make-binary-file-output-handler regular?) ;; handler
|
|
(make-bytevector buffer-length) ;; buffer
|
|
fd)]) ;; info
|
|
(if (eq? b-mode (buffer-mode block))
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
(when (eq? b-mode (buffer-mode line))
|
|
($set-port-flags! p (constant port-flag-line-buffered))))
|
|
($set-port-flags! p (constant port-flag-file))
|
|
(when compressed
|
|
($set-port-flags! p (constant port-flag-compressed)))
|
|
(when lock
|
|
($set-port-flags! p (constant port-flag-exclusive)))
|
|
(set-binary-port-output-size! p (fx1- buffer-length)) ;; leave room for put to work
|
|
(register-open-file p)
|
|
p)))))
|
|
|
|
(module (open-binary-fd-input/output-port)
|
|
;; Two modes: ready-for-input and ready-for-output
|
|
;;
|
|
;; ready-for-input: output-size == 0
|
|
;; ready-for-output: output-size == length-1 and input-size == 0
|
|
;;
|
|
;; unbuffered port (ports with length 1 buffers) may be both
|
|
;; ready-for-input and ready-for-output simultaneously,
|
|
;; but it is never the case that both
|
|
;; output-size != 0 and input-size != 0
|
|
;;
|
|
;; for our purposes having the eof flag set is the same as input-size != 0
|
|
|
|
(define-syntax make-ready-for-input
|
|
(syntax-rules ()
|
|
[(_ who p_)
|
|
(let ([p p_])
|
|
(unless (eq? 0 (binary-port-output-size p))
|
|
(binary-file-port-flush who p)
|
|
;; don't set input-size; it is set only after a read
|
|
(set-binary-port-output-size! p 0)))]))
|
|
|
|
(module ((make-ready-for-output $make-ready-for-output))
|
|
(define $make-ready-for-output
|
|
(lambda (who p)
|
|
(unless (eq? (binary-port-input-size p) 0)
|
|
(unless (port-input-empty? p)
|
|
(binary-file-port-set-port-position! who p
|
|
(binary-file-port-port-position in/out who p)))
|
|
(set-binary-port-input-size! p 0))
|
|
(set-port-eof! p #f)
|
|
(set-binary-port-output-size! p
|
|
(fx1- (bytevector-length (binary-port-output-buffer p))))))
|
|
|
|
(define-syntax make-ready-for-output
|
|
(syntax-rules ()
|
|
[(_ ?who ?p)
|
|
(let ([p ?p])
|
|
(when (eq? (binary-port-output-size p) 0)
|
|
($make-ready-for-output ?who p)))])))
|
|
|
|
(define (make-binary-file-input/output-handler regular?)
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(check-interrupt
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p)
|
|
(binary-file-port-ready? who p))))]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(check-interrupt
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p)
|
|
(binary-file-port-lookahead who p))))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p)
|
|
(binary-file-port-unget who p x)))]
|
|
[get
|
|
(lambda (who p)
|
|
(check-interrupt
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p)
|
|
(binary-file-port-get who p))))]
|
|
[get-some
|
|
(lambda (who p bv start count)
|
|
(check-interrupt
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p)
|
|
(binary-file-port-get-some who p bv start count))))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-clear-input who p)))]
|
|
[put
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(make-ready-for-output who p)
|
|
(binary-file-port-put who p x)))]
|
|
[put-some
|
|
(lambda (who p bv start count)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(make-ready-for-output who p)
|
|
(binary-file-port-put-some who p bv start count)))]
|
|
[flush
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(make-ready-for-output who p)
|
|
(binary-file-port-flush who p)))]
|
|
[clear-output
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-clear-output who p)))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(critical-section
|
|
(unless (port-closed? p)
|
|
(binary-file-port-flush who p)
|
|
(binary-file-port-close-port who p))))]
|
|
[port-position
|
|
(and regular?
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-port-position in/out who p))))]
|
|
[set-port-position!
|
|
(and regular?
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-flush who p)
|
|
(binary-file-port-set-port-position! who p x)
|
|
(set-binary-port-input-size! p 0) ;; junk the buffer data
|
|
(set-port-eof! p #f))))]
|
|
[port-length
|
|
(and regular?
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-flush who p)
|
|
(binary-file-port-port-length who p))))]
|
|
[set-port-length!
|
|
(and regular?
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(cond
|
|
[(and (fx= (binary-port-input-size p) 0) (not (port-flag-eof-set? p)))
|
|
(binary-file-port-flush who p)
|
|
(binary-file-port-set-port-length! who p x)]
|
|
[else
|
|
(let ([pos (binary-file-port-port-position in/out who p)])
|
|
(set-binary-port-input-size! p 0) ;; junk the buffer data
|
|
(set-port-eof! p #f)
|
|
(binary-file-port-set-port-length! who p x)
|
|
(binary-file-port-set-port-position! who p pos))]))))]
|
|
[port-nonblocking?
|
|
(if-feature windows #f
|
|
(lambda (who p)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-port-nonblocking? who p))))]
|
|
[set-port-nonblocking!
|
|
(if-feature windows #f
|
|
(lambda (who p x)
|
|
(critical-section
|
|
(assert-not-closed who p)
|
|
(binary-file-port-set-port-nonblocking! who p x))))]))
|
|
|
|
(define open-binary-fd-input/output-port
|
|
(lambda (who name fd regular? b-mode lock compressed)
|
|
(let ([buffer-length (if (eq? b-mode (buffer-mode none))
|
|
minimum-file-buffer-length
|
|
(file-buffer-size))])
|
|
(let ([p ($make-binary-input/output-port
|
|
name ;; name
|
|
(make-binary-file-input/output-handler regular?) ;; handler
|
|
(make-bytevector buffer-length) ;; input buffer
|
|
(make-bytevector buffer-length) ;; output buffer
|
|
fd)]) ;; info
|
|
(if (eq? b-mode (buffer-mode block))
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
(when (eq? b-mode (buffer-mode line))
|
|
($set-port-flags! p (constant port-flag-line-buffered))))
|
|
($set-port-flags! p (constant port-flag-file))
|
|
(when compressed
|
|
($set-port-flags! p (constant port-flag-compressed)))
|
|
(when lock
|
|
($set-port-flags! p (constant port-flag-exclusive)))
|
|
;; size is set by $make-binary-input/output-port, but
|
|
;; we want it to trip the handler the first time so
|
|
;; re-set the size to zero
|
|
(set-binary-port-input-size! p 0)
|
|
(set-binary-port-output-size! p (fx1- buffer-length)) ;; leave room for put to work
|
|
(register-open-file p)
|
|
p)))))
|
|
|
|
;;;; Public functions
|
|
;; All section numbers are from ``R6RS -- Standard Libraries''
|
|
|
|
;;;; 8.1 Condition types (in exceptions.ss)
|
|
|
|
;;;; 8.2 Port I/O: (rnrs io ports (6))
|
|
;;;; 8.2.1 Filenames
|
|
;;;; 8.2.2 File options
|
|
;; file-options in syntax.ss
|
|
(set-who! $file-options (make-enumeration (file-options-list)))
|
|
(set-who! $make-file-options (enum-set-constructor $file-options))
|
|
|
|
;;;; 8.2.3 Buffer modes
|
|
;; buffer-mode in syntax.ss
|
|
(set-who! buffer-mode?
|
|
(lambda (mode) (and (memq mode '(none line block)) #t)))
|
|
|
|
;;;; 8.2.4 Transcoders
|
|
(let ()
|
|
(define (encode-oops who tp c)
|
|
($oops/c who
|
|
(make-i/o-encoding-error tp c)
|
|
(parameterize ([print-unicode #f])
|
|
(let* ([tx (codec-info-tx ($port-info tp))]
|
|
[name (codec-name ($transcoder-codec tx))])
|
|
(if (and (eqv? c #\newline) (not (memq ($transcoder-eol-style tx) '(none lf))))
|
|
(format "~a codec cannot encode ~s with eol-style ~s"
|
|
name c ($transcoder-eol-style tx))
|
|
(format "~a codec cannot encode ~s" name c))))))
|
|
|
|
(define (decode-oops who tp msg . args)
|
|
(apply $oops/c who
|
|
(make-i/o-decoding-error tp)
|
|
msg args))
|
|
|
|
(define (flush-buffer who bp bv i k)
|
|
(if (fx= k 0)
|
|
0
|
|
(let ([n (call-port-handler put-some who bp bv i k)])
|
|
(if (fx= n 0)
|
|
(begin
|
|
(unless (fx= i 0) (bytevector-copy! bv i bv 0 k))
|
|
k)
|
|
(flush-buffer who bp bv (fx+ i n) (fx- k n))))))
|
|
|
|
(define get-some-maybe-nb
|
|
; get some from binary port bp. if ifready? is true, don't block if port
|
|
; isn't ready, even if port has not been set nonblocking
|
|
(lambda (who bp bv start ifready?)
|
|
(let ([h ($port-handler bp)])
|
|
; port-handler-ready? may raise an exception, but that's okay because ifready?
|
|
; is true only if this is called from transcoded-port's port-handler-ready?.
|
|
(if (or (not ifready?) ((port-handler-ready? h) who bp))
|
|
((port-handler-get-some h) who bp bv start (fx- codec-buffer-length start))
|
|
0))))
|
|
|
|
(let ()
|
|
(define latin-1-decode
|
|
(let ()
|
|
(define (return ans i iend cr? bytes info)
|
|
(codec-info-next-set! info i)
|
|
(codec-info-iend-set! info iend)
|
|
(codec-info-ibytes-set! info bytes)
|
|
(codec-info-icr-set! info cr?)
|
|
ans)
|
|
(lambda (who tp str start count ifready?)
|
|
(let ([info ($port-info tp)])
|
|
(let ([bp (codec-info-bp info)]
|
|
[ioffsets (and (eq? str (textual-port-input-buffer tp)) (codec-info-ioffsets info))]
|
|
[bv (codec-info-bv info)]
|
|
[jend (fx+ start count)])
|
|
(let loop ([j start]
|
|
[i (codec-info-next info)]
|
|
[iend (codec-info-iend info)]
|
|
[cr? (codec-info-icr info)]
|
|
[bytes 0])
|
|
(cond
|
|
[(fx= j jend) (return count i iend cr? bytes info)]
|
|
[(fx= i iend)
|
|
(if (fx= j start)
|
|
(let ([n (get-some-maybe-nb who bp bv 0 ifready?)])
|
|
(cond
|
|
[(eof-object? n) (return #!eof i iend #f bytes info)]
|
|
[(fx= n 0) (return 0 i iend cr? bytes info)]
|
|
[else (loop j 0 n cr? bytes)]))
|
|
; don't try to read in this case to avoid dealing with eof
|
|
(return (fx- j start) i iend cr? bytes info))]
|
|
[else
|
|
(let ([b (bytevector-u8-ref bv i)])
|
|
(cond
|
|
[(fx= b #x0d)
|
|
(cond
|
|
[(eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
|
|
(string-set! str j #\return)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))]
|
|
[else
|
|
(string-set! str j #\newline)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 1) iend #t (fx+ bytes 1))])]
|
|
[(fx= b #x0a)
|
|
(cond
|
|
[cr? (loop j (fx+ i 1) iend #f (fx+ bytes 1))]
|
|
[else
|
|
(string-set! str j #\newline)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))])]
|
|
[(fx= b #x85) ; NEL
|
|
(cond
|
|
[cr? (loop j (fx+ i 1) iend #f (fx+ bytes 1))]
|
|
[else
|
|
(string-set! str j
|
|
(if (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
|
|
(integer->char #x85)
|
|
#\newline))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))])]
|
|
[else
|
|
(string-set! str j (integer->char b))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 1) iend #f (fx+ bytes 1))]))])))))))
|
|
|
|
(define latin-1-encode
|
|
(let ()
|
|
(define (return ans o info)
|
|
(codec-info-next-set! info o)
|
|
ans)
|
|
(lambda (who tp str start count)
|
|
(let ([info ($port-info tp)])
|
|
(let ([bp (codec-info-bp info)]
|
|
[bv (codec-info-bv info)]
|
|
[jend (fx+ start count)])
|
|
(let loop ([j start] [o (codec-info-next info)])
|
|
(cond
|
|
[(fx= j jend) (return count o info)]
|
|
[(fx= o codec-buffer-length)
|
|
(let ([o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= o codec-buffer-length)
|
|
(return (fx- j start) o info)
|
|
(loop j o)))]
|
|
[else
|
|
(let ([int (char->integer (string-ref str j))])
|
|
(cond
|
|
[(fx= int #x0a)
|
|
(let ([eol-style ($transcoder-eol-style (codec-info-tx info))])
|
|
(case eol-style
|
|
[(lf none)
|
|
(bytevector-u8-set! bv o #x0a)
|
|
(loop (fx+ j 1) (fx+ o 1))]
|
|
[(cr)
|
|
(bytevector-u8-set! bv o #x0d)
|
|
(loop (fx+ j 1) (fx+ o 1))]
|
|
[(nel)
|
|
(bytevector-u8-set! bv o #x85)
|
|
(loop (fx+ j 1) (fx+ o 1))]
|
|
[(crlf crnel)
|
|
(let f ([o o])
|
|
(if (fx< o (fx- codec-buffer-length 1))
|
|
(begin
|
|
(bytevector-u8-set! bv o #x0d)
|
|
(bytevector-u8-set! bv (fx+ o 1) (if (eq? eol-style 'crlf) #x0a #x85))
|
|
(loop (fx+ j 1) (fx+ o 2)))
|
|
(let ([new-o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= new-o o)
|
|
(return (fx- j start) o info)
|
|
(f new-o)))))]
|
|
[(ls)
|
|
(let ([error-mode ($transcoder-error-handling-mode (codec-info-tx info))])
|
|
(case error-mode
|
|
[(ignore) (loop (fx+ j 1) o)]
|
|
[(replace)
|
|
(bytevector-u8-set! bv o (char->integer #\?))
|
|
(loop (fx+ j 1) (fx+ o 1))]
|
|
[(raise) (encode-oops who tp #\newline)]
|
|
[else ($oops who "unknown error handling mode ~s" error-mode)]))]
|
|
[else ($oops who "unrecognized eol style ~s" eol-style)]))]
|
|
[(fx<= int 255)
|
|
(bytevector-u8-set! bv o int)
|
|
(loop (fx+ j 1) (fx+ o 1))]
|
|
[else
|
|
(let ([error-mode ($transcoder-error-handling-mode (codec-info-tx info))])
|
|
(case ($transcoder-error-handling-mode (codec-info-tx info))
|
|
[(ignore) (loop (fx+ j 1) o)]
|
|
[(replace)
|
|
(bytevector-u8-set! bv o (char->integer #\?))
|
|
(loop (fx+ j 1) (fx+ o 1))]
|
|
[(raise) (encode-oops who tp (string-ref str j))]
|
|
[else ($oops who "unknown error handling mode ~s" error-mode)]))]))])))))))
|
|
|
|
(set-who! latin-1-codec
|
|
(let ()
|
|
(define codec
|
|
(make-codec
|
|
[name "latin-1"]
|
|
[make-info
|
|
(lambda (who tx bp bv)
|
|
(make-codec-info tx bp bv 0 0
|
|
(and (input-port? bp) (make-fxvector (bytevector-length bv)))
|
|
0 #f #f #f #f
|
|
latin-1-decode latin-1-encode (lambda (info) #f)))]))
|
|
(lambda () codec))))
|
|
|
|
(let ()
|
|
(define utf-8-decode
|
|
(let ()
|
|
(define (err who tp info i iend bytes b . b*)
|
|
(codec-info-bom-set! info #f)
|
|
(codec-info-next-set! info i)
|
|
(codec-info-iend-set! info iend)
|
|
(codec-info-ibytes-set! info (fx+ bytes 1 (length b*)))
|
|
(codec-info-icr-set! info #f)
|
|
(decode-oops who tp "invalid utf-8 encoding #x~2,'0x~{, ~a~}" b
|
|
(map (lambda (b) (if (eof-object? b) "#!eof" (format "#x~2,'0x" b))) b*)))
|
|
(define (eof-err who tp info i iend bytes)
|
|
(unless (fx= bytes 0) (codec-info-bom-set! info #f))
|
|
(codec-info-next-set! info iend)
|
|
(codec-info-iend-set! info iend)
|
|
(codec-info-ibytes-set! info (fx+ bytes (fx- iend i)))
|
|
(codec-info-icr-set! info #f)
|
|
(decode-oops who tp "unexpected end-of-file reading multibyte utf-8 encoding"))
|
|
(define (return ans i iend cr? bytes info)
|
|
(unless (fx= bytes 0) (codec-info-bom-set! info #f))
|
|
(codec-info-next-set! info i)
|
|
(codec-info-iend-set! info iend)
|
|
(codec-info-ibytes-set! info bytes)
|
|
(codec-info-icr-set! info cr?)
|
|
ans)
|
|
(lambda (who tp str start count ifready?)
|
|
(let ([info ($port-info tp)])
|
|
(let ([bp (codec-info-bp info)]
|
|
[ioffsets (and (eq? str (textual-port-input-buffer tp)) (codec-info-ioffsets info))]
|
|
[bv (codec-info-bv info)]
|
|
[jend (fx+ start count)])
|
|
(define-syntax decode-error
|
|
(syntax-rules ()
|
|
[(_ j i iend bytes b1 b2 ...)
|
|
(case ($transcoder-error-handling-mode (codec-info-tx info))
|
|
[(ignore) j]
|
|
[(replace)
|
|
(string-set! str j #\xfffd)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(fx+ j 1)]
|
|
[else (err who tp info i iend bytes b1 b2 ...)])]))
|
|
(define-syntax decode-eof-error
|
|
(syntax-rules ()
|
|
[(_ j i iend bytes)
|
|
(case ($transcoder-error-handling-mode (codec-info-tx info))
|
|
[(ignore) (return #!eof iend iend #f (fx+ bytes (fx- iend i)) info)]
|
|
[(replace)
|
|
(string-set! str j #\xfffd)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(return (fx- (fx+ j 1) start) iend iend #f (fx+ bytes (fx- iend i)) info)]
|
|
[else (eof-err who tp info i iend bytes)])]))
|
|
(let loop ([j start]
|
|
[i (codec-info-next info)]
|
|
[iend (codec-info-iend info)]
|
|
[cr? (codec-info-icr info)]
|
|
[bytes 0])
|
|
(cond
|
|
[(fx= j jend) (pariah (return count i iend cr? bytes info))]
|
|
[(fx= i iend)
|
|
(pariah
|
|
(if (fx= j start)
|
|
(let ([n (get-some-maybe-nb who bp bv 0 ifready?)])
|
|
(cond
|
|
[(eof-object? n) (return #!eof 0 0 #f bytes info)]
|
|
[(fx= n 0) (return 0 0 0 cr? bytes info)]
|
|
[else (loop j 0 n cr? bytes)]))
|
|
; don't try to read in this case to avoid dealing with eof
|
|
(return (fx- j start) i iend cr? bytes info)))]
|
|
[else
|
|
(let ([b1 (bytevector-u8-ref bv i)])
|
|
(cond
|
|
[(fx<= b1 #x7f) ; one-byte encoding
|
|
(cond
|
|
[(fx= b1 #x0d)
|
|
(pariah
|
|
(cond
|
|
[(eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
|
|
(string-set! str j #\return)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))]
|
|
[else
|
|
(string-set! str j #\newline)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 1) iend #t (fx+ bytes 1))]))]
|
|
[(fx= b1 #x0a)
|
|
(pariah
|
|
(cond
|
|
[cr? (loop j (fx+ i 1) iend #f (fx+ bytes 1))]
|
|
[else
|
|
(string-set! str j #\newline)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))]))]
|
|
[else
|
|
(string-set! str j (integer->char b1))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 1) iend #f (fx+ bytes 1))])]
|
|
[else
|
|
(pariah
|
|
(cond
|
|
[(fx<= #xc2 b1 #xdf) ; two-byte encoding
|
|
(let f ([i i] [iend iend])
|
|
(if (fx< (fx+ i 1) iend) ; have at least two bytes?
|
|
(let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
|
|
(if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
|
|
(let ([x (fxlogor (fxsll (fxlogand b1 #b11111) 6) (fxlogand b2 #b111111))]
|
|
[i (fx+ i 2)])
|
|
(cond
|
|
[(fx= x #x85) ; NEL
|
|
(cond
|
|
[cr? (loop j i iend #f (fx+ bytes 2))]
|
|
[else
|
|
(string-set! str j
|
|
(if (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
|
|
(integer->char #x85)
|
|
#\newline))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) i iend cr? (fx+ bytes 2))])]
|
|
[else
|
|
(string-set! str j (integer->char x))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) i iend #f (fx+ bytes 2))]))
|
|
; second byte is not a continuation byte
|
|
(let ([j (decode-error j (fx+ i 1) iend bytes b1)])
|
|
(loop j (fx+ i 1) iend #f (fx+ bytes 1)))))
|
|
; have only one byte
|
|
(begin
|
|
(bytevector-u8-set! bv 0 b1)
|
|
(let ([i 0] [iend 1])
|
|
(let ([n (get-some-maybe-nb who bp bv iend ifready?)])
|
|
(cond
|
|
[(eof-object? n) (decode-eof-error j i iend bytes)]
|
|
[(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
|
|
[else (f i (fx+ iend n))]))))))]
|
|
[(fx<= #xe0 b1 #xef) ; three-byte encoding
|
|
(let f ([i i] [iend iend])
|
|
(if (fx< (fx+ i 1) iend) ; have at least two bytes?
|
|
(let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
|
|
(if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
|
|
(if (fx< (fx+ i 2) iend) ; have at least three bytes?
|
|
(let ([b3 (bytevector-u8-ref bv (fx+ i 2))])
|
|
(if (fx= (fxsrl b3 6) #b10) ; third byte a continuation byte?
|
|
(let ([x (fxlogor
|
|
(fxsll (fxlogand b1 #b1111) 12)
|
|
(fxsll (fxlogand b2 #b111111) 6)
|
|
(fxlogand b3 #b111111))]
|
|
[i (fx+ i 3)])
|
|
(cond
|
|
[(and (fx= x #xfeff) (fx= bytes 0) (codec-info-bom info))
|
|
(loop j i iend #f (fx+ bytes 3))]
|
|
[(and (fx>= x #x800) (not (fx<= #xd800 x #xdfff)))
|
|
(string-set! str j
|
|
(if (and (fx= x #x2028) ; LS
|
|
(not (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)))
|
|
#\newline
|
|
(integer->char x)))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) i iend #f (fx+ bytes 3))]
|
|
[else
|
|
(let ([j (decode-error j i iend bytes b1 b2 b3)])
|
|
(loop j i iend #f (fx+ bytes 3)))]))
|
|
; third byte is not a continuation byte
|
|
(let ([j (decode-error j (fx+ i 2) iend bytes b1 b2)])
|
|
(loop j (fx+ i 2) iend #f (fx+ bytes 2)))))
|
|
; have only two bytes
|
|
(begin
|
|
(bytevector-u8-set! bv 0 b1)
|
|
(bytevector-u8-set! bv 1 b2)
|
|
(let ([i 0] [iend 2])
|
|
(let ([n (get-some-maybe-nb who bp bv iend ifready?)])
|
|
(cond
|
|
[(eof-object? n) (decode-eof-error j i iend bytes)]
|
|
[(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
|
|
[else (f i (fx+ iend n))])))))
|
|
; second byte is not a continuation byte
|
|
(let ([j (decode-error j (fx+ i 1) iend bytes b1)])
|
|
(loop j (fx+ i 1) iend #f (fx+ bytes 1)))))
|
|
; have only one byte
|
|
(begin
|
|
(bytevector-u8-set! bv 0 b1)
|
|
(let ([i 0] [iend 1])
|
|
(let ([n (get-some-maybe-nb who bp bv iend ifready?)])
|
|
(cond
|
|
[(eof-object? n) (decode-eof-error j i iend bytes)]
|
|
[(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
|
|
[else (f i (fx+ iend n))]))))))]
|
|
[(fx<= #xf0 b1 #xf4) ; four-byte encoding
|
|
(let f ([i i] [iend iend])
|
|
(if (fx< (fx+ i 1) iend) ; have at least two bytes?
|
|
(let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
|
|
(if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
|
|
(if (fx< (fx+ i 2) iend) ; have at least three bytes?
|
|
(let ([b3 (bytevector-u8-ref bv (fx+ i 2))])
|
|
(if (fx= (fxsrl b3 6) #b10) ; third byte a continuation byte?
|
|
(if (fx< (fx+ i 3) iend) ; have at least four bytes?
|
|
(let ([b4 (bytevector-u8-ref bv (fx+ i 3))])
|
|
(if (fx= (fxsrl b4 6) #b10) ; fourth byte a continuation byte?
|
|
(let ([x (fxlogor
|
|
(fxsll (fxlogand b1 #b111) 18)
|
|
(fxsll (fxlogand b2 #b111111) 12)
|
|
(fxsll (fxlogand b3 #b111111) 6)
|
|
(fxlogand b4 #b111111))]
|
|
[i (fx+ i 4)])
|
|
(cond
|
|
[(fx<= #x10000 x #x10ffff)
|
|
(string-set! str j (integer->char x))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) i iend #f (fx+ bytes 4))]
|
|
[else
|
|
(let ([j (decode-error j i iend bytes b1 b2 b3)])
|
|
(loop j i iend #f (fx+ bytes 3)))]))
|
|
; fourth byte is not a continuation byte
|
|
(let ([j (decode-error j (fx+ i 3) iend bytes b1 b2 b3)])
|
|
(loop j (fx+ i 3) iend #f (fx+ bytes 3)))))
|
|
; have only three bytes
|
|
(begin
|
|
(bytevector-u8-set! bv 0 b1)
|
|
(bytevector-u8-set! bv 1 b2)
|
|
(bytevector-u8-set! bv 2 b3)
|
|
(let ([i 0] [iend 3])
|
|
(let ([n (get-some-maybe-nb who bp bv iend ifready?)])
|
|
(cond
|
|
[(eof-object? n) (decode-eof-error j i iend bytes)]
|
|
[(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
|
|
[else (f i (fx+ iend n))])))))
|
|
; third byte is not a continuation byte
|
|
(let ([j (decode-error j (fx+ i 2) iend bytes b1 b2)])
|
|
(loop j (fx+ i 2) iend #f (fx+ bytes 2)))))
|
|
; have only two bytes
|
|
(begin
|
|
(bytevector-u8-set! bv 0 b1)
|
|
(bytevector-u8-set! bv 1 b2)
|
|
(let ([i 0] [iend 2])
|
|
(let ([n (get-some-maybe-nb who bp bv iend ifready?)])
|
|
(cond
|
|
[(eof-object? n) (decode-eof-error j i iend bytes)]
|
|
[(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
|
|
[else (f i (fx+ iend n))])))))
|
|
; second byte is not a continuation byte
|
|
(let ([j (decode-error j (fx+ i 1) iend bytes b1)])
|
|
(loop j (fx+ i 1) iend #f (fx+ bytes 1)))))
|
|
; have only one byte
|
|
(begin
|
|
(bytevector-u8-set! bv 0 b1)
|
|
(let ([i 0] [iend 1])
|
|
(let ([n (get-some-maybe-nb who bp bv iend ifready?)])
|
|
(cond
|
|
[(eof-object? n) (decode-eof-error j i iend bytes)]
|
|
[(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
|
|
[else (f i (fx+ iend n))]))))))]
|
|
[else
|
|
(let ([j (decode-error j (fx+ i 1) iend bytes b1)])
|
|
(loop j (fx+ i 1) iend #f (fx+ bytes 1)))]))]))])))))))
|
|
|
|
(define utf-8-encode
|
|
(let ()
|
|
(define (return ans o info)
|
|
(codec-info-next-set! info o)
|
|
ans)
|
|
(define (write-two-byte bv o x)
|
|
(bytevector-u8-set! bv o (fxlogor #b11000000 (fxsrl x 6)))
|
|
(bytevector-u8-set! bv (fx+ o 1) (fxlogor #b10000000 (fxlogand x #b111111))))
|
|
(define (write-three-byte bv o x)
|
|
(bytevector-u8-set! bv o (fxlogor #b11100000 (fxsrl x 12)))
|
|
(bytevector-u8-set! bv (fx+ o 1) (fxlogor #b10000000 (fxlogand (fxsrl x 6) #b111111)))
|
|
(bytevector-u8-set! bv (fx+ o 2) (fxlogor #b10000000 (fxlogand x #b111111))))
|
|
(lambda (who tp str start count)
|
|
(let ([info ($port-info tp)])
|
|
(codec-info-bom-set! info #f)
|
|
(let ([bp (codec-info-bp info)]
|
|
[bv (codec-info-bv info)]
|
|
[jend (fx+ start count)])
|
|
(let loop ([j start] [o (codec-info-next info)])
|
|
(cond
|
|
[(fx= j jend) (return count o info)]
|
|
[(fx= o codec-buffer-length)
|
|
(let ([o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= o codec-buffer-length)
|
|
(return (fx- j start) o info)
|
|
(loop j o)))]
|
|
[else
|
|
(let ([x (char->integer (string-ref str j))])
|
|
(cond
|
|
[(fx= x #x0a)
|
|
(let ([eol-style ($transcoder-eol-style (codec-info-tx info))])
|
|
(case eol-style
|
|
[(lf none)
|
|
(bytevector-u8-set! bv o #x0a)
|
|
(loop (fx+ j 1) (fx+ o 1))]
|
|
[(cr)
|
|
(bytevector-u8-set! bv o #x0d)
|
|
(loop (fx+ j 1) (fx+ o 1))]
|
|
[(crlf nel)
|
|
(let f ([o o])
|
|
(if (fx< o (fx- codec-buffer-length 1))
|
|
(begin
|
|
(case eol-style
|
|
[(crlf)
|
|
(bytevector-u8-set! bv o #x0d)
|
|
(bytevector-u8-set! bv (fx+ o 1) #x0a)]
|
|
[else (write-two-byte bv o #x85)])
|
|
(loop (fx+ j 1) (fx+ o 2)))
|
|
(let ([new-o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= new-o o)
|
|
(return (fx- j start) o info)
|
|
(f new-o)))))]
|
|
[(crnel ls)
|
|
(let f ([o o])
|
|
(if (fx< o (fx- codec-buffer-length 2))
|
|
(begin
|
|
(case eol-style
|
|
[(crnel)
|
|
(bytevector-u8-set! bv o #x0d)
|
|
(write-two-byte bv (fx+ o 1) #x85)]
|
|
[else (write-three-byte bv o #x2028)])
|
|
(loop (fx+ j 1) (fx+ o 3)))
|
|
(let ([new-o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= new-o o)
|
|
(return (fx- j start) o info)
|
|
(f new-o)))))]
|
|
[else ($oops who "unrecognized eol style ~s" eol-style)]))]
|
|
[(fx<= x #x7f) ; one-byte encoding
|
|
(bytevector-u8-set! bv o x)
|
|
(loop (fx+ j 1) (fx+ o 1))]
|
|
[(fx<= x #x7ff) ; two-byte encoding
|
|
(let f ([o o])
|
|
(if (fx< o (fx- codec-buffer-length 1))
|
|
(begin
|
|
(write-two-byte bv o x)
|
|
(loop (fx+ j 1) (fx+ o 2)))
|
|
(let ([new-o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= new-o o)
|
|
(return (fx- j start) o info)
|
|
(f new-o)))))]
|
|
[(fx<= x #xffff) ; three-byte encoding
|
|
(let f ([o o])
|
|
(if (fx< o (fx- codec-buffer-length 2))
|
|
(begin
|
|
(write-three-byte bv o x)
|
|
(loop (fx+ j 1) (fx+ o 3)))
|
|
(let ([new-o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= new-o o)
|
|
(return (fx- j start) o info)
|
|
(f new-o)))))]
|
|
[else ; four-byte encoding
|
|
(let f ([o o])
|
|
(if (fx< o (fx- codec-buffer-length 3))
|
|
(begin
|
|
(bytevector-u8-set! bv o (fxlogor #b11110000 (fxsrl x 18)))
|
|
(bytevector-u8-set! bv (fx+ o 1) (fxlogor #b10000000 (fxlogand (fxsrl x 12) #b111111)))
|
|
(bytevector-u8-set! bv (fx+ o 2) (fxlogor #b10000000 (fxlogand (fxsrl x 6) #b111111)))
|
|
(bytevector-u8-set! bv (fx+ o 3) (fxlogor #b10000000 (fxlogand x #b111111)))
|
|
(loop (fx+ j 1) (fx+ o 4)))
|
|
(let ([new-o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= new-o o)
|
|
(return (fx- j start) o info)
|
|
(f new-o)))))]))])))))))
|
|
|
|
(set-who! utf-8-codec
|
|
(let ()
|
|
(define codec
|
|
(make-codec
|
|
[name "utf-8"]
|
|
[make-info
|
|
(lambda (who tx bp bv)
|
|
(make-codec-info tx bp bv 0 0
|
|
(and (input-port? bp) (make-fxvector (bytevector-length bv)))
|
|
0 #f #t #f #f
|
|
utf-8-decode utf-8-encode (lambda (info) #f)))]))
|
|
(lambda () codec))))
|
|
|
|
(let ()
|
|
(define utf-16-decode
|
|
(let ()
|
|
(define (err who tp info i iend bytes b . b*)
|
|
(codec-info-bom-set! info #f)
|
|
(codec-info-next-set! info i)
|
|
(codec-info-iend-set! info iend)
|
|
(codec-info-ibytes-set! info (fx+ bytes 1 (length b*)))
|
|
(codec-info-icr-set! info #f)
|
|
(decode-oops who tp "invalid utf-16 encoding #x~2,'0x~{, ~a~}" b
|
|
(map (lambda (b) (if (eof-object? b) "#!eof" (format "#x~2,'0x" b))) b*)))
|
|
(define (eof-err who tp info i iend bytes)
|
|
(unless (fx= bytes 0) (codec-info-bom-set! info #f))
|
|
(codec-info-next-set! info iend)
|
|
(codec-info-iend-set! info iend)
|
|
(codec-info-ibytes-set! info (fx+ bytes (fx- iend i)))
|
|
(codec-info-icr-set! info #f)
|
|
(decode-oops who tp "unexpected end-of-file reading two-word utf-16 encoding"))
|
|
(define (return ans i iend cr? bytes info)
|
|
(unless (fx= bytes 0) (codec-info-bom-set! info #f))
|
|
(codec-info-next-set! info i)
|
|
(codec-info-iend-set! info iend)
|
|
(codec-info-ibytes-set! info bytes)
|
|
(codec-info-icr-set! info cr?)
|
|
ans)
|
|
(lambda (who tp str start count ifready?)
|
|
(let ([info ($port-info tp)])
|
|
(let ([bp (codec-info-bp info)]
|
|
[ioffsets (and (eq? str (textual-port-input-buffer tp)) (codec-info-ioffsets info))]
|
|
[bv (codec-info-bv info)]
|
|
[jend (fx+ start count)])
|
|
(define-syntax decode-error
|
|
(syntax-rules ()
|
|
[(_ j i iend bytes b1 b2 ...)
|
|
(case ($transcoder-error-handling-mode (codec-info-tx info))
|
|
[(ignore) j]
|
|
[(replace)
|
|
(string-set! str j #\xfffd)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(fx+ j 1)]
|
|
[else (err who tp info i iend bytes b1 b2 ...)])]))
|
|
(define-syntax decode-eof-error
|
|
(syntax-rules ()
|
|
[(_ j i iend bytes)
|
|
(case ($transcoder-error-handling-mode (codec-info-tx info))
|
|
[(ignore) (return #!eof iend iend #f (fx+ bytes (fx- iend i)) info)]
|
|
[(replace)
|
|
(string-set! str j #\xfffd)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(return (fx- (fx+ j 1) start) iend iend #f (fx+ bytes (fx- iend i)) info)]
|
|
[else (eof-err who tp info i iend bytes)])]))
|
|
(let loop ([j start]
|
|
[i (codec-info-next info)]
|
|
[iend (codec-info-iend info)]
|
|
[cr? (codec-info-icr info)]
|
|
[bytes 0])
|
|
(cond
|
|
[(fx= j jend) (return count i iend cr? bytes info)]
|
|
[(fx= i iend)
|
|
(if (fx= j start)
|
|
(let ([n (get-some-maybe-nb who bp bv 0 ifready?)])
|
|
(cond
|
|
[(eof-object? n) (return #!eof 0 0 #f bytes info)]
|
|
[(fx= n 0) (return 0 0 0 cr? bytes info)]
|
|
[else (loop j 0 n cr? bytes)]))
|
|
; don't try to read in this case to avoid dealing with eof
|
|
(return (fx- j start) i iend cr? bytes info))]
|
|
[(fx= i (fx- iend 1))
|
|
(bytevector-u8-set! bv 0 (bytevector-u8-ref bv i))
|
|
(let ([n (get-some-maybe-nb who bp bv 1 ifready?)])
|
|
(cond
|
|
[(eof-object? n) (decode-eof-error j 0 1 bytes)]
|
|
[(fx= n 0) (return (fx- j start) 0 1 cr? bytes info)]
|
|
[else (loop j 0 (fx+ n 1) cr? bytes)]))]
|
|
[else
|
|
(let ([b1 (bytevector-u8-ref bv i)]
|
|
[b2 (bytevector-u8-ref bv (fx+ i 1))])
|
|
(let ([w1 (if (codec-info-big info)
|
|
(fxlogor (fxsll b1 8) b2)
|
|
(fxlogor (fxsll b2 8) b1))])
|
|
(cond
|
|
[(and (fx= w1 #xfeff) (fx= i 0) (codec-info-bom info))
|
|
(when (and (port-has-port-position? bp)
|
|
(guard (c [#t #f])
|
|
(let ([n (port-position bp)])
|
|
(eq? (- n iend) 0))))
|
|
(codec-info-zbom-set! info #t))
|
|
(loop j (fx+ i 2) iend cr? (fx+ bytes 2))]
|
|
[(and (fx= w1 #xfffe) (fx= i 0) (codec-info-bom info))
|
|
(when (and (port-has-port-position? bp)
|
|
(guard (c [#t #f])
|
|
(let ([n (port-position bp)])
|
|
(eq? (- n iend) 0))))
|
|
(codec-info-zbom-set! info #t))
|
|
(codec-info-big-set! info (not (codec-info-big info)))
|
|
(loop j (fx+ i 2) iend cr? (fx+ bytes 2))]
|
|
[(fx<= #xD800 w1 #xDBFF) ; two-word encoding
|
|
(cond
|
|
[(fx<= i (fx- iend 4))
|
|
(let ([b3 (bytevector-u8-ref bv (fx+ i 2))]
|
|
[b4 (bytevector-u8-ref bv (fx+ i 3))])
|
|
(let ([w2 (if (codec-info-big info)
|
|
(fxlogor (fxsll b3 8) b4)
|
|
(fxlogor (fxsll b4 8) b3))])
|
|
(cond
|
|
[(fx<= #xDC00 w2 #xDFFF) ; valid encoding
|
|
(string-set! str j
|
|
(integer->char
|
|
(fx+ (fxlogor (fxsll (fx- w1 #xD800) 10) (fx- w2 #xDC00))
|
|
#x10000)))
|
|
(loop (fx+ j 1) (fx+ i 4) iend #f (fx+ bytes 4))]
|
|
[else
|
|
(let ([i (fx+ i 4)])
|
|
(let ([j (decode-error j i iend bytes b1 b2 b3 b4)])
|
|
(loop j i iend #f (fx+ bytes 4))))])))]
|
|
[(fx= i (fx- iend 2))
|
|
(bytevector-u8-set! bv 0 b1)
|
|
(bytevector-u8-set! bv 1 b2)
|
|
(let ([n (get-some-maybe-nb who bp bv 2 ifready?)])
|
|
(cond
|
|
[(eof-object? n) (decode-eof-error j 0 2 bytes)]
|
|
[(fx= n 0) (return (fx- j start) 0 2 cr? bytes info)]
|
|
[else (loop j 0 (fx+ n 2) cr? bytes)]))]
|
|
[else ; must have three bytes of the four we need
|
|
(bytevector-u8-set! bv 0 b1)
|
|
(bytevector-u8-set! bv 1 b2)
|
|
(bytevector-u8-set! bv 2 (bytevector-u8-ref bv (fx+ i 2)))
|
|
(let ([n (get-some-maybe-nb who bp bv 3 ifready?)])
|
|
(cond
|
|
[(eof-object? n) (decode-eof-error j 0 3 bytes)]
|
|
[(fx= n 0) (return (fx- j start) 0 3 cr? bytes info)]
|
|
[else (loop j 0 (fx+ n 3) cr? bytes)]))])]
|
|
[(fx<= #xDC00 w1 #xDFFF) ; bogus encoding
|
|
(let ([i (fx+ i 2)])
|
|
(let ([j (decode-error j i iend bytes b1 b2)])
|
|
(loop j i iend #f (fx+ bytes 2))))]
|
|
[(fx= w1 #x0d)
|
|
(cond
|
|
[(eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
|
|
(string-set! str j #\return)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 2) iend cr? (fx+ bytes 2))]
|
|
[else
|
|
(string-set! str j #\newline)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 2) iend #t (fx+ bytes 2))])]
|
|
[(fx= w1 #x0a) ; LF
|
|
(cond
|
|
[cr? (loop j (fx+ i 2) iend #f (fx+ bytes 2))]
|
|
[else
|
|
(string-set! str j #\newline)
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 2) iend cr? (fx+ bytes 2))])]
|
|
[(fx= w1 #x85) ; NEL
|
|
(cond
|
|
[cr? (loop j (fx+ i 2) iend #f (fx+ bytes 2))]
|
|
[else
|
|
(string-set! str j
|
|
(if (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
|
|
(integer->char w1)
|
|
#\newline))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 2) iend cr? (fx+ bytes 2))])]
|
|
[(fx= w1 #x2028) ; LS
|
|
(string-set! str j
|
|
(if (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
|
|
(integer->char w1)
|
|
#\newline))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 2) iend #f (fx+ bytes 2))]
|
|
[else
|
|
(string-set! str j (integer->char w1))
|
|
(when ioffsets (fxvector-set! ioffsets j bytes))
|
|
(loop (fx+ j 1) (fx+ i 2) iend #f (fx+ bytes 2))])))])))))))
|
|
|
|
(define utf-16-encode
|
|
(let ()
|
|
(define (return ans o info)
|
|
(codec-info-next-set! info o)
|
|
ans)
|
|
(lambda (who tp str start count)
|
|
(let ([info ($port-info tp)])
|
|
(let ([bp (codec-info-bp info)]
|
|
[bv (codec-info-bv info)]
|
|
[jend (fx+ start count)])
|
|
(when (codec-info-bom info)
|
|
(codec-info-bom-set! info #f)
|
|
(when (and (port-has-port-position? bp)
|
|
(guard (c [#t #f])
|
|
(eq? (port-position bp) 0)))
|
|
(codec-info-zbom-set! info #t))
|
|
(call-port-handler put-some who bp
|
|
(if (codec-info-big info) #vu8(#xfe #xff) #vu8(#xff #xfe))
|
|
0 2))
|
|
(let loop ([j start] [o (codec-info-next info)])
|
|
(cond
|
|
[(fx= j jend) (return count o info)]
|
|
[(fx>= o (fx- codec-buffer-length 1))
|
|
(let ([new-o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= new-o o)
|
|
(return (fx- j start) o info)
|
|
(loop j new-o)))]
|
|
[else
|
|
(let ([x (char->integer (string-ref str j))])
|
|
(cond
|
|
[(fx= x #x0a)
|
|
(let ([eol-style ($transcoder-eol-style (codec-info-tx info))])
|
|
(case eol-style
|
|
[(lf none)
|
|
(cond
|
|
[(codec-info-big info)
|
|
(bytevector-u8-set! bv o #x0)
|
|
(bytevector-u8-set! bv (fx+ o 1) #x0a)]
|
|
[else
|
|
(bytevector-u8-set! bv (fx+ o 1) #x0)
|
|
(bytevector-u8-set! bv o #x0a)])
|
|
(loop (fx+ j 1) (fx+ o 2))]
|
|
[(cr)
|
|
(cond
|
|
[(codec-info-big info)
|
|
(bytevector-u8-set! bv o #x0)
|
|
(bytevector-u8-set! bv (fx+ o 1) #x0d)]
|
|
[else
|
|
(bytevector-u8-set! bv (fx+ o 1) #x0)
|
|
(bytevector-u8-set! bv o #x0d)])
|
|
(loop (fx+ j 1) (fx+ o 2))]
|
|
[(nel)
|
|
(cond
|
|
[(codec-info-big info)
|
|
(bytevector-u8-set! bv o #x0)
|
|
(bytevector-u8-set! bv (fx+ o 1) #x85)]
|
|
[else
|
|
(bytevector-u8-set! bv (fx+ o 1) #x0)
|
|
(bytevector-u8-set! bv o #x85)])
|
|
(loop (fx+ j 1) (fx+ o 2))]
|
|
[(ls)
|
|
(cond
|
|
[(codec-info-big info)
|
|
(bytevector-u8-set! bv o #x20)
|
|
(bytevector-u8-set! bv (fx+ o 1) #x28)]
|
|
[else
|
|
(bytevector-u8-set! bv (fx+ o 1) #x20)
|
|
(bytevector-u8-set! bv o #x28)])
|
|
(loop (fx+ j 1) (fx+ o 2))]
|
|
[(crlf crnel)
|
|
(if (fx< o (fx- codec-buffer-length 3))
|
|
(begin
|
|
(cond
|
|
[(codec-info-big info)
|
|
(bytevector-u8-set! bv o #x0)
|
|
(bytevector-u8-set! bv (fx+ o 1) #x0d)
|
|
(bytevector-u8-set! bv (fx+ o 2) #x0)
|
|
(bytevector-u8-set! bv (fx+ o 3)
|
|
(case eol-style [(crlf) #x0a] [(crnel) #x85]))]
|
|
[else
|
|
(bytevector-u8-set! bv (fx+ o 1) #x0)
|
|
(bytevector-u8-set! bv o #x0d)
|
|
(bytevector-u8-set! bv (fx+ o 3) #x0)
|
|
(bytevector-u8-set! bv (fx+ o 2)
|
|
(case eol-style [(crlf) #x0a] [(crnel) #x85]))])
|
|
(loop (fx+ j 1) (fx+ o 4)))
|
|
(let ([new-o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= new-o o)
|
|
(return (fx- j start) o info)
|
|
(loop j new-o))))]
|
|
[else ($oops who "unrecognized eol style ~s" eol-style)]))]
|
|
[(fx<= x #xffff) ; two-byte encoding
|
|
(cond
|
|
[(codec-info-big info)
|
|
(bytevector-u8-set! bv o (fxsrl x 8))
|
|
(bytevector-u8-set! bv (fx+ o 1) (fxand x #xff))]
|
|
[else
|
|
(bytevector-u8-set! bv (fx+ o 1) (fxsrl x 8))
|
|
(bytevector-u8-set! bv o (fxand x #xff))])
|
|
(loop (fx+ j 1) (fx+ o 2))]
|
|
[else ; four-byte encoding
|
|
(if (fx< o (fx- codec-buffer-length 3))
|
|
(let ([x (fx- x #x10000)])
|
|
(let ([w1 (fxior #xd800 (fxsrl x 10))]
|
|
[w2 (fxior #xdc00 (fxand x #x3ff))])
|
|
(cond
|
|
[(codec-info-big info)
|
|
(bytevector-u8-set! bv o (fxsrl w1 8))
|
|
(bytevector-u8-set! bv (fx+ o 1) (fxand w1 #xff))
|
|
(bytevector-u8-set! bv (fx+ o 2) (fxsrl w2 8))
|
|
(bytevector-u8-set! bv (fx+ o 3) (fxand w2 #xff))]
|
|
[else
|
|
(bytevector-u8-set! bv (fx+ o 1) (fxsrl w1 8))
|
|
(bytevector-u8-set! bv o (fxand w1 #xff))
|
|
(bytevector-u8-set! bv (fx+ o 3) (fxsrl w2 8))
|
|
(bytevector-u8-set! bv (fx+ o 2) (fxand w2 #xff))])
|
|
(loop (fx+ j 1) (fx+ o 4))))
|
|
(let ([new-o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= new-o o)
|
|
(return (fx- j start) o info)
|
|
(loop j new-o))))]))])))))))
|
|
|
|
(define make-utf-16-codec
|
|
(lambda (bom big)
|
|
(make-codec
|
|
[name "utf-16"]
|
|
[make-info
|
|
(lambda (who tx bp bv)
|
|
(make-codec-info tx bp bv 0 0
|
|
(and (input-port? bp) (make-fxvector (bytevector-length bv)))
|
|
0 #f bom #f big
|
|
utf-16-decode utf-16-encode (lambda (info) #f)))])))
|
|
|
|
(let ([codec-bom-be (make-utf-16-codec #t #t)]
|
|
[codec-bom-le (make-utf-16-codec #t #f)])
|
|
(set-who! #(r6rs: utf-16-codec)
|
|
(lambda () codec-bom-be))
|
|
(set-who! utf-16-codec
|
|
(case-lambda
|
|
[() codec-bom-be]
|
|
[(eness)
|
|
(unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
|
|
(if (eq? eness 'big) codec-bom-be codec-bom-le)])))
|
|
|
|
(set-who! utf-16le-codec
|
|
(let ([codec (make-utf-16-codec #f #f)])
|
|
(lambda () codec)))
|
|
|
|
(set-who! utf-16be-codec
|
|
(let ([codec (make-utf-16-codec #f #t)])
|
|
(lambda () codec))))
|
|
|
|
(when-feature iconv
|
|
(let ()
|
|
(define-record-type iconv-info
|
|
(parent codec-info)
|
|
(nongenerative)
|
|
(opaque #t)
|
|
(fields decode-desc encode-desc))
|
|
|
|
(define $iconv-open (foreign-procedure "(cs)s_iconv_open" (string string) ptr))
|
|
(define $iconv-close (foreign-procedure "(cs)s_iconv_close" (uptr) void))
|
|
(define $iconv-from-string (foreign-procedure "(cs)s_iconv_from_string" (uptr ptr uptr uptr ptr uptr uptr) ptr))
|
|
(define $iconv-to-string (foreign-procedure "(cs)s_iconv_to_string" (uptr ptr uptr uptr ptr uptr uptr) ptr))
|
|
|
|
(define iconv-decode
|
|
(let ()
|
|
(define (err who tp info i iend bv)
|
|
(codec-info-next-set! info i)
|
|
(codec-info-iend-set! info iend)
|
|
(codec-info-icr-set! info #f)
|
|
(let ([ls (let f ([k 4] [i i])
|
|
(if (fx= k 0)
|
|
(list "etc")
|
|
(if (fx= i iend)
|
|
(list "#!eof")
|
|
(cons (format "#x~2,'0x" (bytevector-u8-ref bv i))
|
|
(f (fx- k 1) (fx+ i 1))))))])
|
|
(decode-oops who tp "decoding failed for byte sequence ~a~{, ~a~}" (car ls) (cdr ls))))
|
|
(define (return-count str start count i iend info)
|
|
(let ([eol-style ($transcoder-eol-style (codec-info-tx info))])
|
|
(if (eq? eol-style 'none)
|
|
(return count i iend info)
|
|
(let ([end (fx+ start count)])
|
|
(let loop ([jold start] [jnew start] [cr? (codec-info-icr info)])
|
|
(if (fx= jold end)
|
|
(return/cr (fx- jnew start) i iend cr? info)
|
|
(let ([c (string-ref str jold)])
|
|
(case c
|
|
[(#\nel #\newline)
|
|
(if cr?
|
|
(loop (fx+ jold 1) jnew #f)
|
|
(begin
|
|
(string-set! str jnew #\newline)
|
|
(loop (fx+ jold 1) (fx+ jnew 1) #f)))]
|
|
[(#\return)
|
|
(string-set! str jnew #\newline)
|
|
(loop (fx+ jold 1) (fx+ jnew 1) #t)]
|
|
[(#\ls)
|
|
(string-set! str jnew #\newline)
|
|
(loop (fx+ jold 1) (fx+ jnew 1) #f)]
|
|
[else
|
|
(string-set! str jnew c)
|
|
(loop (fx+ jold 1) (fx+ jnew 1) #f)]))))))))
|
|
(define (return/cr ans i iend cr? info)
|
|
(codec-info-icr-set! info cr?)
|
|
(return ans i iend info))
|
|
(define (return ans i iend info)
|
|
(codec-info-next-set! info i)
|
|
(codec-info-iend-set! info iend)
|
|
ans)
|
|
(lambda (who tp str start count ifready?)
|
|
(let ([info ($port-info tp)])
|
|
(let ([bp (codec-info-bp info)]
|
|
[bv (codec-info-bv info)]
|
|
[jend (fx+ start count)])
|
|
(let loop ([j start]
|
|
[i (codec-info-next info)]
|
|
[iend (codec-info-iend info)])
|
|
(cond
|
|
[(fx= j jend) (return-count str start count i iend info)]
|
|
[(fx= i iend)
|
|
(if (fx= j start)
|
|
(let ([n (get-some-maybe-nb who bp bv 0 ifready?)])
|
|
(cond
|
|
[(eof-object? n) (return/cr #!eof i iend #f info)]
|
|
[(fx= n 0) (return 0 i iend info)]
|
|
[else (loop j 0 n)]))
|
|
; don't try to read in this case to avoid dealing with eof
|
|
(return-count str start (fx- j start) i iend info))]
|
|
[else
|
|
(let ([newi.newj ($iconv-to-string (iconv-info-decode-desc info) bv i iend str j jend)])
|
|
(cond
|
|
[(pair? newi.newj) (loop (cdr newi.newj) (car newi.newj) iend)]
|
|
; one of the following presumably happened:
|
|
; - too few input bytes to make progress
|
|
; - invalid input sequence found
|
|
; assuming problem can't have been too little output space since
|
|
; j != jend implies enough room for at least one character
|
|
[(or (eq? newi.newj (constant SICONV-INVALID))
|
|
; assuming bv is large enough to hold any valid encoding sequence
|
|
(and (eq? newi.newj (constant SICONV-DUNNO))
|
|
(and (fx= i 0) (fx= iend (bytevector-length bv)))))
|
|
(case ($transcoder-error-handling-mode (codec-info-tx info))
|
|
[(ignore) (loop j (fx+ i 1) iend)]
|
|
[(replace)
|
|
(string-set! str j #\xfffd)
|
|
(loop (fx+ j 1) (fx+ i 1) iend)]
|
|
[else (err who tp info i iend bv)])]
|
|
[else
|
|
; try again with more bytes
|
|
(unless (fx= i 0) (bytevector-copy! bv i bv 0 (fx- iend i)))
|
|
(let ([i 0] [iend (fx- iend i)])
|
|
(let ([n (get-some-maybe-nb who bp bv iend ifready?)])
|
|
(cond
|
|
[(eof-object? n)
|
|
(set-port-eof! bp #t)
|
|
(case ($transcoder-error-handling-mode (codec-info-tx info))
|
|
[(ignore) (loop j (fx+ i 1) iend)]
|
|
[(replace)
|
|
(string-set! str j #\xfffd)
|
|
(loop (fx+ j 1) (fx+ i 1) iend)]
|
|
[else (err who tp info i iend bv)])]
|
|
[(fx= n 0) (return 0 i iend info)]
|
|
[else (loop j 0 (fx+ iend n))])))]))])))))))
|
|
|
|
(define iconv-encode
|
|
(let ()
|
|
(define (return ans o info)
|
|
(codec-info-next-set! info o)
|
|
ans)
|
|
(define (do-iconv who info str j jend bv o)
|
|
(let ([eol-style ($transcoder-eol-style (codec-info-tx info))]
|
|
[desc (iconv-info-encode-desc info)])
|
|
(cond
|
|
[(memq eol-style '(none lf))
|
|
($iconv-from-string desc str j jend bv o codec-buffer-length)]
|
|
[(eqv? (string-ref str j) #\newline)
|
|
(let ()
|
|
(define (iconv-newline s k)
|
|
(let ([newj.newo ($iconv-from-string desc s 0 k bv o codec-buffer-length)])
|
|
(if (pair? newj.newo)
|
|
(if (fx= (car newj.newo) k)
|
|
(cons (fx+ j 1) (cdr newj.newo))
|
|
(constant SICONV-NOROOM))
|
|
newj.newo)))
|
|
(case eol-style
|
|
[(cr) (iconv-newline "\r" 1)]
|
|
[(nel) (iconv-newline "\x85;" 1)]
|
|
[(ls) (iconv-newline "\x2028;" 1)]
|
|
[(crlf) (iconv-newline "\r\n" 2)]
|
|
[(crnel) (iconv-newline "\r\x85;" 2)]
|
|
[else ($oops who "unrecognized eol style ~s" eol-style)]))]
|
|
[else
|
|
(do ([k (fx+ j 1) (fx+ k 1)])
|
|
((or (fx= k jend) (eqv? (string-ref str k) #\newline))
|
|
($iconv-from-string desc str j k bv o codec-buffer-length)))])))
|
|
(lambda (who tp str start count)
|
|
(let ([info ($port-info tp)])
|
|
(let ([bp (codec-info-bp info)]
|
|
[bv (codec-info-bv info)]
|
|
[jend (fx+ start count)])
|
|
(let loop ([j start] [o (codec-info-next info)])
|
|
(cond
|
|
[(fx= j jend) (return count o info)]
|
|
[(fx= o codec-buffer-length)
|
|
(let ([o (flush-buffer who bp bv 0 o)])
|
|
(if (fx= o codec-buffer-length)
|
|
(return (fx- j start) o info)
|
|
(loop j o)))]
|
|
[else
|
|
(let ([newj.newo (do-iconv who info str j jend bv o)])
|
|
(cond
|
|
[(pair? newj.newo) (loop (car newj.newo) (cdr newj.newo))]
|
|
; one of the following presumably happened:
|
|
; - unencodeable character found
|
|
; - too little output space to make progress
|
|
[(fx= o 0) ; assuming bv is large enough to hold any valid encoding sequence
|
|
(case ($transcoder-error-handling-mode (codec-info-tx info))
|
|
[(ignore) (loop (fx+ j 1) o)]
|
|
[(replace)
|
|
; try to write the Unicode replacement character
|
|
(let ([newj.newo ($iconv-from-string (iconv-info-encode-desc info) "\xfffd;" 0 1 bv o codec-buffer-length)])
|
|
(if (pair? newj.newo)
|
|
(loop (fx+ j 1) (cdr newj.newo))
|
|
; if that failed, try to write ?
|
|
(let ([newj.newo ($iconv-from-string (iconv-info-encode-desc info) "?" 0 1 bv o codec-buffer-length)])
|
|
(if (pair? newj.newo)
|
|
(loop (fx+ j 1) (cdr newj.newo))
|
|
; if even that failed, just ignore
|
|
(loop (fx+ j 1) o)))))]
|
|
[else (encode-oops who tp (string-ref str j))])]
|
|
[else (let ([newo (flush-buffer who bp bv 0 o)])
|
|
(if (fx= newo o)
|
|
(return (fx- j start) o info)
|
|
(loop j newo)))]))])))))))
|
|
|
|
(define iconv-close
|
|
(lambda (info)
|
|
(cond [(iconv-info-decode-desc info) => $iconv-close])
|
|
(cond [(iconv-info-encode-desc info) => $iconv-close])))
|
|
|
|
(set-who! iconv-codec
|
|
(lambda (code)
|
|
(unless (string? code) ($oops who "~s is not a string" code))
|
|
(make-codec
|
|
[name (format "iconv ~a" code)]
|
|
[make-info
|
|
(lambda (who tx bp bv)
|
|
(define UTF-32B/LE
|
|
(constant-case native-endianness
|
|
[(little) "UTF-32LE"]
|
|
[(big) "UTF-32BE"]))
|
|
(define (iconv-open to from)
|
|
(let ([desc ($iconv-open to from)])
|
|
(when (string? desc) ($oops who "~a" desc))
|
|
(unless desc ($oops who "unsupported encoding ~a" code))
|
|
desc))
|
|
(let ([decode-desc (and (input-port? bp) (iconv-open UTF-32B/LE code))]
|
|
[encode-desc (and (output-port? bp) (iconv-open code UTF-32B/LE))])
|
|
(make-iconv-info tx bp bv 0 0 #f 0 #f #f #f #f
|
|
(if decode-desc
|
|
iconv-decode
|
|
(lambda args ($oops who "unexpected decode from non-input-port ~s" bp)))
|
|
(if encode-desc
|
|
iconv-encode
|
|
(lambda args ($oops who "unexpected encode to non-output-port ~s" bp)))
|
|
iconv-close decode-desc encode-desc)))]))))))
|
|
|
|
;; eol-style in syntax.ss
|
|
(set-who! $eol-style?
|
|
(lambda (style) (and (memq style (eol-style-list)) #t)))
|
|
|
|
(set-who! native-eol-style
|
|
(lambda ()
|
|
(eol-style none)))
|
|
|
|
;; &i/o-decoding in exceptions.ss
|
|
;; make-i/o-decoding-error in exceptions.ss
|
|
;; i/o-decoding-error? in exceptions.ss
|
|
;; &i/o-encoding in exceptions.ss
|
|
;; make-i/o-encoding-error in exceptions.ss
|
|
;; i/o-encoding-error? in exceptions.ss
|
|
;; i/o-encoding-error-char in exceptions.ss
|
|
|
|
;; error-handling-mode in syntax.ss
|
|
(set-who! $error-handling-mode?
|
|
(lambda (mode) (and (memq mode (error-handling-mode-list)) #t)))
|
|
|
|
(set-who! make-transcoder
|
|
(rec make-transcoder
|
|
(case-lambda
|
|
[(codec) (make-transcoder codec (native-eol-style) (error-handling-mode replace))]
|
|
[(codec eol-style) (make-transcoder codec eol-style (error-handling-mode replace))]
|
|
[(codec eol-style handling-mode)
|
|
(unless (codec? codec) ($oops who "~s is not a codec" codec))
|
|
(unless ($eol-style? eol-style) ($oops who "~s is not an eol-style" eol-style))
|
|
(unless ($error-handling-mode? handling-mode)
|
|
($oops who "~s is not an error-handling-mode" handling-mode))
|
|
($make-transcoder codec eol-style handling-mode)])))
|
|
|
|
(set-who! transcoder? (lambda (x) ($transcoder? x)))
|
|
|
|
(let ([transcoder (make-transcoder (utf-8-codec))])
|
|
(set-who! native-transcoder (lambda () transcoder))
|
|
(set-who! current-transcoder
|
|
($make-thread-parameter transcoder
|
|
(lambda (tx)
|
|
(unless ($transcoder? tx) ($oops who "~s is not a transcoder" tx))
|
|
tx))))
|
|
|
|
;; transcoder-codec, transcoder-eol-style, transcoder-error-handling-mode
|
|
(let ()
|
|
(define-syntax define-accessor
|
|
(syntax-rules ()
|
|
[(_ name $name)
|
|
(set-who! name
|
|
(lambda (transcoder)
|
|
(unless ($transcoder? transcoder)
|
|
($oops who "~s is not a transcoder" transcoder))
|
|
($name transcoder)))]))
|
|
|
|
(define-accessor transcoder-codec $transcoder-codec)
|
|
(define-accessor transcoder-eol-style $transcoder-eol-style)
|
|
(define-accessor transcoder-error-handling-mode $transcoder-error-handling-mode))
|
|
|
|
;;;; 8.2.5 End-of-file object
|
|
;; eof-object in prims.ss
|
|
;; eof-object? in prims.ss
|
|
|
|
;;;; 8.2.6 Input and output ports
|
|
;; port? in prims.ss
|
|
|
|
(set-who! port-transcoder
|
|
(lambda (port)
|
|
(unless (port? port)
|
|
($oops who "~s is not a port" port))
|
|
(let ([info ($port-info port)])
|
|
(and (codec-info? info)
|
|
(codec-info-tx info)))))
|
|
|
|
;; textual-port? in prims.ss
|
|
;; binary-port? in prims.ss
|
|
|
|
;; transcoded-port
|
|
(let ()
|
|
(module (make-transcoded-port-handler)
|
|
(define read-from-codec
|
|
(lambda (who tp str start count ifready?)
|
|
(when (eq? tp $console-input-port)
|
|
(guard (c [else (void)]) (flush-output-port $console-output-port))
|
|
(unless (eq? $console-error-port $console-output-port)
|
|
(guard (c [else (void)]) (flush-output-port $console-error-port))))
|
|
((codec-info-decode ($port-info tp)) who tp str start count ifready?)))
|
|
(define fill-from-codec
|
|
(lambda (who tp ifready?)
|
|
(let ([buf (textual-port-input-buffer tp)])
|
|
(let ([n (read-from-codec who tp buf 0 (string-length buf) ifready?)])
|
|
(if (eof-object? n)
|
|
(begin
|
|
(set-textual-port-input-size! tp 0)
|
|
(set-port-eof! tp #t))
|
|
(set-textual-port-input-size! tp n))
|
|
n))))
|
|
(define write-to-codec
|
|
(lambda (who tp str start count)
|
|
(let ([n ((codec-info-encode ($port-info tp)) who tp str start count)])
|
|
(unless (fx= n 0)
|
|
(set-port-bol! tp (eol-char? (string-ref str (fx- (fx+ start n) 1)))))
|
|
n)))
|
|
(define flush-to-codec
|
|
(case-lambda
|
|
[(who tp) (flush-to-codec who tp (textual-port-output-index tp))]
|
|
[(who tp count)
|
|
(unless (fx= count 0)
|
|
; push the chars from port's buffer into the codec's buffer
|
|
(let loop ([start 0] [count count])
|
|
(let ([n (write-to-codec who tp (textual-port-output-buffer tp) start count)])
|
|
(unless (fx= n count) (loop (fx+ start n) (fx- count n)))))
|
|
(if ($port-flags-set? tp (constant port-flag-line-buffered))
|
|
(set-textual-port-output-size! tp 0)
|
|
(set-textual-port-output-index! tp 0)))]))
|
|
(define try-flush-to-codec
|
|
(lambda (who tp)
|
|
(let ([count (textual-port-output-index tp)])
|
|
(or (fx= count 0)
|
|
(let ([buf (textual-port-output-buffer tp)])
|
|
(let loop ([start 0] [count count])
|
|
(let ([n (write-to-codec who tp buf start count)])
|
|
(cond
|
|
[(fx= n count)
|
|
(if ($port-flags-set? tp (constant port-flag-line-buffered))
|
|
(set-textual-port-output-size! tp 0)
|
|
(set-textual-port-output-index! tp 0))
|
|
#t]
|
|
[(fx= n 0)
|
|
(unless (fx= start 0)
|
|
(string-copy! buf start buf 0 count)
|
|
(when ($port-flags-set? tp (constant port-flag-line-buffered))
|
|
(set-textual-port-output-size! tp count))
|
|
(set-textual-port-output-index! tp count))
|
|
#f]
|
|
[else (loop (fx+ start n) (fx- count n))]))))))))
|
|
(define flush-from-codec
|
|
(lambda (who tp)
|
|
; push the bytes from codec's buffer into the binary port
|
|
(let ([info ($port-info tp)])
|
|
(let loop ([start 0] [count (codec-info-next info)])
|
|
(unless (fx= count 0)
|
|
(let ([n (let ([bp (codec-info-bp info)])
|
|
(call-port-handler put-some who bp (codec-info-bv info) start count))])
|
|
(loop (fx+ start n) (fx- count n)))))
|
|
(codec-info-next-set! info 0))))
|
|
(define flush-from-bp
|
|
(lambda (who tp)
|
|
(let ([bp (codec-info-bp ($port-info tp))])
|
|
(call-port-handler flush who bp))))
|
|
(module ((make-ready-for-input $make-ready-for-input))
|
|
(define $make-ready-for-input
|
|
(lambda (who tp)
|
|
(flush-to-codec who tp)
|
|
(flush-from-codec who tp)
|
|
(set-textual-port-output-size! tp 0)
|
|
(let ([info ($port-info tp)])
|
|
(codec-info-next-set! info 0)
|
|
(codec-info-iend-set! info 0)
|
|
(codec-info-icr-set! info #f))
|
|
($set-port-flags! tp (constant port-flag-input-mode))))
|
|
(define-syntax make-ready-for-input
|
|
(syntax-rules ()
|
|
[(_ who ?tp)
|
|
(let ([tp ?tp])
|
|
(unless ($port-flags-set? tp (constant port-flag-input-mode))
|
|
($make-ready-for-input who tp)))])))
|
|
(module ((make-ready-for-output $make-ready-for-output))
|
|
(define $make-ready-for-output
|
|
(lambda (who tp)
|
|
; rewind if textual port or codec has something buffered.
|
|
; if underlying binary port has something buffered, we'll let
|
|
; the first write to the binary port take care of it
|
|
(unless (and (fx= (textual-port-input-size tp) 0)
|
|
(let ([info ($port-info tp)])
|
|
(fx= (codec-info-next info) (codec-info-iend info))))
|
|
(if (port-handler-port-position ($port-handler tp))
|
|
(if (port-handler-set-port-position! ($port-handler tp))
|
|
(let ([bp (codec-info-bp ($port-info tp))])
|
|
(call-port-handler set-port-position! who bp
|
|
(call-port-handler port-position who tp)))
|
|
(position-warning who "cannot set position for write after read on ~s" tp))
|
|
(position-warning who "cannot determine position for write after read on ~s" tp)))
|
|
(set-textual-port-input-size! tp 0)
|
|
(set-port-eof! tp #f)
|
|
(codec-info-next-set! ($port-info tp) 0)
|
|
(unless ($port-flags-set? tp (constant port-flag-line-buffered))
|
|
(set-textual-port-output-size! tp (fx1- (string-length (textual-port-output-buffer tp)))))
|
|
($reset-port-flags! tp (constant port-flag-input-mode))))
|
|
(define-syntax make-ready-for-output
|
|
(syntax-rules ()
|
|
[(_ ?who ?tp)
|
|
(let ([tp ?tp])
|
|
(when ($port-flags-set? tp (constant port-flag-input-mode))
|
|
($make-ready-for-output ?who tp)))])))
|
|
(define contains-eol-char?
|
|
(lambda (s i end)
|
|
(let f ([i i])
|
|
(and (not (fx= i end))
|
|
(or (eol-char? (string-ref s i))
|
|
(f (fx+ i 1)))))))
|
|
(define transcoded-port-ready?
|
|
(lambda (who tp)
|
|
(assert-not-closed who tp)
|
|
(make-ready-for-input who tp)
|
|
(or (not (port-input-empty? tp))
|
|
(port-flag-eof-set? tp)
|
|
(not (eq? (fill-from-codec who tp #t) 0)))))
|
|
(define transcoded-port-lookahead
|
|
(lambda (who tp)
|
|
(assert-not-closed who tp)
|
|
(make-ready-for-input who tp)
|
|
(cond
|
|
[(not (port-input-empty? tp))
|
|
(string-ref (textual-port-input-buffer tp)
|
|
(textual-port-input-index tp))]
|
|
[(port-flag-eof-set? tp) (eof-object)]
|
|
[else (let loop ()
|
|
(let ([n (fill-from-codec who tp #f)])
|
|
(cond
|
|
[(eq? n 0) (loop)]
|
|
[(eof-object? n) n]
|
|
[else (string-ref (textual-port-input-buffer tp) 0)])))])))
|
|
(define transcoded-port-unget
|
|
(lambda (who tp x)
|
|
(assert-not-closed who tp)
|
|
(make-ready-for-input who tp)
|
|
(when (port-flag-eof-set? tp) (unget-error who tp x))
|
|
(if (eof-object? x)
|
|
(let ()
|
|
(unless (port-input-empty? tp) (unget-error who tp x))
|
|
(set-port-eof! tp #t))
|
|
(let ([index (textual-port-input-index tp)])
|
|
(when (fx= index 0) (unget-error who tp x))
|
|
(set-textual-port-input-index! tp (fx- index 1))))))
|
|
(define transcoded-port-get
|
|
(lambda (who tp)
|
|
(assert-not-closed who tp)
|
|
(make-ready-for-input who tp)
|
|
(cond
|
|
[(not (port-input-empty? tp))
|
|
(let ([index (textual-port-input-index tp)])
|
|
(set-textual-port-input-index! tp (fx1+ index))
|
|
(string-ref (textual-port-input-buffer tp) index))]
|
|
[(port-flag-eof-set? tp) (set-port-eof! tp #f) (eof-object)]
|
|
[else (let loop ()
|
|
(let ([n (fill-from-codec who tp #f)])
|
|
(cond
|
|
[(eq? 0 n) (loop)]
|
|
[(eof-object? n) (set-port-eof! tp #f) (eof-object)]
|
|
[else
|
|
(set-textual-port-input-index! tp 1)
|
|
(string-ref (textual-port-input-buffer tp) 0)])))])))
|
|
(define transcoded-port-get-some
|
|
(lambda (who tp str start count)
|
|
(assert-not-closed who tp)
|
|
(make-ready-for-input who tp)
|
|
(let ([port-count (textual-port-input-count tp)])
|
|
(cond
|
|
[(not (fx= port-count 0))
|
|
(let ([count (fxmin count port-count)]
|
|
[index (textual-port-input-index tp)])
|
|
(string-copy! (textual-port-input-buffer tp) index str start count)
|
|
(set-textual-port-input-index! tp (fx+ index count))
|
|
count)]
|
|
[(port-flag-eof-set? tp) (set-port-eof! tp #f) (eof-object)]
|
|
[else (read-from-codec who tp str start count #f)]))))
|
|
(define transcoded-port-clear-input
|
|
(lambda (who tp)
|
|
(assert-not-closed who tp)
|
|
(when ($port-flags-set? tp (constant port-flag-input-mode))
|
|
; position will be wrong after this. c'est la vie.
|
|
(set-textual-port-input-size! tp 0)
|
|
(set-port-eof! tp #f)
|
|
(let ([info ($port-info tp)])
|
|
(codec-info-next-set! info 0)
|
|
(codec-info-iend-set! info 0)
|
|
(codec-info-icr-set! info #f)
|
|
(let ([bp (codec-info-bp info)])
|
|
(call-port-handler clear-input who bp))))))
|
|
(define transcoded-port-put
|
|
(lambda (who tp elt)
|
|
(assert-not-closed who tp)
|
|
(make-ready-for-output who tp)
|
|
(let ([index (textual-port-output-index tp)])
|
|
(string-set! (textual-port-output-buffer tp) index elt)
|
|
(let ([index (fx+ index 1)])
|
|
(cond
|
|
[(not (port-output-full? tp))
|
|
(set-textual-port-output-index! tp index)]
|
|
[($port-flags-set? tp (constant port-flag-line-buffered))
|
|
(cond
|
|
[(eol-char? elt)
|
|
(flush-to-codec who tp index)
|
|
(flush-from-codec who tp)
|
|
(flush-from-bp who tp)]
|
|
[(fx< (textual-port-output-size tp) (fx- (string-length (textual-port-output-buffer tp)) 1))
|
|
(set-textual-port-output-size! tp index)
|
|
(set-textual-port-output-index! tp index)]
|
|
[else (flush-to-codec who tp index)])]
|
|
[else (flush-to-codec who tp index)])))))
|
|
(define transcoded-port-put-some
|
|
(lambda (who tp str start count)
|
|
(assert-not-closed who tp)
|
|
(make-ready-for-output who tp)
|
|
(cond
|
|
[($port-flags-set? tp (constant port-flag-line-buffered))
|
|
(if (contains-eol-char? str start (fx+ start count))
|
|
(begin
|
|
; line-buffering trumps nonblocking
|
|
(flush-to-codec who tp)
|
|
(let loop ([start start] [count count])
|
|
(unless (fx= count 0)
|
|
(let ([n (write-to-codec who tp str start count)])
|
|
(loop (fx+ start n) (fx- count n)))))
|
|
(flush-from-codec who tp)
|
|
(flush-from-bp who tp)
|
|
count)
|
|
(let ([buf (textual-port-output-buffer tp)]
|
|
[index (textual-port-output-index tp)])
|
|
(if (and (fx<= count max-put-copy) (fx< (fx+ index count) (string-length buf)))
|
|
; there's room to copy str with one character to spare
|
|
(begin
|
|
(string-copy! str start buf index count)
|
|
(let ([index (fx+ index count)])
|
|
(set-textual-port-output-size! tp index)
|
|
(set-textual-port-output-index! tp index))
|
|
count)
|
|
(if (try-flush-to-codec who tp) (write-to-codec who tp str start count) 0))))]
|
|
[else (if (try-flush-to-codec who tp) (write-to-codec who tp str start count) 0)])))
|
|
(define transcoded-port-flush
|
|
(lambda (who tp)
|
|
(assert-not-closed who tp)
|
|
(make-ready-for-output who tp)
|
|
(flush-to-codec who tp)
|
|
(flush-from-codec who tp)
|
|
(flush-from-bp who tp)))
|
|
(define transcoded-port-clear-output
|
|
(lambda (who tp)
|
|
(assert-not-closed who tp)
|
|
(unless ($port-flags-set? tp (constant port-flag-input-mode))
|
|
; position will be wrong after this. c'est la vie.
|
|
(if ($port-flags-set? tp (constant port-flag-line-buffered))
|
|
(set-textual-port-output-size! tp 0)
|
|
(set-textual-port-output-index! tp 0))
|
|
(let ([info ($port-info tp)])
|
|
(codec-info-next-set! info 0)
|
|
(let ([bp (codec-info-bp info)])
|
|
(call-port-handler clear-output who bp))))))
|
|
(define transcoded-port-close-port
|
|
(lambda (who tp)
|
|
(unless (port-closed? tp)
|
|
(when (output-port? tp)
|
|
(make-ready-for-output who tp)
|
|
(flush-to-codec who tp)
|
|
(flush-from-codec who tp)
|
|
(flush-from-bp who tp))
|
|
(unless (or (eq? tp $console-input-port) ; refuse to close original console ports
|
|
(eq? tp $console-output-port)
|
|
(eq? tp $console-error-port))
|
|
(when (output-port? tp)
|
|
(set-textual-port-output-size! tp 0))
|
|
(when (input-port? tp)
|
|
(set-textual-port-input-size! tp 0)
|
|
(set-port-eof! tp #f))
|
|
(let ([info ($port-info tp)])
|
|
(close-port (codec-info-bp info))
|
|
((codec-info-close info) info))
|
|
(unregister-open-file tp)
|
|
(mark-port-closed! tp)))))
|
|
(define transcoded-port-port-position
|
|
(lambda (who tp)
|
|
(assert-not-closed who tp)
|
|
(cond
|
|
[($port-flags-set? tp (constant port-flag-input-mode))
|
|
; (port-position bp) gives us position in bytes after characters and bytes
|
|
; we haven't yet consumed. to get position of first unconsumed character or
|
|
; byte, need to adjust downward by the number of bytes buffered, using
|
|
; ioffsets to determine the byte position of the first unconsumed character
|
|
; relative to the start of the port's buffer, ibytes to determine the total
|
|
; number of bytes represented by the characters in the port's buffer, and
|
|
; (- iend next) to determine the number of bytes not yet converted
|
|
; into characters. if ioffsets is not available, the reported port-position
|
|
; may not be accurate.
|
|
(let ([info ($port-info tp)])
|
|
(- (call-port-handler port-position who (codec-info-bp info))
|
|
(let ([buffered-bytes (fx- (codec-info-iend info) (codec-info-next info))])
|
|
(cond
|
|
[(port-input-empty? tp) buffered-bytes]
|
|
[(codec-info-ioffsets info) =>
|
|
(lambda (ioffsets)
|
|
(fx- (fx+ (codec-info-ibytes info) buffered-bytes)
|
|
(fxvector-ref ioffsets (textual-port-input-index tp))))]
|
|
[else
|
|
(position-warning who "cannot determine accurate position for operation on ~s" tp)
|
|
buffered-bytes]))))]
|
|
[else
|
|
(flush-to-codec who tp)
|
|
(flush-from-codec who tp)
|
|
(let ([bp (codec-info-bp ($port-info tp))])
|
|
(call-port-handler port-position who bp))])))
|
|
(define transcoded-port-set-port-position!
|
|
(lambda (who tp pos)
|
|
(assert-not-closed who tp)
|
|
(let ([info ($port-info tp)])
|
|
(if ($port-flags-set? tp (constant port-flag-input-mode))
|
|
(begin
|
|
(set-textual-port-input-size! tp 0)
|
|
(set-port-eof! tp #f)
|
|
(codec-info-next-set! info 0)
|
|
(codec-info-iend-set! info 0)
|
|
(codec-info-icr-set! info #f))
|
|
(begin
|
|
(flush-to-codec who tp)
|
|
(flush-from-codec who tp)))
|
|
(let ([bp (codec-info-bp info)])
|
|
(call-port-handler set-port-position! who bp
|
|
; position past bom if known to be present at position 0
|
|
; if it was found or put elsewhere, all bets are off
|
|
(if (and (eq? pos 0) (codec-info-zbom info)) 2 pos))))))
|
|
(define transcoded-port-port-length
|
|
(lambda (who tp)
|
|
(assert-not-closed who tp)
|
|
(unless ($port-flags-set? tp (constant port-flag-input-mode))
|
|
(flush-to-codec who tp)
|
|
(flush-from-codec who tp))
|
|
(let ([bp (codec-info-bp ($port-info tp))])
|
|
(call-port-handler port-length who bp))))
|
|
(define transcoded-port-set-port-length!
|
|
(lambda (who tp pos)
|
|
(assert-not-closed who tp)
|
|
(unless ($port-flags-set? tp (constant port-flag-input-mode))
|
|
(flush-to-codec who tp)
|
|
(flush-from-codec who tp))
|
|
(let ([bp (codec-info-bp ($port-info tp))])
|
|
(call-port-handler set-port-length! who bp pos))))
|
|
(define transcoded-port-port-nonblocking?
|
|
(lambda (who tp)
|
|
(assert-not-closed who tp)
|
|
(port-nonblocking? (codec-info-bp ($port-info tp)))))
|
|
(define transcoded-port-set-port-nonblocking!
|
|
(lambda (who tp b)
|
|
(assert-not-closed who tp)
|
|
(set-port-nonblocking! (codec-info-bp ($port-info tp)) b)))
|
|
(define (make-transcoded-port-handler bp)
|
|
; could cache these, but the savings would be minimal
|
|
(make-port-handler
|
|
[ready? (and (input-port? bp) transcoded-port-ready?)]
|
|
[lookahead (and (input-port? bp) transcoded-port-lookahead)]
|
|
[unget (and (input-port? bp) transcoded-port-unget)]
|
|
[get (and (input-port? bp) transcoded-port-get)]
|
|
[get-some (and (input-port? bp) transcoded-port-get-some)]
|
|
[clear-input (and (input-port? bp) transcoded-port-clear-input)]
|
|
[put (and (output-port? bp) transcoded-port-put)]
|
|
[put-some (and (output-port? bp) transcoded-port-put-some)]
|
|
[flush (and (output-port? bp) transcoded-port-flush)]
|
|
[clear-output (and (output-port? bp) transcoded-port-clear-output)]
|
|
[close-port transcoded-port-close-port]
|
|
[port-position
|
|
(and (port-handler-port-position ($port-handler bp))
|
|
transcoded-port-port-position)]
|
|
[set-port-position!
|
|
(and (port-handler-set-port-position! ($port-handler bp))
|
|
transcoded-port-set-port-position!)]
|
|
[port-length
|
|
(and (port-handler-port-length ($port-handler bp))
|
|
transcoded-port-port-length)]
|
|
[set-port-length!
|
|
(and (port-handler-set-port-length! ($port-handler bp))
|
|
transcoded-port-set-port-length!)]
|
|
[port-nonblocking?
|
|
(and (port-handler-port-nonblocking? ($port-handler bp))
|
|
transcoded-port-port-nonblocking?)]
|
|
[set-port-nonblocking!
|
|
(and (port-handler-set-port-nonblocking! ($port-handler bp))
|
|
transcoded-port-set-port-nonblocking!)])))
|
|
(set-who! transcoded-port
|
|
(lambda (bp tx)
|
|
(define-syntax copy-flag!
|
|
(syntax-rules ()
|
|
[(_ from to flag)
|
|
(when ($port-flags-set? from (constant flag))
|
|
($set-port-flags! to (constant flag)))]))
|
|
(define (clone-port bp)
|
|
(let ([bpc ($make-textual-input/output-port "" ($port-handler bp) "" "" #f)])
|
|
($byte-copy! bp (constant port-type-disp) bpc (constant port-type-disp) (constant size-port))
|
|
bpc))
|
|
(unless (and (port? bp) (binary-port? bp)) ($oops who "~s is not a binary port" bp))
|
|
(unless ($transcoder? tx) ($oops who "~s is not a transcoder" tx))
|
|
(let* ([bpc (clone-port bp)]
|
|
[name (port-name bpc)]
|
|
[buffer-length (if (or ($port-flags-set? bp (constant port-flag-block-buffered))
|
|
($port-flags-set? bp (constant port-flag-line-buffered)))
|
|
buffered-transcoded-port-buffer-length
|
|
unbuffered-transcoded-port-buffer-length)]
|
|
[codec ($transcoder-codec tx)]
|
|
[info ((codec-make-info codec) who tx bpc (make-bytevector codec-buffer-length))]
|
|
[handler (make-transcoded-port-handler bpc)]
|
|
[tp (if (input-port? bpc)
|
|
(if (output-port? bpc)
|
|
($make-textual-input/output-port name handler
|
|
(make-string buffer-length)
|
|
(make-string buffer-length)
|
|
info)
|
|
($make-textual-input-port name handler
|
|
(make-string buffer-length) info))
|
|
($make-textual-output-port name handler
|
|
(make-string buffer-length) info))])
|
|
(copy-flag! bpc tp port-flag-block-buffered)
|
|
(copy-flag! bpc tp port-flag-line-buffered)
|
|
(mark-port-closed! bp)
|
|
(when (input-port? bp)
|
|
(set-binary-port-input-size! bp 0)
|
|
(set-port-eof! bp #f)
|
|
(set-textual-port-input-size! tp 0))
|
|
(when (output-port? bp)
|
|
(set-binary-port-output-size! bp 0)
|
|
(set-textual-port-output-size! tp
|
|
(if ($port-flags-set? tp (constant port-flag-line-buffered))
|
|
0
|
|
(fx1- buffer-length)))
|
|
($set-port-flags! tp (constant port-flag-bol)))
|
|
($set-port-info! bp tp) ; back-link for bytevector-output-port extractor
|
|
(when (registered-open-file? bp)
|
|
(unregister-open-file bp)
|
|
(register-open-file tp))
|
|
tp))))
|
|
|
|
(let ()
|
|
(define-syntax set-who!-port-has
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name)
|
|
(with-syntax ([name (construct-name #'name "port-has-" #'name "?")]
|
|
[field (construct-name #'name "port-handler-" #'name)])
|
|
#'(set-who! name
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(and (field ($port-handler p)) #t))))])))
|
|
|
|
(define-syntax set-who!-port
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name (args ...))
|
|
(with-syntax ([field (construct-name #'name "port-handler-" #'name)])
|
|
#'(set-who! name
|
|
(lambda (p args ...)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(let ([op (field ($port-handler p))])
|
|
(unless op ($oops who "~s does not support operation" p))
|
|
(op who p args ...)))))])))
|
|
|
|
(set-who!-port-has port-position)
|
|
(set-who!-port port-position ())
|
|
(set-who!-port-has set-port-position!)
|
|
(set-who!-port set-port-position! (x))
|
|
|
|
;; The following are not in R6RS
|
|
(set-who!-port-has port-nonblocking?)
|
|
(set-who!-port port-nonblocking? ())
|
|
(set-who!-port-has set-port-nonblocking!)
|
|
(set-who!-port set-port-nonblocking! (x))
|
|
(set-who!-port-has port-length)
|
|
(set-who!-port port-length ())
|
|
(set-who!-port-has set-port-length!)
|
|
(set-who!-port set-port-length! (x)))
|
|
|
|
(set-who! file-position
|
|
(case-lambda
|
|
[(p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(let ([op (port-handler-port-position ($port-handler p))])
|
|
(unless op ($oops who "~s does not support operation" p))
|
|
(op who p))]
|
|
[(p pos)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(let ([op (port-handler-set-port-position! ($port-handler p))])
|
|
(unless op ($oops who "~s does not support operation" p))
|
|
(op who p pos))]))
|
|
|
|
(set-who! file-length
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(let ([op (port-handler-port-length ($port-handler p))])
|
|
(unless op ($oops who "~s does not support operation" p))
|
|
(op who p))))
|
|
|
|
;; Not in R6RS
|
|
;; truncate-file is set-port-length and set-port-position combined
|
|
(let ()
|
|
(define (tp who port pos)
|
|
(unless (output-port? port) ($oops who "~s is not an output port" port))
|
|
(let ([handler ($port-handler port)])
|
|
(let ([set-len! (port-handler-set-port-length! handler)]
|
|
[set-pos! (port-handler-set-port-position! handler)])
|
|
(unless (and set-len! set-pos!)
|
|
($oops who "~s does not support operation" port))
|
|
(set-len! who port pos)
|
|
(set-pos! who port pos))))
|
|
|
|
(set-who! truncate-port
|
|
(case-lambda
|
|
[(port) (tp who port 0)]
|
|
[(port pos) (tp who port pos)]))
|
|
|
|
(set-who! truncate-file
|
|
(case-lambda
|
|
[(port) (tp who port 0)]
|
|
[(port pos) (tp who port pos)])))
|
|
|
|
(set-who! close-port
|
|
(lambda (port)
|
|
(unless (port? port) ($oops who "~s is not a port" port))
|
|
(call-port-handler close-port who port)))
|
|
|
|
(set-who! call-with-port
|
|
(lambda (port proc)
|
|
(unless (port? port) ($oops who "~s is not a port" port))
|
|
(unless (procedure? proc) ($oops who "~s is not a procedure" proc))
|
|
(call-with-values
|
|
(lambda () (proc port))
|
|
(case-lambda
|
|
[(x)
|
|
(call-port-handler close-port who port)
|
|
x]
|
|
[args
|
|
(call-port-handler close-port who port)
|
|
(apply values args)]))))
|
|
|
|
;;;; 8.2.7 Input ports
|
|
;; input-port? in prims.ss
|
|
;; port-eof? in prims.ss
|
|
|
|
;; Not in R6RS
|
|
(set-who! input-port-ready?
|
|
(lambda (input-port)
|
|
(unless (input-port? input-port)
|
|
($oops who "~s is not an input port" input-port))
|
|
(or (not (port-input-empty? input-port))
|
|
(port-flag-eof-set? input-port)
|
|
(call-port-handler ready? who input-port))))
|
|
|
|
(let ()
|
|
;; open-file-input-port
|
|
(define open-binary-file-input-port
|
|
(lambda (who filename options mode)
|
|
(unless (string? filename)
|
|
($oops who "~s is not a string" filename))
|
|
(unless (and (enum-set? options)
|
|
(enum-set-subset? options $file-options))
|
|
($oops who "~s is not a file-options object" options))
|
|
(unless (buffer-mode? mode)
|
|
($oops who "~s is not a valid buffer mode" mode))
|
|
(when (enum-set-subset? (file-options exclusive) options)
|
|
($oops who "exclusive option not supported for file input ports"))
|
|
(let ([fd (critical-section ($open-input-fd filename (enum-set-subset? (file-options compressed) options)))])
|
|
(when (pair? fd) (open-oops who filename options fd))
|
|
(if (box? fd) ; box iff file opened with compressed option is actually gzip'd
|
|
(open-binary-fd-input-port who filename (unbox fd) #t mode #t)
|
|
(open-binary-fd-input-port who filename fd #t mode #f)))))
|
|
|
|
(define open-binary-standard-input-port
|
|
(lambda (b-mode)
|
|
(define who 'standard-input-port)
|
|
(unless (buffer-mode? b-mode)
|
|
($oops who "~s is not a valid buffer mode" b-mode))
|
|
(open-binary-fd-input-port who "stdin" (make-fd 0) ($fd-regular? 0) b-mode #f)))
|
|
|
|
(define help-open-file-input-port
|
|
(lambda (who filename options buffer-mode maybe-transcoder)
|
|
(let ([binary-port (open-binary-file-input-port who filename options buffer-mode)])
|
|
(if maybe-transcoder
|
|
(transcoded-port binary-port maybe-transcoder)
|
|
binary-port))))
|
|
|
|
(set-who! port-file-compressed!
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(when (and (input-port? p) (output-port? p)) ($oops who "cannot compress input/output port ~s" p))
|
|
(let ([bp (if (binary-port? p)
|
|
p
|
|
(let ([info ($port-info p)])
|
|
(and (codec-info? info) (codec-info-bp info))))])
|
|
(unless (and bp ($port-flags-set? bp (constant port-flag-file))) ($oops who "~s is not a file port" p))
|
|
(unless ($port-flags-set? bp (constant port-flag-compressed))
|
|
(let ([fd ($port-info bp)])
|
|
(unless ($fd-regular? fd) ($oops who "~s is not a regular file" p))
|
|
; flush any uncompressed data in the output buffer
|
|
(when (output-port? p) (flush-output-port p))
|
|
(critical-section
|
|
(let ([gzfd (if (input-port? p)
|
|
(let ([fp (port-position p)])
|
|
; reposition to 'unread' any compressed data in the input buffer
|
|
(set-port-position! p fp)
|
|
($compress-input-fd fd fp))
|
|
($compress-output-fd fd))])
|
|
(when (string? gzfd) ($oops who "failed for ~s: ~(~a~)" p gzfd))
|
|
(unless (eqv? gzfd fd) ; uncompressed input port
|
|
(assert (box? gzfd))
|
|
($set-port-info! bp (unbox gzfd))
|
|
($set-port-flags! bp (constant port-flag-compressed))))))))))
|
|
|
|
(set-who! open-fd-input-port
|
|
(case-lambda
|
|
[(fd)
|
|
(unless (and (fixnum? fd) (fx>= fd 0))
|
|
($oops who "~s is not a file descriptor" fd))
|
|
(open-binary-fd-input-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) (buffer-mode block) #f)]
|
|
[(fd buffer-mode)
|
|
(unless (and (fixnum? fd) (fx>= fd 0))
|
|
($oops who "~s is not a file descriptor" fd))
|
|
(unless (buffer-mode? buffer-mode)
|
|
($oops who "~s is not a buffer mode" buffer-mode))
|
|
(open-binary-fd-input-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f)]
|
|
[(fd buffer-mode maybe-transcoder)
|
|
(unless (and (fixnum? fd) (fx>= fd 0))
|
|
($oops who "~s is not a file descriptor" fd))
|
|
(unless (buffer-mode? buffer-mode)
|
|
($oops who "~s is not a buffer mode" buffer-mode))
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(let ([binary-port (open-binary-fd-input-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f)])
|
|
(if maybe-transcoder
|
|
(transcoded-port binary-port maybe-transcoder)
|
|
binary-port))]))
|
|
|
|
(let ()
|
|
(define s-process (foreign-procedure "(cs)s_process" (string boolean) scheme-object))
|
|
(define (subprocess-port who what fd pid b-mode maybe-transcoder)
|
|
(unless (buffer-mode? b-mode)
|
|
($oops who "~s is not a valid buffer mode" b-mode))
|
|
(let ([name (format "pid ~s ~a" pid what)])
|
|
(let ([bp (if (eq? what 'stdin)
|
|
(open-binary-fd-output-port who name (make-fd fd) #f b-mode #f #f)
|
|
(open-binary-fd-input-port who name (make-fd fd) #f b-mode #f))])
|
|
(if maybe-transcoder (transcoded-port bp maybe-transcoder) bp))))
|
|
(set-who! process
|
|
(lambda (s)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(apply (lambda (ifd ofd pid)
|
|
(list
|
|
(subprocess-port who 'stdout ifd pid (buffer-mode block) (current-transcoder))
|
|
(subprocess-port who 'stdin ofd pid (buffer-mode line) (current-transcoder))
|
|
pid))
|
|
(s-process s #f))))
|
|
(set-who! open-process-ports
|
|
(case-lambda
|
|
[(s)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(apply (lambda (ifd efd ofd pid)
|
|
(values
|
|
(subprocess-port who 'stdin ofd pid (buffer-mode block) #f)
|
|
(subprocess-port who 'stdout ifd pid (buffer-mode block) #f)
|
|
(subprocess-port who 'stderr efd pid (buffer-mode block) #f)
|
|
pid))
|
|
(s-process s #t))]
|
|
[(s b-mode)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(apply (lambda (ifd efd ofd pid)
|
|
(values
|
|
(subprocess-port who 'stdin ofd pid b-mode #f)
|
|
(subprocess-port who 'stdout ifd pid b-mode #f)
|
|
(subprocess-port who 'stderr efd pid b-mode #f)
|
|
pid))
|
|
(s-process s #t))]
|
|
[(s b-mode maybe-transcoder)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(apply (lambda (ifd efd ofd pid)
|
|
(values
|
|
(subprocess-port who 'stdin ofd pid b-mode maybe-transcoder)
|
|
(subprocess-port who 'stdout ifd pid b-mode maybe-transcoder)
|
|
(subprocess-port who 'stderr efd pid b-mode maybe-transcoder)
|
|
pid))
|
|
(s-process s #t))])))
|
|
|
|
(set-who! open-file-input-port
|
|
(case-lambda
|
|
[(filename)
|
|
(open-binary-file-input-port who filename (file-options) (buffer-mode block))]
|
|
[(filename options)
|
|
(open-binary-file-input-port who filename options (buffer-mode block))]
|
|
[(filename options buffer-mode)
|
|
(open-binary-file-input-port who filename options buffer-mode)]
|
|
[(filename options buffer-mode maybe-transcoder)
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(help-open-file-input-port who filename options buffer-mode maybe-transcoder)]))
|
|
|
|
(set! $open-file-input-port
|
|
(case-lambda
|
|
[(who filename)
|
|
(open-binary-file-input-port who filename (file-options) (buffer-mode block))]
|
|
[(who filename options)
|
|
(open-binary-file-input-port who filename options (buffer-mode block))]
|
|
[(who filename options buffer-mode)
|
|
(open-binary-file-input-port who filename options buffer-mode)]
|
|
[(who filename options buffer-mode maybe-transcoder)
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(help-open-file-input-port who filename options buffer-mode maybe-transcoder)]))
|
|
|
|
(set-who! standard-input-port
|
|
(case-lambda
|
|
[() (open-binary-standard-input-port (buffer-mode block))]
|
|
[(b-mode) (open-binary-standard-input-port b-mode)]
|
|
[(b-mode maybe-transcoder)
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(let ([binary-port (open-binary-standard-input-port b-mode)])
|
|
(if maybe-transcoder
|
|
(transcoded-port binary-port maybe-transcoder)
|
|
binary-port))]))
|
|
|
|
(set-who! r6rs:standard-input-port
|
|
(rec standard-input-port
|
|
(lambda ()
|
|
(open-binary-standard-input-port (buffer-mode block)))))
|
|
|
|
; simple i/o routines here to share helpers
|
|
(let ()
|
|
(define (oif who s o)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(let ([o (if (list? o) o (list o))])
|
|
(let loop ([o o] [zmode #f] [bmode #f])
|
|
(if (null? o)
|
|
(help-open-file-input-port who s
|
|
(if (eq? zmode 'compressed) (file-options compressed) (file-options))
|
|
(if (eq? bmode 'unbuffered) (buffer-mode none) (buffer-mode block))
|
|
(current-transcoder))
|
|
(case (car o)
|
|
[(compressed uncompressed)
|
|
(check-option who zmode (car o))
|
|
(loop (cdr o) (car o) bmode)]
|
|
[(buffered unbuffered)
|
|
(check-option who bmode (car o))
|
|
(loop (cdr o) zmode (car o))]
|
|
[else ($oops who "invalid option ~s" (car o))])))))
|
|
|
|
(set-who! #(r6rs: open-input-file)
|
|
(lambda (s) (oif who s '())))
|
|
|
|
(set-who! open-input-file
|
|
(case-lambda
|
|
[(s) (oif who s '())]
|
|
[(s o) (oif who s o)]))
|
|
|
|
(let ()
|
|
(define (cwif who s f o)
|
|
(unless (procedure? f)
|
|
($oops 'call-with-input-file "~s is not a procedure" f))
|
|
(let ([p (oif 'call-with-input-file s o)])
|
|
(call-with-values
|
|
(lambda () (f p))
|
|
(lambda args (close-input-port p) (apply values args)))))
|
|
(set-who! #(r6rs: call-with-input-file)
|
|
(lambda (s f) (cwif who s f '())))
|
|
(set-who! call-with-input-file
|
|
(case-lambda
|
|
[(s f) (cwif who s f '())]
|
|
[(s f o) (cwif who s f o)])))
|
|
|
|
(let ()
|
|
(define (wiff who s f o)
|
|
(unless (procedure? f)
|
|
($oops 'with-input-from-file "~s is not a procedure" f))
|
|
(let ([p (oif 'with-input-from-file s o)])
|
|
(call-with-values
|
|
(lambda () (parameterize ([current-input-port p]) (f)))
|
|
(lambda v (close-input-port p) (apply values v)))))
|
|
(set-who! #(r6rs: with-input-from-file)
|
|
(lambda (s f) (wiff who s f '())))
|
|
(set-who! with-input-from-file
|
|
(case-lambda
|
|
[(s f) (wiff who s f '())]
|
|
[(s f o) (wiff who s f o)]))))
|
|
)
|
|
|
|
;; open-bytevector-input-port
|
|
(let ()
|
|
;; port-info stores whether to claim it is nonblocking or not
|
|
(define $bytevector-input-handler
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
#t)]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(if (port-input-empty? p)
|
|
(eof-object)
|
|
(bytevector-u8-ref (binary-port-input-buffer p)
|
|
(binary-port-input-index p))))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(if (eof-object? x)
|
|
;; We don't set port-eof b/c #!eof only comes at end anyway
|
|
(unless (port-input-empty? p) (unget-error who p x))
|
|
(let ([index (binary-port-input-index p)])
|
|
(when (eq? 0 index) (unget-error who p x))
|
|
(set-binary-port-input-index! p (fx1- index)))))]
|
|
[get
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(if (port-input-empty? p)
|
|
(eof-object)
|
|
(let ([index (binary-port-input-index p)])
|
|
(set-binary-port-input-index! p (fx1+ index))
|
|
(bytevector-u8-ref (binary-port-input-buffer p) index))))]
|
|
[get-some
|
|
(lambda (who p bv start count)
|
|
(assert-not-closed who p)
|
|
(let ([port-count (binary-port-input-count p)])
|
|
(if (eq? 0 port-count)
|
|
(eof-object)
|
|
(let ([index (binary-port-input-index p)]
|
|
[count (fxmin count port-count)])
|
|
(bytevector-copy! (binary-port-input-buffer p) index
|
|
bv start count)
|
|
(set-binary-port-input-index! p (fx+ index count))
|
|
count))))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(assert-not-closed who p))]
|
|
[put #f]
|
|
[put-some #f]
|
|
[flush #f]
|
|
[clear-output #f]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
(mark-port-closed! p)
|
|
(set-binary-port-input-size! p 0)))]
|
|
[port-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-port-input-index p))]
|
|
[set-port-position!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(unless (and (fixnum? x) (not ($fxu< (binary-port-input-size p) x)))
|
|
(if (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
|
|
(position-oops who p x "out of range")
|
|
($oops who "~s is not a valid position" x)))
|
|
(set-binary-port-input-index! p x))]
|
|
[port-length
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(bytevector-length (binary-port-input-buffer p)))]
|
|
[set-port-length! #f]
|
|
[port-nonblocking?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
($port-info p))]
|
|
[set-port-nonblocking!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
($set-port-info! p x))]))
|
|
|
|
(define open-binary-bytevector-input-port
|
|
(lambda (bv)
|
|
(define who 'open-bytevector-input-port)
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(let ([p ($make-binary-input-port "bytevector" $bytevector-input-handler bv #f)])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
p)))
|
|
|
|
(set-who! open-bytevector-input-port
|
|
(case-lambda
|
|
[(bv) (open-binary-bytevector-input-port bv)]
|
|
[(bv maybe-transcoder)
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(let ([binary-port (open-binary-bytevector-input-port bv)])
|
|
(if maybe-transcoder
|
|
(transcoded-port binary-port maybe-transcoder)
|
|
binary-port))]))
|
|
)
|
|
|
|
;; open-string-input-port
|
|
(let ()
|
|
;; port-info stores whether to claim it is nonblocking or not
|
|
(define $string-input-handler
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
#t)]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(if (port-input-empty? p)
|
|
(eof-object)
|
|
(string-ref (textual-port-input-buffer p)
|
|
(textual-port-input-index p))))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(if (eof-object? x)
|
|
;; We don't set port-eof b/c #!eof only comes at end anyway
|
|
(unless (port-input-empty? p) (unget-error who p x))
|
|
(let ([index (textual-port-input-index p)])
|
|
(when (eq? 0 index) (unget-error who p x))
|
|
(set-textual-port-input-index! p (fx1- index)))))]
|
|
[get
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(if (port-input-empty? p)
|
|
(eof-object)
|
|
(let ([index (textual-port-input-index p)])
|
|
(set-textual-port-input-index! p (fx1+ index))
|
|
(string-ref (textual-port-input-buffer p) index))))]
|
|
[get-some
|
|
(lambda (who p st start count)
|
|
(assert-not-closed who p)
|
|
(let ([port-count (textual-port-input-count p)])
|
|
(if (eq? 0 port-count)
|
|
(eof-object)
|
|
(let ([index (textual-port-input-index p)]
|
|
[count (fxmin count port-count)])
|
|
(string-copy! (textual-port-input-buffer p) index
|
|
st start count)
|
|
(set-textual-port-input-index! p (fx+ index count))
|
|
count))))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(assert-not-closed who p))]
|
|
[put #f]
|
|
[put-some #f]
|
|
[flush #f]
|
|
[clear-output #f]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
(mark-port-closed! p)
|
|
(set-textual-port-input-size! p 0)))]
|
|
[port-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-port-input-index p))]
|
|
[set-port-position!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(unless (and (fixnum? x) (not ($fxu< (textual-port-input-size p) x)))
|
|
(if (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
|
|
(position-oops who p x "out of range")
|
|
($oops who "~s is not a valid position" x)))
|
|
(set-textual-port-input-index! p x))]
|
|
[port-length
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(string-length (textual-port-input-buffer p)))]
|
|
[set-port-length! #f]
|
|
[port-nonblocking?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
($port-info p))]
|
|
[set-port-nonblocking!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
($set-port-info! p x))]))
|
|
|
|
(define (osip who str)
|
|
(unless (string? str)
|
|
($oops who "~s is not a string" str))
|
|
(let ([p ($make-textual-input-port "string" $string-input-handler str #f)])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
($set-port-flags! p (constant port-flag-char-positions))
|
|
p))
|
|
|
|
(set-who! open-string-input-port
|
|
(lambda (str)
|
|
(osip who str)))
|
|
|
|
(set-who! open-input-string
|
|
(lambda (str)
|
|
(osip who str)))
|
|
)
|
|
|
|
;; standard-input-port in open-binary-file-input-port section
|
|
;; current-input-port in prims.ss
|
|
|
|
(set-who! make-custom-binary-input-port
|
|
(lambda (id read! get-position set-position! close)
|
|
(unless (string? id) ($oops who "~s is not a string" id))
|
|
(unless (procedure? read!) ($oops who "~s is not a procedure" read!))
|
|
(unless (or (not get-position) (procedure? get-position))
|
|
($oops who "~s is not a procedure or #f" get-position))
|
|
(unless (or (not set-position!) (procedure? set-position!))
|
|
($oops who "~s is not a procedure or #f" set-position!))
|
|
(unless (or (not close) (procedure? close))
|
|
($oops who "~s is not a procedure or #f" close))
|
|
(let ([handler
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(or (not (port-input-empty? p))
|
|
(port-flag-eof-set? p)
|
|
(read-oops who p "cannot determine ready status")))]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-lookahead who p read!))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-unget who p x))]
|
|
[get
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-get who p read!))]
|
|
[get-some
|
|
(lambda (who p bv start count)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-get-some who p read! bv start count))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-clear-input who p))]
|
|
[put #f]
|
|
[put-some #f]
|
|
[flush #f]
|
|
[clear-output #f]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
(binary-custom-port-close-port who p close)))]
|
|
[port-position
|
|
(and get-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-port-position in who p get-position)))]
|
|
[set-port-position!
|
|
(and set-position!
|
|
(lambda (who p x)
|
|
(unless (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
|
|
($oops who "~s is not a valid position" x))
|
|
(assert-not-closed who p)
|
|
(set-binary-port-input-size! p 0) ;; junk the buffer data
|
|
(set-port-eof! p #f)
|
|
(set-position! x)))]
|
|
[port-length #f]
|
|
[set-port-length! #f]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f])])
|
|
(let ([p ($make-binary-input-port id handler
|
|
(make-bytevector (custom-port-buffer-size))
|
|
#f)])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
(set-binary-port-input-size! p 0)
|
|
p))))
|
|
|
|
(set-who! make-custom-textual-input-port
|
|
(lambda (id read! get-position set-position! close)
|
|
(unless (string? id) ($oops who "~s is not a string" id))
|
|
(unless (procedure? read!) ($oops who "~s is not a procedure" read!))
|
|
(unless (or (not get-position) (procedure? get-position))
|
|
($oops who "~s is not a procedure or #f" get-position))
|
|
(unless (or (not set-position!) (procedure? set-position!))
|
|
($oops who "~s is not a procedure or #f" set-position!))
|
|
(unless (or (not close) (procedure? close))
|
|
($oops who "~s is not a procedure or #f" close))
|
|
(let ([handler
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(or (not (port-input-empty? p))
|
|
(port-flag-eof-set? p)
|
|
(read-oops who p "cannot determine ready status")))]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-lookahead who p read!))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-unget who p x))]
|
|
[get
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-get who p read!))]
|
|
[get-some
|
|
(lambda (who p str start count)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-get-some who p read! str start count))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-clear-input who p))]
|
|
[put #f]
|
|
[put-some #f]
|
|
[flush #f]
|
|
[clear-output #f]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
(textual-custom-port-close-port who p close)))]
|
|
[port-position
|
|
(and get-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(unless (port-input-empty? p)
|
|
(position-warning who
|
|
"cannot determine accurate position after read on ~s"
|
|
p))
|
|
(get-position)))]
|
|
[set-port-position!
|
|
(and set-position!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(set-textual-port-input-size! p 0) ;; junk the buffer data
|
|
(set-port-eof! p #f)
|
|
(set-position! x)))]
|
|
[port-length #f]
|
|
[set-port-length! #f]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f])])
|
|
(let ([p ($make-textual-input-port id handler
|
|
(make-string (custom-port-buffer-size))
|
|
#f)])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
(set-textual-port-input-size! p 0)
|
|
p))))
|
|
|
|
|
|
;;;; 8.2.8 Binary input
|
|
;; get-u8 in prims.ss
|
|
;; lookahead-u8 in prims.ss
|
|
;; unget-u8 in prims.ss
|
|
|
|
;; get-bytevector! :: port * bv * start * max -> count TODO(not R6RS)
|
|
|
|
(let ()
|
|
;; This helper handles all the looping for the following functions
|
|
(define (get-bytevector-min-max who p bv start min max)
|
|
(if (eq? 0 max)
|
|
0
|
|
(let ([get-some (port-handler-get-some ($port-handler p))])
|
|
;; Loop invariant:
|
|
;; next = next spot to fill in the bytevector
|
|
;; min = minimum left to read
|
|
;; max = maximum left to read
|
|
(let loop ([next start]
|
|
[min min]
|
|
[max max])
|
|
(let ([n (get-some who p bv next max)])
|
|
(if (eof-object? n)
|
|
(if (eq? start next)
|
|
(eof-object) ;; We couldn't even read one byte
|
|
(begin ;; Got some but got #!eof before full
|
|
(call-port-handler unget who p (eof-object)) ;; Put the #!eof back
|
|
(fx- next start))) ;; Return our count
|
|
(let ([min (fx- min n)]
|
|
[next (fx+ next n)])
|
|
(if (fx<= min 0)
|
|
(fx- next start) ;; We got enough to stop
|
|
(loop next min (fx- max n))))))))))
|
|
|
|
(define (append-blocks size block-size block blocks)
|
|
(let ([buffer (#2%make-bytevector size)])
|
|
(let loop ([block-size block-size] [block block] [blocks blocks] [end size])
|
|
(let ([end (fx- end block-size)])
|
|
(bytevector-copy! block 0 buffer end block-size)
|
|
(if (null? blocks)
|
|
buffer
|
|
(loop (caar blocks) (cdar blocks) (cdr blocks) end))))))
|
|
|
|
(set-who! get-bytevector-n
|
|
(lambda (binary-input-port count)
|
|
(unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
|
|
($oops who "~s is not a binary input port" binary-input-port))
|
|
(unless (and (fixnum? count) (fx>= count 0))
|
|
($oops who "~s is not a nonnegative fixnum" count))
|
|
(let ([buffer-size (file-buffer-size)])
|
|
(if (not ($fxu< buffer-size count))
|
|
(let ([bv (make-bytevector count)])
|
|
(let ([n (get-bytevector-min-max
|
|
who binary-input-port bv 0 count count)])
|
|
(if (eof-object? n) n (bytevector-truncate! bv n))))
|
|
(let ([get-some (port-handler-get-some ($port-handler binary-input-port))])
|
|
(let loop ([count count]
|
|
[size 0]
|
|
[next-block-index 0]
|
|
[next-block (make-bytevector buffer-size)]
|
|
[blocks '()])
|
|
(let ([next-size (get-some who binary-input-port
|
|
next-block next-block-index
|
|
(fxmin count (fx- buffer-size next-block-index)))])
|
|
(if (or (eof-object? next-size) (eq? next-size 0))
|
|
(if (eqv? size 0)
|
|
(if (eof-object? next-size) (eof-object) #vu8())
|
|
(append-blocks size next-block-index next-block blocks))
|
|
(let ([count (fx- count next-size)]
|
|
[size (fx+ size next-size)]
|
|
[next-block-index (fx+ next-block-index next-size)])
|
|
(if (eqv? count 0)
|
|
(append-blocks size next-block-index next-block blocks)
|
|
(if (fx>= next-block-index (fxquotient buffer-size 2))
|
|
(loop count size 0
|
|
(make-bytevector buffer-size)
|
|
(cons (cons next-block-index next-block) blocks))
|
|
(loop count size next-block-index next-block blocks))))))))))))
|
|
|
|
(set-who! get-bytevector-n!
|
|
(lambda (binary-input-port bv start count)
|
|
(unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
|
|
($oops who "~s is not a binary input port" binary-input-port))
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(unless (and (fixnum? start) (fx>= start 0))
|
|
($oops who "invalid start value ~s" start))
|
|
(unless (and (fixnum? count) (fx>= count 0))
|
|
($oops who "invalid count ~s" count))
|
|
(unless (fx<= count (fx- (bytevector-length bv) start)) ; avoid overflow
|
|
($oops who "index ~s + count ~s is beyond the end of ~s" start count bv))
|
|
(get-bytevector-min-max who binary-input-port bv start count count)))
|
|
|
|
(set-who! get-bytevector-some
|
|
(lambda (binary-input-port)
|
|
(let ([buffer-size (file-buffer-size)])
|
|
(unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
|
|
($oops who "~s is not a binary input port" binary-input-port))
|
|
(let ([bv (make-bytevector buffer-size)])
|
|
(let ([n (get-bytevector-min-max who binary-input-port bv 0 0 buffer-size)])
|
|
(if (eof-object? n)
|
|
(eof-object)
|
|
(bytevector-truncate! bv n)))))))
|
|
|
|
(set-who! get-bytevector-some!
|
|
(lambda (binary-input-port bv start count)
|
|
(unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
|
|
($oops who "~s is not a binary input port" binary-input-port))
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(unless (and (fixnum? start) (fx>= start 0))
|
|
($oops who "invalid start value ~s" start))
|
|
(unless (and (fixnum? count) (fx>= count 0))
|
|
($oops who "invalid count ~s" count))
|
|
(unless (fx<= count (fx- (bytevector-length bv) start)) ; avoid overflow
|
|
($oops who "index ~s + count ~s is beyond the end of ~s" start count bv))
|
|
(get-bytevector-min-max who binary-input-port bv start 0 count)))
|
|
|
|
(set-who! get-bytevector-all
|
|
(lambda (binary-input-port)
|
|
(unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
|
|
($oops who "~s is not a binary input port" binary-input-port))
|
|
(let ([buffer-size (file-buffer-size)])
|
|
(let ([get-some (port-handler-get-some ($port-handler binary-input-port))])
|
|
(let loop ([size 0]
|
|
[next-block-index 0]
|
|
[next-block (make-bytevector buffer-size)]
|
|
[blocks '()])
|
|
(let ([next-size (get-some who binary-input-port
|
|
next-block next-block-index
|
|
(fx- buffer-size next-block-index))])
|
|
(if (eof-object? next-size)
|
|
(if (eq? size 0)
|
|
(eof-object)
|
|
(append-blocks size next-block-index next-block blocks))
|
|
(let ([size (fx+ size next-size)]
|
|
[next-block-index (fx+ next-block-index next-size)])
|
|
(if (fx>= next-block-index (fxquotient buffer-size 2))
|
|
(loop size 0
|
|
(make-bytevector buffer-size)
|
|
(cons (cons next-block-index next-block) blocks))
|
|
(loop size next-block-index next-block blocks))))))))))
|
|
)
|
|
|
|
|
|
;;;; 8.2.9 Textual input
|
|
;; get-char in prims.ss
|
|
;; lookahead-char in prims.ss
|
|
|
|
(let ()
|
|
;; TODO: this code is identical to get-bytevector-min-max
|
|
;; This helper handles all the looping for the following functions
|
|
(define (get-string-min-max who p bv start min max)
|
|
(if (eq? 0 max)
|
|
0
|
|
(let ([get-some (port-handler-get-some ($port-handler p))])
|
|
;; Loop invariant:
|
|
;; next = next spot to fill in the bytevector
|
|
;; min = minimum left to read
|
|
;; max = maximum left to read
|
|
(let loop ([next start]
|
|
[min min]
|
|
[max max])
|
|
(let ([n (get-some who p bv next max)])
|
|
(if (eof-object? n)
|
|
(if (eq? start next)
|
|
(eof-object) ;; We couldn't even read one byte
|
|
(begin ;; Got some but got #!eof before full
|
|
(call-port-handler unget who p (eof-object)) ;; Put the #!eof back
|
|
(fx- next start))) ;; Return our count
|
|
(let ([min (fx- min n)]
|
|
[next (fx+ next n)])
|
|
(if (fx<= min 0)
|
|
(fx- next start) ;; We got enough to stop
|
|
(loop next min (fx- max n))))))))))
|
|
|
|
(define (append-blocks size block-size block blocks)
|
|
(let ([buffer (#2%make-string size)])
|
|
(let loop ([block-size block-size] [block block] [blocks blocks] [end size])
|
|
(let ([end (fx- end block-size)])
|
|
(string-copy! block 0 buffer end block-size)
|
|
(if (null? blocks)
|
|
buffer
|
|
(loop (caar blocks) (cdar blocks) (cdr blocks) end))))))
|
|
|
|
(define $get-string-all
|
|
(lambda (who textual-input-port)
|
|
(let ([buffer-size (file-buffer-size)])
|
|
(let ([get-some (port-handler-get-some ($port-handler textual-input-port))])
|
|
(let loop ([size 0]
|
|
[next-block-index 0]
|
|
[next-block (make-string buffer-size)]
|
|
[blocks '()])
|
|
(let ([next-size (get-some who textual-input-port
|
|
next-block next-block-index
|
|
(fx- buffer-size next-block-index))])
|
|
(if (eof-object? next-size)
|
|
(if (eq? size 0)
|
|
(eof-object)
|
|
(append-blocks size next-block-index next-block blocks))
|
|
(let ([size (fx+ size next-size)]
|
|
[next-block-index (fx+ next-block-index next-size)])
|
|
(if (fx>= next-block-index (fxquotient buffer-size 2))
|
|
(loop size 0
|
|
(make-string buffer-size)
|
|
(cons (cons next-block-index next-block) blocks))
|
|
(loop size next-block-index next-block blocks))))))))))
|
|
|
|
(set-who! get-string-n
|
|
(lambda (textual-input-port count)
|
|
(unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
|
|
($oops who "~s is not a textual input port" textual-input-port))
|
|
(unless (and (fixnum? count) (fx>= count 0))
|
|
($oops who "~s is not a nonnegative fixnum" count))
|
|
(let ([buffer-size (file-buffer-size)])
|
|
(if (not ($fxu< buffer-size count))
|
|
(let ([st (make-string count)])
|
|
(let ([n (get-string-min-max
|
|
who textual-input-port st 0 count count)])
|
|
(if (eof-object? n) n (string-truncate! st n))))
|
|
(let ([get-some (port-handler-get-some ($port-handler textual-input-port))])
|
|
(let loop ([count count]
|
|
[size 0]
|
|
[next-block-index 0]
|
|
[next-block (make-string buffer-size)]
|
|
[blocks '()])
|
|
(let ([next-size (get-some who textual-input-port
|
|
next-block next-block-index
|
|
(fxmin count (fx- buffer-size next-block-index)))])
|
|
(if (or (eof-object? next-size) (eq? next-size 0))
|
|
(if (eqv? size 0)
|
|
(if (eof-object? next-size) (eof-object) "")
|
|
(append-blocks size next-block-index next-block blocks))
|
|
(let ([count (fx- count next-size)]
|
|
[size (fx+ size next-size)]
|
|
[next-block-index (fx+ next-block-index next-size)])
|
|
(if (eqv? count 0)
|
|
(append-blocks size next-block-index next-block blocks)
|
|
(if (fx>= next-block-index (fxquotient buffer-size 2))
|
|
(loop count size 0
|
|
(make-string buffer-size)
|
|
(cons (cons next-block-index next-block) blocks))
|
|
(loop count size next-block-index next-block blocks))))))))))))
|
|
|
|
(set-who! get-string-n!
|
|
(lambda (textual-input-port st start count)
|
|
(unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
|
|
($oops who "~s is not a textual input port" textual-input-port))
|
|
(unless (string? st)
|
|
($oops who "~s is not a string" st))
|
|
(unless (and (fixnum? start) (fx>= start 0))
|
|
($oops who "invalid start value ~s" start))
|
|
(unless (and (fixnum? count) (fx>= count 0))
|
|
($oops who "invalid count ~s" count))
|
|
(unless (fx<= count (fx- (string-length st) start)) ; avoid overflow
|
|
($oops who "index ~s + count ~s is beyond the end of ~s" start count st))
|
|
(get-string-min-max who textual-input-port st start count count)))
|
|
|
|
(set-who! get-string-some
|
|
(lambda (textual-input-port)
|
|
(unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
|
|
($oops who "~s is not a textual input port" textual-input-port))
|
|
(let ([buffer-size (file-buffer-size)])
|
|
(let ([st (make-string buffer-size)])
|
|
(let ([n (get-string-min-max who textual-input-port st 0 0 buffer-size)])
|
|
(if (eof-object? n)
|
|
(eof-object)
|
|
(string-truncate! st n)))))))
|
|
|
|
(set-who! get-string-some!
|
|
(lambda (textual-input-port st start count)
|
|
(unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
|
|
($oops who "~s is not a textual input port" textual-input-port))
|
|
(unless (string? st)
|
|
($oops who "~s is not a string" st))
|
|
(unless (and (fixnum? start) (fx>= start 0))
|
|
($oops who "invalid start value ~s" start))
|
|
(unless (and (fixnum? count) (fx>= count 0))
|
|
($oops who "invalid count ~s" count))
|
|
(unless (fx<= count (fx- (string-length st) start)) ; avoid overflow
|
|
($oops who "index ~s + count ~s is beyond the end of ~s" start count st))
|
|
(get-string-min-max who textual-input-port st start 0 count)))
|
|
|
|
(set-who! get-string-all
|
|
(lambda (textual-input-port)
|
|
(unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
|
|
($oops who "~s is not a textual input port" textual-input-port))
|
|
($get-string-all who textual-input-port)))
|
|
|
|
(set-who! bytevector->string
|
|
(lambda (bv tx)
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(unless ($transcoder? tx)
|
|
($oops who "~s is not a transcoder" tx))
|
|
(let ([str ($get-string-all who (open-bytevector-input-port bv tx))])
|
|
(if (eof-object? str) "" str))))
|
|
)
|
|
|
|
(set-who! get-line
|
|
(lambda (tp)
|
|
(unless (and (input-port? tp) (textual-port? tp))
|
|
($oops who "~s is not a textual input port" tp))
|
|
(let f ([n 0])
|
|
(let ([c (get-char tp)])
|
|
(cond
|
|
[(eof-object? c) (if (fx= n 0) c (begin (unget-char tp c) (make-string n)))]
|
|
[(char=? c #\newline) (make-string n)]
|
|
[else (let ([s (f (fx+ n 1))]) (string-set! s n c) s)])))))
|
|
|
|
;; get-datum in read.ss
|
|
|
|
;;;; 8.2.10 Output ports
|
|
;; output-port? in prims.ss
|
|
(let ()
|
|
(define who 'flush-output-port)
|
|
(define flush-help
|
|
(lambda (output-port)
|
|
(call-port-handler flush who output-port)))
|
|
(define flush-check-help
|
|
(lambda (output-port)
|
|
(unless (output-port? output-port)
|
|
($oops who "~s is not an output port" output-port))
|
|
(flush-help output-port)))
|
|
(set! flush-output-port
|
|
(case-lambda
|
|
[() (flush-help (current-output-port))]
|
|
[(output-port) (flush-check-help output-port)]))
|
|
(set! r6rs:flush-output-port
|
|
(rec flush-output-port
|
|
(lambda (output-port)
|
|
(flush-check-help output-port)))))
|
|
|
|
; input-port-buffer-mode isn't required by r6rs but would be essentially
|
|
; the same code. if anything, it would be even more useless.
|
|
(set-who! output-port-buffer-mode
|
|
(lambda (output-port)
|
|
(unless (output-port? output-port)
|
|
($oops who "~s is not an output port" output-port))
|
|
(cond
|
|
[($port-flags-set? output-port (constant port-flag-block-buffered))
|
|
(buffer-mode block)]
|
|
[($port-flags-set? output-port (constant port-flag-line-buffered))
|
|
(buffer-mode line)]
|
|
[else (buffer-mode none)])))
|
|
|
|
;; open-file-output-port
|
|
(let ()
|
|
(define open-binary-file-output-port
|
|
(lambda (who filename options perms b-mode)
|
|
(let ([no-create (enum-set-subset? (file-options no-create) options)]
|
|
[no-fail (enum-set-subset? (file-options no-fail) options)]
|
|
[no-truncate (enum-set-subset? (file-options no-truncate) options)]
|
|
[append (enum-set-subset? (file-options append) options)]
|
|
[lock (enum-set-subset? (file-options exclusive) options)]
|
|
[replace (enum-set-subset? (file-options replace) options)]
|
|
[compressed (enum-set-subset? (file-options compressed) options)])
|
|
(when (and compressed lock)
|
|
($oops who "exclusive option is not supported with compress option"))
|
|
(when-feature windows
|
|
(unless-feature pthreads
|
|
; try to work around windows file open semantics by trying
|
|
; to close any open ports to the file if we cannot delete it
|
|
; without doing so.
|
|
(when replace
|
|
(delete-file filename #f)
|
|
(when (file-exists? filename)
|
|
(collect (collect-maximum-generation))))))
|
|
(let ([fd (critical-section
|
|
($open-output-fd filename perms
|
|
no-create no-fail no-truncate
|
|
append lock replace compressed))])
|
|
(when (pair? fd) (open-oops who filename options fd))
|
|
(open-binary-fd-output-port who filename fd #t b-mode lock compressed)))))
|
|
|
|
(define help-open-file-output-port
|
|
(lambda (who filename options perms b-mode maybe-transcoder)
|
|
(let ([bp (open-binary-file-output-port who filename options perms b-mode)])
|
|
(if maybe-transcoder
|
|
(transcoded-port bp maybe-transcoder)
|
|
bp))))
|
|
|
|
(define open-binary-standard-output-port
|
|
(lambda (who fd name b-mode)
|
|
(unless (buffer-mode? b-mode)
|
|
($oops who "~s is not a valid buffer mode" b-mode))
|
|
(open-binary-fd-output-port who name (make-fd fd) ($fd-regular? fd) b-mode #f #f)))
|
|
|
|
(set-who! open-file-output-port
|
|
(rec open-file-output-port
|
|
(case-lambda
|
|
[(filename) (open-file-output-port filename (file-options))]
|
|
[(filename options) (open-file-output-port filename options (buffer-mode block))]
|
|
[(filename options b-mode) (open-file-output-port filename options b-mode #f)]
|
|
[(filename options b-mode maybe-transcoder)
|
|
(unless (string? filename) ($oops who "~s is not a string" filename))
|
|
(unless (and (enum-set? options) (enum-set-subset? options $file-options))
|
|
($oops who "~s is not a file-options object" options))
|
|
(unless (buffer-mode? b-mode)
|
|
($oops who "~s is not a valid buffer mode" b-mode))
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(help-open-file-output-port who filename options
|
|
(extract-permission-mask options) b-mode maybe-transcoder)])))
|
|
|
|
(set! $open-file-output-port
|
|
(rec $open-file-output-port
|
|
(case-lambda
|
|
[(who filename) ($open-file-output-port who filename (file-options))]
|
|
[(who filename options) ($open-file-output-port who filename options (buffer-mode block))]
|
|
[(who filename options b-mode) ($open-file-output-port who filename options b-mode #f)]
|
|
[(who filename options b-mode maybe-transcoder)
|
|
(unless (string? filename) ($oops who "~s is not a string" filename))
|
|
(unless (and (enum-set? options) (enum-set-subset? options $file-options))
|
|
($oops who "~s is not a file-options object" options))
|
|
(unless (buffer-mode? b-mode)
|
|
($oops who "~s is not a valid buffer mode" b-mode))
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(help-open-file-output-port who filename options
|
|
(extract-permission-mask options) b-mode maybe-transcoder)])))
|
|
|
|
(set-who! open-fd-output-port
|
|
(case-lambda
|
|
[(fd)
|
|
(unless (and (fixnum? fd) (fx>= fd 0))
|
|
($oops who "~s is not a file descriptor" fd))
|
|
(open-binary-fd-output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) (buffer-mode block) #f #f)]
|
|
[(fd buffer-mode)
|
|
(unless (and (fixnum? fd) (fx>= fd 0))
|
|
($oops who "~s is not a file descriptor" fd))
|
|
(unless (buffer-mode? buffer-mode)
|
|
($oops who "~s is not a buffer mode" buffer-mode))
|
|
(open-binary-fd-output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f #f)]
|
|
[(fd buffer-mode maybe-transcoder)
|
|
(unless (and (fixnum? fd) (fx>= fd 0))
|
|
($oops who "~s is not a file descriptor" fd))
|
|
(unless (buffer-mode? buffer-mode)
|
|
($oops who "~s is not a buffer mode" buffer-mode))
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(let ([bp (open-binary-fd-output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f #f)])
|
|
(if maybe-transcoder
|
|
(transcoded-port bp maybe-transcoder)
|
|
bp))]))
|
|
|
|
(set-who! standard-output-port
|
|
(case-lambda
|
|
[() (open-binary-standard-output-port who 1 "stdout" (buffer-mode line))]
|
|
[(b-mode) (open-binary-standard-output-port who 1 "stdout" b-mode)]
|
|
[(b-mode maybe-transcoder)
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(let ([binary-port (open-binary-standard-output-port who 1 "stdout" b-mode)])
|
|
(if maybe-transcoder
|
|
(transcoded-port binary-port maybe-transcoder)
|
|
binary-port))]))
|
|
|
|
(set-who! r6rs:standard-output-port
|
|
(rec standard-output-port
|
|
(lambda ()
|
|
(open-binary-standard-output-port who 1 "stdout" (buffer-mode line)))))
|
|
|
|
(set-who! standard-error-port
|
|
(case-lambda
|
|
[() (open-binary-standard-output-port who 2 "stderr" (buffer-mode none))]
|
|
[(b-mode) (open-binary-standard-output-port who 2 "stderr" b-mode)]
|
|
[(b-mode maybe-transcoder)
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(let ([binary-port (open-binary-standard-output-port who 2 "stderr" b-mode)])
|
|
(if maybe-transcoder
|
|
(transcoded-port binary-port maybe-transcoder)
|
|
binary-port))]))
|
|
|
|
(set-who! r6rs:standard-error-port
|
|
(rec standard-error-port
|
|
(lambda ()
|
|
(open-binary-standard-output-port who 2 "stderr" (buffer-mode none)))))
|
|
|
|
; simple i/o routines here to share helpers
|
|
(let ()
|
|
(define (oof who s o)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(let ([o (if (list? o) o (list o))])
|
|
(let loop ([o o] [ifexists #f] [mode #o666] [zmode #f] [xmode #f] [bmode #f])
|
|
(if (null? o)
|
|
(help-open-file-output-port who s
|
|
(enum-set-union
|
|
(enum-set-union
|
|
(case ifexists
|
|
[(error) (file-options)]
|
|
[(truncate) (file-options no-fail)]
|
|
[(replace) (file-options no-fail no-truncate replace)]
|
|
[(append) (file-options append no-fail no-truncate)]
|
|
[else (file-options)])
|
|
(if (eq? zmode 'compressed) (file-options compressed) (file-options)))
|
|
(if (eq? xmode 'exclusive) (file-options exclusive) (file-options)))
|
|
mode
|
|
(if (eq? bmode 'unbuffered) (buffer-mode none) (buffer-mode block))
|
|
(current-transcoder))
|
|
(case (car o)
|
|
[(error truncate replace append)
|
|
(check-option who ifexists (car o))
|
|
(loop (cdr o) (car o) mode zmode xmode bmode)]
|
|
[(compressed uncompressed)
|
|
(check-option who zmode (car o))
|
|
(loop (cdr o) ifexists mode (car o) xmode bmode)]
|
|
[(buffered unbuffered)
|
|
(check-option who bmode (car o))
|
|
(loop (cdr o) ifexists mode zmode xmode (car o))]
|
|
[(exclusive nonexclusive)
|
|
(check-option who xmode (car o))
|
|
(loop (cdr o) ifexists mode zmode (car o) bmode)]
|
|
[(mode)
|
|
(if (null? (cdr o))
|
|
($oops who "mode option requires an argument")
|
|
(let ([mode (cadr o)])
|
|
(if (and (fixnum? mode) (fx>= mode 0))
|
|
(loop (cddr o) ifexists mode zmode xmode bmode)
|
|
($oops who "mode argument must be a nonnegative fixnum"))))]
|
|
[else ($oops who "invalid option ~s" (car o))])))))
|
|
|
|
(set-who! #(r6rs: open-output-file)
|
|
(lambda (s) (oof who s '())))
|
|
|
|
(set-who! open-output-file
|
|
(case-lambda
|
|
[(s) (oof who s '())]
|
|
[(s o) (oof who s o)]))
|
|
|
|
(let ()
|
|
(define (cwof who s f o)
|
|
(unless (procedure? f)
|
|
($oops who "~s is not a procedure" f))
|
|
(let ([p (oof who s o)])
|
|
(call-with-values
|
|
(lambda () (f p))
|
|
(lambda args
|
|
(close-output-port p)
|
|
(apply values args)))))
|
|
(set-who! #(r6rs: call-with-output-file)
|
|
(lambda (s f) (cwof who s f '())))
|
|
(set-who! call-with-output-file
|
|
(case-lambda
|
|
[(s f) (cwof who s f '())]
|
|
[(s f o) (cwof who s f o)])))
|
|
|
|
(let ()
|
|
(define (wotf who s f o)
|
|
(unless (procedure? f)
|
|
($oops who "~s is not a procedure" f))
|
|
(let ([p (oof who s o)])
|
|
(call-with-values
|
|
(lambda () (parameterize ([current-output-port p]) (f)))
|
|
(lambda v
|
|
(close-output-port p)
|
|
(apply values v)))))
|
|
(set-who! #(r6rs: with-output-to-file)
|
|
(lambda (s f) (wotf who s f '())))
|
|
(set-who! with-output-to-file
|
|
(case-lambda
|
|
[(s f) (wotf who s f '())]
|
|
[(s f o) (wotf who s f o)]))))
|
|
|
|
)
|
|
|
|
;; open-bytevector-output-port
|
|
(let ()
|
|
;; if info-index != index, there was put/put-some after last set-pos
|
|
;; and (max info-length index) is true length
|
|
;; if info-index == index, there was set-pos after last put/put-some
|
|
;; and info-length is true length
|
|
|
|
;; Invariant: info-index <= index
|
|
;; Invariant: size = (max length index)
|
|
;; Invariant: if no put/put-some after last set-pos/set-length,
|
|
;; then info-index = index and true length = info-length
|
|
;; Invariant: if put/put-some after last set-pos/set-length,
|
|
;; then info-index < index and true length = max info-length index
|
|
|
|
;; It is always safe to increment index when count != 0
|
|
;; It is always safe to write at index when count != 0
|
|
;; Index always contains the current position
|
|
;; The only operation that needs to decrement index is set-position
|
|
;; which needs to set info-index anyway
|
|
|
|
(define-record-type bytevector-output-port-info
|
|
(nongenerative)
|
|
(opaque #t)
|
|
(sealed #t)
|
|
(fields
|
|
(mutable index)
|
|
(mutable length)
|
|
(mutable nonblocking)))
|
|
|
|
;; NOTE: leaves index at 0, callers must reset index if needed
|
|
(define (extend-buffer p count)
|
|
(let ([old-size (binary-port-output-size p)]
|
|
[old-buffer (binary-port-output-buffer p)]
|
|
[old-index (binary-port-output-index p)])
|
|
(let* ([new-length (fxmax bytevector-buffer-length
|
|
(fx* 2 (fx+ old-size count)))]
|
|
[new-buffer (make-bytevector new-length)])
|
|
(bytevector-copy! old-buffer 0 new-buffer 0
|
|
(fxmin (bytevector-length old-buffer) old-size))
|
|
(set-binary-port-output-buffer! p new-buffer))))
|
|
|
|
(define port-length
|
|
(lambda (who p)
|
|
(let ([info ($port-info p)]
|
|
[index (binary-port-output-index p)])
|
|
(let ([info-index (bytevector-output-port-info-index info)]
|
|
[info-length (bytevector-output-port-info-length info)])
|
|
(if (eq? index info-index)
|
|
info-length ;; last op was set-pos
|
|
(max index info-length)))))) ;; last op was put
|
|
|
|
(define $bytevector-output-handler
|
|
(make-port-handler
|
|
[ready? #f]
|
|
[lookahead #f]
|
|
[unget #f]
|
|
[get #f]
|
|
[get-some #f]
|
|
[clear-input #f]
|
|
[put
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(let ([index (binary-port-output-index p)])
|
|
(when (port-output-full? p) (extend-buffer p 0))
|
|
(bytevector-u8-set! (binary-port-output-buffer p) index x)
|
|
(set-binary-port-output-index! p (fx1+ index))))]
|
|
[put-some
|
|
(lambda (who p bv start count)
|
|
(assert-not-closed who p)
|
|
(let ([index (binary-port-output-index p)])
|
|
(when ($fxu< (binary-port-output-count p) count) (extend-buffer p count))
|
|
(bytevector-copy! bv start
|
|
(binary-port-output-buffer p) index count)
|
|
(set-binary-port-output-index! p (fx+ index count)))
|
|
count)]
|
|
[flush ; no-op on bytevector output ports
|
|
(lambda (who p)
|
|
(assert-not-closed who p))]
|
|
[clear-output ; no-op on bytevector output ports
|
|
(lambda (who p)
|
|
(assert-not-closed who p))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
; sync info-index for possible post-close extraction
|
|
(let ([info ($port-info p)] [index (binary-port-output-index p)])
|
|
(unless (eq? index (bytevector-output-port-info-index info))
|
|
(bytevector-output-port-info-length-set! info
|
|
(fxmax index (bytevector-output-port-info-length info)))))
|
|
(mark-port-closed! p)
|
|
(set-binary-port-output-size! p 0)))]
|
|
[port-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-port-output-index p))]
|
|
[set-port-position!
|
|
(lambda (who p pos)
|
|
(assert-not-closed who p)
|
|
(unless (and (fixnum? pos) (fx>= pos 0))
|
|
(if (and (bignum? pos) (>= pos 0))
|
|
(position-oops who p pos "out of range")
|
|
($oops who "~s is not a valid position" pos)))
|
|
(let ([info ($port-info p)]
|
|
[index (binary-port-output-index p)])
|
|
; unless last op was set-pos, save the true length
|
|
(unless (eq? index (bytevector-output-port-info-index info))
|
|
(bytevector-output-port-info-length-set! info
|
|
(fxmax index (bytevector-output-port-info-length info))))
|
|
(set-binary-port-output-size! p
|
|
(fxmax pos (fx1- (bytevector-length (binary-port-output-buffer p)))))
|
|
(set-binary-port-output-index! p pos)
|
|
(bytevector-output-port-info-index-set! info pos)))]
|
|
[port-length
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(port-length who p))]
|
|
[set-port-length!
|
|
(lambda (who p pos)
|
|
(unless (and (fixnum? pos) (fx>= pos 0))
|
|
(if (and (bignum? pos) (>= pos 0))
|
|
(position-oops who p pos "out of range")
|
|
($oops who "~s is not a valid length" pos)))
|
|
(assert-not-closed who p)
|
|
(let ([info ($port-info p)]
|
|
[index (binary-port-output-index p)]
|
|
[size (binary-port-output-size p)])
|
|
;; ensure the bytevector is long enough
|
|
(let ([buflen-1 (fx1- (bytevector-length (binary-port-output-buffer p)))])
|
|
(when ($fxu< buflen-1 pos)
|
|
(extend-buffer p (fx- pos buflen-1))
|
|
(set-binary-port-output-index! p index)))
|
|
;; make it look like a set-pos was done last
|
|
;; (i.e. index might be beyond true length)
|
|
(bytevector-output-port-info-index-set! info index)
|
|
;; set the true length
|
|
(bytevector-output-port-info-length-set! info pos)))]
|
|
[port-nonblocking?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(bytevector-output-port-info-nonblocking ($port-info p)))]
|
|
[set-port-nonblocking!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(bytevector-output-port-info-nonblocking-set! ($port-info p) x))]))
|
|
|
|
(define extractor
|
|
(lambda (p)
|
|
(let ([old-buffer
|
|
(bytevector-truncate!
|
|
(binary-port-output-buffer p)
|
|
(port-length #f p))])
|
|
(set-binary-port-output-buffer! p #vu8())
|
|
(let ([info ($port-info p)])
|
|
(bytevector-output-port-info-index-set! info 0)
|
|
(bytevector-output-port-info-length-set! info 0))
|
|
old-buffer)))
|
|
|
|
(define open-binary-bytevector-output-port
|
|
(lambda ()
|
|
(let ([p ($make-binary-output-port "bytevector"
|
|
$bytevector-output-handler
|
|
#vu8()
|
|
(make-bytevector-output-port-info 0 0 #f))])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
(values
|
|
p
|
|
(lambda ()
|
|
(let ([info ($port-info p)])
|
|
(if (bytevector-output-port-info? info)
|
|
(extractor p)
|
|
; the port must have been transcoded
|
|
(begin
|
|
(flush-output-port info)
|
|
(extractor (codec-info-bp ($port-info info)))))))))))
|
|
|
|
(set-who! open-bytevector-output-port
|
|
(case-lambda
|
|
[() (open-binary-bytevector-output-port)]
|
|
[(maybe-transcoder)
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(let-values ([(binary-port extractor)
|
|
(open-binary-bytevector-output-port)])
|
|
(values
|
|
(if maybe-transcoder
|
|
(transcoded-port binary-port maybe-transcoder)
|
|
binary-port)
|
|
extractor))]))
|
|
)
|
|
|
|
;; open-bytevector-list-output-port
|
|
(let ()
|
|
(define-record-type bv-list-op-info
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(fields
|
|
(mutable nonblocking)
|
|
(mutable bv*)))
|
|
|
|
; allocate in chunk-size chunks
|
|
(define chunk-size 4096)
|
|
|
|
(define (extend-buffer p)
|
|
(let ([bv (binary-port-output-buffer p)])
|
|
(unless (eqv? bv #vu8())
|
|
(let ([info ($port-info p)])
|
|
(bv-list-op-info-bv*-set! info
|
|
(cons bv (bv-list-op-info-bv* info))))))
|
|
(set-binary-port-output-buffer! p (make-bytevector chunk-size)))
|
|
|
|
(define $bytevector-list-output-handler
|
|
(make-port-handler
|
|
[ready? #f]
|
|
[lookahead #f]
|
|
[unget #f]
|
|
[get #f]
|
|
[get-some #f]
|
|
[clear-input #f]
|
|
[put
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(when (port-output-full? p) (extend-buffer p))
|
|
(let ([index (binary-port-output-index p)])
|
|
(bytevector-u8-set! (binary-port-output-buffer p) index x)
|
|
(set-binary-port-output-index! p (fx1+ index))))]
|
|
[put-some
|
|
(lambda (who p bv start count)
|
|
(assert-not-closed who p)
|
|
(when (port-output-full? p) (extend-buffer p))
|
|
(let ([count (fxmin count (binary-port-output-count p))]
|
|
[index (binary-port-output-index p)])
|
|
(bytevector-copy! bv start (binary-port-output-buffer p) index count)
|
|
(set-binary-port-output-index! p (fx+ index count))
|
|
count))]
|
|
[flush ; no-op on bytevector output ports
|
|
(lambda (who p)
|
|
(assert-not-closed who p))]
|
|
[clear-output ; no-op on bytevector output ports
|
|
(lambda (who p)
|
|
(assert-not-closed who p))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
; sync info-index for possible post-close extraction
|
|
#;(let ([old-buffer (bytevector-truncate!
|
|
(binary-port-output-buffer p)
|
|
(binary-port-output-index p))]
|
|
[bv* (bv-list-op-info-bv* info)])
|
|
(bv-list-op-info-size-set! info
|
|
(fx+ (bytevector-length old-buffer)
|
|
(fx* (length bv*) chunk-size)))
|
|
(bv-list-op-info-bv*-set! info
|
|
(reverse (if (eq? old-buffer #vu8())
|
|
bv*
|
|
(cons old-buffer bv*)))))
|
|
(mark-port-closed! p)
|
|
(set-binary-port-output-size! p 0)))]
|
|
[port-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(fx+ (binary-port-output-index p)
|
|
(fx* (length (bv-list-op-info-bv* ($port-info p))) chunk-size)))]
|
|
[set-port-position! #f]
|
|
[port-length
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(fx+ (binary-port-output-index p)
|
|
(fx* (length (bv-list-op-info-bv* ($port-info p))) chunk-size)))]
|
|
[set-port-length! #f]
|
|
[port-nonblocking?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(bv-list-op-info-nonblocking ($port-info p)))]
|
|
[set-port-nonblocking!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(bv-list-op-info-nonblocking-set! ($port-info p) x))]))
|
|
|
|
(define extractor
|
|
(lambda (p)
|
|
(let ([info ($port-info p)])
|
|
(let ([bv (bytevector-truncate!
|
|
(binary-port-output-buffer p)
|
|
(binary-port-output-index p))]
|
|
[bv* (bv-list-op-info-bv* info)])
|
|
(let ([size (fx+ (bytevector-length bv) (fx* (length bv*) chunk-size))])
|
|
(set-binary-port-output-buffer! p #vu8())
|
|
(bv-list-op-info-bv*-set! info '())
|
|
(values (reverse (if (eqv? bv #vu8()) bv* (cons bv bv*))) size))))))
|
|
|
|
(set-who! $open-bytevector-list-output-port
|
|
(lambda ()
|
|
(let ([p ($make-binary-output-port "bytevector-list"
|
|
$bytevector-list-output-handler
|
|
#vu8()
|
|
(make-bv-list-op-info #f '()))])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
(values p (lambda () (extractor p)))))))
|
|
|
|
(let ()
|
|
(define ($call-with-bytevector-output-port who proc maybe-transcoder)
|
|
(let-values ([(port extractor) (open-bytevector-output-port maybe-transcoder)])
|
|
(proc port)
|
|
(let ([bv (extractor)])
|
|
(call-port-handler close-port who port)
|
|
bv)))
|
|
|
|
(set-who! call-with-bytevector-output-port
|
|
(case-lambda
|
|
[(proc)
|
|
(unless (procedure? proc) ($oops who "~s is not a procedure" proc))
|
|
($call-with-bytevector-output-port who proc #f)]
|
|
[(proc maybe-transcoder)
|
|
(unless (procedure? proc)
|
|
($oops who "~s is not a procedure" proc))
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not a transcoder" maybe-transcoder))
|
|
($call-with-bytevector-output-port who proc maybe-transcoder)]))
|
|
|
|
(set-who! string->bytevector
|
|
(lambda (str tx)
|
|
(unless (string? str)
|
|
($oops who "~s is not a string" str))
|
|
(unless ($transcoder? tx)
|
|
($oops who "~s is not a transcoder" tx))
|
|
($call-with-bytevector-output-port who
|
|
(lambda (op) (put-string op str))
|
|
tx))))
|
|
|
|
;; open-string-output-port
|
|
(let ()
|
|
;; see open-bytevector-output-port for explanation of algorithm
|
|
|
|
(define-record-type string-output-port-info
|
|
(nongenerative)
|
|
(opaque #t)
|
|
(sealed #t)
|
|
(fields
|
|
(mutable index)
|
|
(mutable length)
|
|
(mutable nonblocking)))
|
|
|
|
;; NOTE: leaves index at 0, callers must reset index if needed
|
|
(define (extend-buffer p count)
|
|
(let ([old-size (textual-port-output-size p)]
|
|
[old-buffer (textual-port-output-buffer p)]
|
|
[old-index (textual-port-output-index p)])
|
|
(let* ([new-length (fxmax string-buffer-length
|
|
(fx* 2 (fx+ old-size count)))]
|
|
[new-buffer (make-string new-length)])
|
|
(string-copy! old-buffer 0 new-buffer 0
|
|
(fxmin (string-length old-buffer) old-size))
|
|
(set-textual-port-output-buffer! p new-buffer))))
|
|
|
|
(define port-length
|
|
(lambda (who p)
|
|
(let ([info ($port-info p)]
|
|
[index (textual-port-output-index p)])
|
|
(let ([info-index (string-output-port-info-index info)]
|
|
[info-length (string-output-port-info-length info)])
|
|
(if (eq? index info-index)
|
|
info-length ;; last op was set-pos
|
|
(max index info-length)))))) ;; last op was put
|
|
|
|
(define $string-output-handler
|
|
(make-port-handler
|
|
[ready? #f]
|
|
[lookahead #f]
|
|
[unget #f]
|
|
[get #f]
|
|
[get-some #f]
|
|
[clear-input #f]
|
|
[put
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(let ([index (textual-port-output-index p)])
|
|
(when (port-output-full? p) (extend-buffer p 0))
|
|
(string-set! (textual-port-output-buffer p) index x)
|
|
(set-textual-port-output-index! p (fx1+ index))))]
|
|
[put-some
|
|
(lambda (who p st start count)
|
|
(assert-not-closed who p)
|
|
(let ([index (textual-port-output-index p)])
|
|
(when ($fxu< (textual-port-output-count p) count) (extend-buffer p count))
|
|
(string-copy! st start
|
|
(textual-port-output-buffer p) index count)
|
|
(set-textual-port-output-index! p (fx+ index count)))
|
|
count)]
|
|
[flush ; no-op on string output ports
|
|
(lambda (who p)
|
|
(assert-not-closed who p))]
|
|
[clear-output ; no-op on string output ports
|
|
(lambda (who p)
|
|
(assert-not-closed who p))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
; sync info-index for possible post-close extraction
|
|
(let ([info ($port-info p)] [index (textual-port-output-index p)])
|
|
(unless (eq? index (string-output-port-info-index info))
|
|
(string-output-port-info-length-set! info
|
|
(fxmax index (string-output-port-info-length info)))))
|
|
(mark-port-closed! p)
|
|
(set-textual-port-output-size! p 0)))]
|
|
[port-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-port-output-index p))]
|
|
[set-port-position!
|
|
(lambda (who p pos)
|
|
(assert-not-closed who p)
|
|
(unless (and (fixnum? pos) (fx>= pos 0))
|
|
(if (and (bignum? pos) (>= pos 0))
|
|
(position-oops who p pos "out of range")
|
|
($oops who "~s is not a valid position" pos)))
|
|
(let ([info ($port-info p)]
|
|
[index (textual-port-output-index p)])
|
|
; unless last op was set-pos, save the true length
|
|
(unless (eq? index (string-output-port-info-index info))
|
|
(string-output-port-info-length-set! info
|
|
(fxmax index (string-output-port-info-length info))))
|
|
(set-textual-port-output-size! p
|
|
(fxmax pos (fx1- (string-length (textual-port-output-buffer p)))))
|
|
(set-textual-port-output-index! p pos)
|
|
(string-output-port-info-index-set! info pos)))]
|
|
[port-length
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(port-length who p))]
|
|
[set-port-length!
|
|
(lambda (who p pos)
|
|
(unless (and (fixnum? pos) (fx>= pos 0))
|
|
(if (and (bignum? pos) (>= pos 0))
|
|
(position-oops who p pos "out of range")
|
|
($oops who "~s is not a valid length" pos)))
|
|
(assert-not-closed who p)
|
|
(let ([info ($port-info p)]
|
|
[index (textual-port-output-index p)]
|
|
[size (textual-port-output-size p)])
|
|
;; ensure the bytevector is long enough
|
|
(let ([buflen-1 (fx1- (string-length (textual-port-output-buffer p)))])
|
|
(when ($fxu< buflen-1 pos)
|
|
(extend-buffer p (fx- pos buflen-1))
|
|
(set-textual-port-output-index! p index)))
|
|
;; make it look like a set-pos was done last
|
|
;; (i.e. index might be beyond true length)
|
|
(string-output-port-info-index-set! info index)
|
|
;; set the true length
|
|
(string-output-port-info-length-set! info pos)))]
|
|
[port-nonblocking?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(string-output-port-info-nonblocking ($port-info p)))]
|
|
[set-port-nonblocking!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(string-output-port-info-nonblocking-set! ($port-info p) x))]))
|
|
|
|
(define ($open-string-output-port)
|
|
(let ([p ($make-textual-output-port "string"
|
|
$string-output-handler
|
|
""
|
|
(make-string-output-port-info 0 0 #f))])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
($set-port-flags! p (constant port-flag-char-positions))
|
|
($set-port-flags! p (constant port-flag-bol))
|
|
p))
|
|
|
|
(define ($get-output-string p)
|
|
(let ([old-buffer
|
|
(string-truncate!
|
|
(textual-port-output-buffer p)
|
|
(port-length #f p))])
|
|
(set-textual-port-output-buffer! p "")
|
|
(let ([info ($port-info p)])
|
|
(string-output-port-info-index-set! info 0)
|
|
(string-output-port-info-length-set! info 0))
|
|
old-buffer))
|
|
|
|
(set-who! open-string-output-port
|
|
(lambda ()
|
|
(let ([p ($open-string-output-port)])
|
|
(values p (lambda () ($get-output-string p))))))
|
|
|
|
(set-who! open-output-string
|
|
(lambda ()
|
|
($open-string-output-port)))
|
|
|
|
(set-who! get-output-string
|
|
(lambda (p)
|
|
(unless (and (port? p) (eq? ($port-handler p) $string-output-handler))
|
|
($oops who "~s is not a string output port" p))
|
|
($get-output-string p)))
|
|
)
|
|
|
|
|
|
(set-who! call-with-string-output-port
|
|
(lambda (proc)
|
|
(unless (procedure? proc)
|
|
($oops who "~s is not a procedure" proc))
|
|
(let-values ([(port extractor) (open-string-output-port)])
|
|
(proc port)
|
|
(let ([st (extractor)])
|
|
(call-port-handler close-port who port)
|
|
st))))
|
|
|
|
;; current-output-port and current-error-port are in prims.ss
|
|
|
|
(set-who! make-custom-binary-output-port
|
|
(lambda (id write! get-position set-position! close)
|
|
(unless (string? id) ($oops who "~s is not a string" id))
|
|
(unless (procedure? write!) ($oops who "~s is not a procedure" write!))
|
|
(unless (or (not get-position) (procedure? get-position))
|
|
($oops who "~s is not a procedure or #f" get-position))
|
|
(unless (or (not set-position!) (procedure? set-position!))
|
|
($oops who "~s is not a procedure or #f" set-position!))
|
|
(unless (or (not close) (procedure? close))
|
|
($oops who "~s is not a procedure or #f" close))
|
|
(let ([handler
|
|
(make-port-handler
|
|
[ready? #f]
|
|
[lookahead #f]
|
|
[unget #f]
|
|
[get #f]
|
|
[get-some #f]
|
|
[clear-input #f]
|
|
[put
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-put who p write! x))]
|
|
[put-some
|
|
(lambda (who p bv start count)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-put-some who p write! bv start count))]
|
|
[flush
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-flush who p write!))]
|
|
[clear-output
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-clear-output who p))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
(binary-custom-port-flush who p write!)
|
|
(binary-custom-port-close-port who p close)))]
|
|
[port-position
|
|
(and get-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-port-position out who p get-position)))]
|
|
[set-port-position!
|
|
(and set-position!
|
|
(lambda (who p x)
|
|
(unless (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
|
|
($oops who "~s is not a valid position" x))
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-flush who p write!)
|
|
(set-position! x)))]
|
|
[port-length #f]
|
|
[set-port-length! #f]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f])])
|
|
(let ([bufsiz (custom-port-buffer-size)])
|
|
(let ([p ($make-binary-output-port id handler (make-bytevector bufsiz) #f)])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
(set-binary-port-output-size! p (fx1- bufsiz)) ;; leave room for put to work
|
|
p)))))
|
|
|
|
(set-who! make-custom-textual-output-port
|
|
(lambda (id write! get-position set-position! close)
|
|
(unless (string? id) ($oops who "~s is not a string" id))
|
|
(unless (procedure? write!) ($oops who "~s is not a procedure" write!))
|
|
(unless (or (not get-position) (procedure? get-position))
|
|
($oops who "~s is not a procedure or #f" get-position))
|
|
(unless (or (not set-position!) (procedure? set-position!))
|
|
($oops who "~s is not a procedure or #f" set-position!))
|
|
(unless (or (not close) (procedure? close))
|
|
($oops who "~s is not a procedure or #f" close))
|
|
(let ([handler
|
|
(make-port-handler
|
|
[ready? #f]
|
|
[lookahead #f]
|
|
[unget #f]
|
|
[get #f]
|
|
[get-some #f]
|
|
[clear-input #f]
|
|
[put
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-put who p write! x))]
|
|
[put-some
|
|
(lambda (who p str start count)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-put-some who p write! str start count))]
|
|
[flush
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-flush who p write!))]
|
|
[clear-output
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-clear-output who p))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
(textual-custom-port-flush who p write!)
|
|
(textual-custom-port-close-port who p close)))]
|
|
[port-position
|
|
(and get-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-flush who p write!)
|
|
(get-position)))]
|
|
[set-port-position!
|
|
(and set-position!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-flush who p write!)
|
|
(set-position! x)))]
|
|
[port-length #f]
|
|
[set-port-length! #f]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f])])
|
|
(let ([bufsiz (custom-port-buffer-size)])
|
|
(let ([p ($make-textual-output-port id handler (make-string bufsiz) #f)])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
($set-port-flags! p (constant port-flag-bol))
|
|
(set-textual-port-output-size! p (fx1- bufsiz)) ;; leave room for put to work
|
|
p)))))
|
|
|
|
|
|
;;;; 8.2.11 Binary output
|
|
;; put-u8 in prims.ss
|
|
|
|
(set-who! put-bytevector
|
|
(case-lambda
|
|
[(binary-output-port bv)
|
|
(unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
|
|
($oops who "~s is not a binary output port" binary-output-port))
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(#3%put-bytevector binary-output-port bv)]
|
|
[(binary-output-port bv start)
|
|
(unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
|
|
($oops who "~s is not a binary output port" binary-output-port))
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(unless (and (fixnum? start) (not ($fxu< (bytevector-length bv) start)))
|
|
($oops who "invalid start value ~s" start))
|
|
(#3%put-bytevector binary-output-port bv start)]
|
|
[(binary-output-port bv start count)
|
|
(unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
|
|
($oops who "~s is not a binary output port" binary-output-port))
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(unless (and (fixnum? start) (fx<= 0 start))
|
|
($oops who "invalid start value ~s" start))
|
|
(unless (and (fixnum? count) (fx<= 0 count))
|
|
($oops who "invalid count ~s" count))
|
|
(unless (fx<= count (fx- (bytevector-length bv) start)) ; avoid overflow
|
|
($oops who "index ~s + count ~s is beyond the end of ~s" start count bv))
|
|
(#3%put-bytevector binary-output-port bv start count)]))
|
|
|
|
;; not in R6RS
|
|
(set-who! put-bytevector-some
|
|
(case-lambda
|
|
[(binary-output-port bv)
|
|
(unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
|
|
($oops who "~s is not a binary output port" binary-output-port))
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(#3%put-bytevector-some binary-output-port bv)]
|
|
[(binary-output-port bv start)
|
|
(unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
|
|
($oops who "~s is not a binary output port" binary-output-port))
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(unless (and (fixnum? start) (not ($fxu< (bytevector-length bv) start)))
|
|
($oops who "invalid start value ~s" start))
|
|
(#3%put-bytevector-some binary-output-port bv start)]
|
|
[(binary-output-port bv start count)
|
|
(unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
|
|
($oops who "~s is not a binary output port" binary-output-port))
|
|
(unless (bytevector? bv)
|
|
($oops who "~s is not a bytevector" bv))
|
|
(unless (and (fixnum? start) (fx<= 0 start))
|
|
($oops who "invalid start value ~s" start))
|
|
(unless (and (fixnum? count) (fx<= 0 count))
|
|
($oops who "invalid count ~s" count))
|
|
(unless (fx<= count (fx- (bytevector-length bv) start)) ; avoid overflow
|
|
($oops who "index ~s + count ~s is beyond the end of ~s" start count bv))
|
|
(#3%put-bytevector-some binary-output-port bv start count)]))
|
|
|
|
;;;; 8.2.12 Textual output
|
|
;; put-char in prims.ss
|
|
|
|
(set-who! put-string
|
|
(case-lambda
|
|
[(textual-output-port str)
|
|
(unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
|
|
($oops who "~s is not a textual output port" textual-output-port))
|
|
(unless (string? str)
|
|
($oops who "~s is not a string" str))
|
|
(#3%put-string textual-output-port str)]
|
|
[(textual-output-port str start)
|
|
(unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
|
|
($oops who "~s is not a textual output port" textual-output-port))
|
|
(unless (string? str)
|
|
($oops who "~s is not a string" str))
|
|
(unless (and (fixnum? start) (not ($fxu< (string-length str) start)))
|
|
($oops who "invalid start value ~s" start))
|
|
(#3%put-string textual-output-port str start)]
|
|
[(textual-output-port str start count)
|
|
(unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
|
|
($oops who "~s is not a textual output port" textual-output-port))
|
|
(unless (string? str)
|
|
($oops who "~s is not a string" str))
|
|
(unless (and (fixnum? start) (fx<= 0 start))
|
|
($oops who "invalid start value ~s" start))
|
|
(unless (and (fixnum? count) (fx<= 0 count))
|
|
($oops who "invalid count value ~s" count))
|
|
(unless (fx<= count (fx- (string-length str) start)) ; avoid overflow
|
|
($oops who "index ~s + count ~s is beyond the end of ~s" start count str))
|
|
(#3%put-string textual-output-port str start count)]))
|
|
|
|
;; not in R6RS
|
|
(set-who! put-string-some
|
|
(case-lambda
|
|
[(textual-output-port str)
|
|
(unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
|
|
($oops who "~s is not a textual output port" textual-output-port))
|
|
(unless (string? str)
|
|
($oops who "~s is not a string" str))
|
|
(#3%put-string-some textual-output-port str)]
|
|
[(textual-output-port str start)
|
|
(unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
|
|
($oops who "~s is not a textual output port" textual-output-port))
|
|
(unless (string? str)
|
|
($oops who "~s is not a string" str))
|
|
(unless (and (fixnum? start) (not ($fxu< (string-length str) start)))
|
|
($oops who "invalid start value ~s" start))
|
|
(#3%put-string-some textual-output-port str start)]
|
|
[(textual-output-port str start count)
|
|
(unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
|
|
($oops who "~s is not a textual output port" textual-output-port))
|
|
(unless (string? str)
|
|
($oops who "~s is not a string" str))
|
|
(unless (and (fixnum? start) (fx<= 0 start))
|
|
($oops who "invalid start value ~s" start))
|
|
(unless (and (fixnum? count) (fx<= 0 count))
|
|
($oops who "invalid count value ~s" count))
|
|
(unless (fx<= count (fx- (string-length str) start)) ; avoid overflow
|
|
($oops who "index ~s + count ~s is beyond the end of ~s" start count str))
|
|
(#3%put-string-some textual-output-port str start count)]))
|
|
|
|
;; put-datum in print.ss
|
|
|
|
;;;; 8.2.13 Input/output ports
|
|
;; open-file-input/output-port
|
|
(let ()
|
|
(define open-binary-file-input/output-port
|
|
(lambda (who filename options perms b-mode)
|
|
(let ([no-create (enum-set-subset? (file-options no-create) options)]
|
|
[no-fail (enum-set-subset? (file-options no-fail) options)]
|
|
[no-truncate (enum-set-subset? (file-options no-truncate) options)]
|
|
[append (enum-set-subset? (file-options append) options)]
|
|
[lock (enum-set-subset? (file-options exclusive) options)]
|
|
[replace (enum-set-subset? (file-options replace) options)]
|
|
[compressed (enum-set-subset? (file-options compressed) options)])
|
|
(when (and compressed lock)
|
|
($oops who "exclusive option is not supported with compress option"))
|
|
(when-feature windows
|
|
(unless-feature pthreads
|
|
; try to work around windows file open semantics by trying
|
|
; to close any open ports to the file if we cannot delete it
|
|
; without doing so.
|
|
(when replace
|
|
(delete-file filename #f)
|
|
(when (file-exists? filename)
|
|
(collect (collect-maximum-generation))))))
|
|
(let ([fd (critical-section
|
|
($open-input/output-fd filename perms
|
|
no-create no-fail no-truncate
|
|
append lock replace compressed))])
|
|
(when (pair? fd) (open-oops who filename options fd))
|
|
(open-binary-fd-input/output-port who filename fd #t b-mode lock compressed)))))
|
|
|
|
(define help-open-file-input/output-port
|
|
(lambda (who filename options perms b-mode maybe-transcoder)
|
|
(let ([bp (open-binary-file-input/output-port who filename options perms b-mode)])
|
|
(if maybe-transcoder
|
|
(transcoded-port bp maybe-transcoder)
|
|
bp))))
|
|
|
|
(set-who! open-file-input/output-port
|
|
(rec open-file-input/output-port
|
|
(case-lambda
|
|
[(filename) (open-file-input/output-port filename (file-options))]
|
|
[(filename options) (open-file-input/output-port filename options (buffer-mode block))]
|
|
[(filename options b-mode) (open-file-input/output-port filename options b-mode #f)]
|
|
[(filename options b-mode maybe-transcoder)
|
|
(unless (string? filename) ($oops who "~s is not a string" filename))
|
|
(unless (and (enum-set? options) (enum-set-subset? options $file-options))
|
|
($oops who "~s is not a file-options object" options))
|
|
(unless (buffer-mode? b-mode) ($oops who "~s is not a valid buffer mode" b-mode))
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(help-open-file-input/output-port who filename options
|
|
(extract-permission-mask options) b-mode maybe-transcoder)])))
|
|
|
|
(set! $open-file-input/output-port
|
|
(rec $open-file-input/output-port
|
|
(case-lambda
|
|
[(who filename) ($open-file-input/output-port who filename (file-options))]
|
|
[(who filename options) ($open-file-input/output-port who filename options (buffer-mode block))]
|
|
[(who filename options b-mode) ($open-file-input/output-port who filename options b-mode #f)]
|
|
[(who filename options b-mode maybe-transcoder)
|
|
(unless (string? filename) ($oops who "~s is not a string" filename))
|
|
(unless (and (enum-set? options) (enum-set-subset? options $file-options))
|
|
($oops who "~s is not a file-options object" options))
|
|
(unless (buffer-mode? b-mode) ($oops who "~s is not a valid buffer mode" b-mode))
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(help-open-file-input/output-port who filename options
|
|
(extract-permission-mask options) b-mode maybe-transcoder)])))
|
|
|
|
(set-who! open-fd-input/output-port
|
|
(case-lambda
|
|
[(fd)
|
|
(unless (and (fixnum? fd) (fx>= fd 0))
|
|
($oops who "~s is not a file descriptor" fd))
|
|
(open-binary-fd-input/output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) (buffer-mode block) #f #f)]
|
|
[(fd buffer-mode)
|
|
(unless (and (fixnum? fd) (fx>= fd 0))
|
|
($oops who "~s is not a file descriptor" fd))
|
|
(unless (buffer-mode? buffer-mode)
|
|
($oops who "~s is not a buffer mode" buffer-mode))
|
|
(open-binary-fd-input/output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f #f)]
|
|
[(fd buffer-mode maybe-transcoder)
|
|
(unless (and (fixnum? fd) (fx>= fd 0))
|
|
($oops who "~s is not a file descriptor" fd))
|
|
(unless (buffer-mode? buffer-mode)
|
|
($oops who "~s is not a buffer mode" buffer-mode))
|
|
(unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
|
|
($oops who "~s is not #f or a transcoder" maybe-transcoder))
|
|
(let ([binary-port
|
|
(open-binary-fd-input/output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f #f)])
|
|
(if maybe-transcoder
|
|
(transcoded-port binary-port maybe-transcoder)
|
|
binary-port))]))
|
|
|
|
; TODO: standard-input/output-port. requires paired fds
|
|
|
|
; simple i/o routines here to share helpers
|
|
(let ()
|
|
(define (oiof who s o)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(let ([o (if (list? o) o (list o))])
|
|
(let loop ([o o] [ifexists #f] [mode #o666] [xmode #f] [bmode #f])
|
|
(if (null? o)
|
|
(help-open-file-input/output-port who s
|
|
(enum-set-union
|
|
(case ifexists
|
|
[(error) (file-options)]
|
|
[(truncate) (file-options no-fail)]
|
|
[(replace) (file-options no-fail no-truncate replace)]
|
|
[(append) (file-options append no-fail no-truncate)]
|
|
[else (file-options no-fail no-truncate)])
|
|
(if (eq? xmode 'exclusive) (file-options exclusive) (file-options)))
|
|
mode
|
|
(if (eq? bmode 'unbuffered) (buffer-mode none) (buffer-mode block))
|
|
(current-transcoder))
|
|
(case (car o)
|
|
[(error truncate replace append)
|
|
(check-option who ifexists (car o))
|
|
(loop (cdr o) (car o) mode xmode bmode)]
|
|
[(buffered unbuffered)
|
|
(check-option who bmode (car o))
|
|
(loop (cdr o) ifexists mode xmode (car o))]
|
|
[(exclusive nonexclusive)
|
|
(check-option who xmode (car o))
|
|
(loop (cdr o) ifexists mode (car o) bmode)]
|
|
[(mode)
|
|
(if (null? (cdr o))
|
|
($oops who "mode option requires an argument")
|
|
(let ([mode (cadr o)])
|
|
(if (and (fixnum? mode) (fx>= mode 0))
|
|
(loop (cddr o) ifexists mode xmode bmode)
|
|
($oops who "mode argument must be a nonnegative fixnum"))))]
|
|
[else ($oops who "invalid option ~s" (car o))])))))
|
|
(set-who! open-input-output-file
|
|
(case-lambda
|
|
[(s) (oiof who s '())]
|
|
[(s o) (oiof who s o)])))
|
|
)
|
|
|
|
;; make-custom-binary-input/output-port
|
|
(let ()
|
|
(define-syntax make-ready-for-input
|
|
(syntax-rules ()
|
|
[(_ who p_ write!)
|
|
(let ([p p_])
|
|
(unless (eq? 0 (binary-port-output-size p))
|
|
(binary-custom-port-flush who p write!)
|
|
;; don't set input-size; it is set only after a read
|
|
(set-binary-port-output-size! p 0)))]))
|
|
|
|
(module ((make-ready-for-output $make-ready-for-output))
|
|
(define $make-ready-for-output
|
|
(lambda (who p get-position set-position!)
|
|
(unless (eq? (binary-port-input-size p) 0)
|
|
(unless (port-input-empty? p)
|
|
(if (not (and get-position set-position!))
|
|
(position-warning who
|
|
(if get-position
|
|
"cannot set position for write after read on ~s"
|
|
"cannot determine position for write after read on ~s")
|
|
p)
|
|
(set-position! (- (get-position) (binary-port-input-count p)))))
|
|
(set-binary-port-input-size! p 0))
|
|
(set-port-eof! p #f)
|
|
(set-binary-port-output-size! p
|
|
(fx1- (bytevector-length (binary-port-output-buffer p))))))
|
|
|
|
(define-syntax make-ready-for-output
|
|
(syntax-rules ()
|
|
[(_ ?who ?p ?get-position ?set-position!)
|
|
(let ([p ?p])
|
|
(when (eq? (binary-port-output-size p) 0)
|
|
($make-ready-for-output ?who p ?get-position ?set-position!)))])))
|
|
|
|
;; Ports start with a non-ill-defined position.
|
|
;; Unless get-position and set-position! are provided,
|
|
;; doing a buffered read operation makes the position ill-defined.
|
|
;;
|
|
;; A put, put-some or (textual)port-position operation may give
|
|
;; unexpected results when the position is ill-defined.
|
|
;;
|
|
;; A set-port-position is sufficient to make
|
|
;; the position no longer ill-defined.
|
|
;;
|
|
;; Buffered read operations include lookahead, port-eof?, and unget.
|
|
;; Buffered read operations also include get and get-some if buffer-mode is not none.
|
|
|
|
(set-who! make-custom-binary-input/output-port
|
|
(lambda (id read! write! get-position set-position! close)
|
|
(unless (string? id) ($oops who "~s is not a string" id))
|
|
(unless (procedure? read!) ($oops who "~s is not a procedure" read!))
|
|
(unless (procedure? write!) ($oops who "~s is not a procedure" write!))
|
|
(unless (or (not get-position) (procedure? get-position))
|
|
($oops who "~s is not a procedure or #f" get-position))
|
|
(unless (or (not set-position!) (procedure? set-position!))
|
|
($oops who "~s is not a procedure or #f" set-position!))
|
|
(unless (or (not close) (procedure? close))
|
|
($oops who "~s is not a procedure or #f" close))
|
|
(let ([handler
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(or (not (port-input-empty? p))
|
|
(port-flag-eof-set? p)
|
|
(read-oops who p "cannot determine ready status")))]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(binary-custom-port-lookahead who p read!))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(binary-custom-port-unget who p x))]
|
|
[get
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(binary-custom-port-get who p read!))]
|
|
[get-some
|
|
(lambda (who p bv start count)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(binary-custom-port-get-some who p read! bv start count))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-clear-input who p))]
|
|
[put
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-output who p get-position set-position!)
|
|
(binary-custom-port-put who p write! x))]
|
|
[put-some
|
|
(lambda (who p bv start count)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-output who p get-position set-position!)
|
|
(binary-custom-port-put-some who p write! bv start count))]
|
|
[flush
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
; binary-custom-port-flush must be a no-op in input mode
|
|
(binary-custom-port-flush who p write!))]
|
|
[clear-output
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-clear-output who p))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
; binary-custom-port-flush must be a no-op in input mode
|
|
(binary-custom-port-flush who p write!)
|
|
(binary-custom-port-close-port who p close)))]
|
|
[port-position
|
|
(and get-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-port-position in/out who p get-position)))]
|
|
[set-port-position!
|
|
(and set-position!
|
|
(lambda (who p x)
|
|
(unless (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
|
|
($oops who "~s is not a valid position" x))
|
|
(assert-not-closed who p)
|
|
(binary-custom-port-flush who p write!)
|
|
(set-binary-port-input-size! p 0) ;; junk the buffer data
|
|
(set-port-eof! p #f)
|
|
(set-position! x)))]
|
|
[port-length #f]
|
|
[set-port-length! #f]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f])])
|
|
(let ([bufsiz (custom-port-buffer-size)])
|
|
(let ([p ($make-binary-input/output-port id handler
|
|
(make-bytevector bufsiz)
|
|
(make-bytevector bufsiz)
|
|
#f)])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
(set-binary-port-input-size! p 0)
|
|
(set-binary-port-output-size! p (fx1- bufsiz)) ;; leave room for put to work
|
|
p))))))
|
|
|
|
;; make-custom-textual-input/output-port
|
|
(let ()
|
|
(define-syntax make-ready-for-input
|
|
(syntax-rules ()
|
|
[(_ who p_ write!)
|
|
(let ([p p_])
|
|
(unless (eq? 0 (textual-port-output-size p))
|
|
(textual-custom-port-flush who p write!)
|
|
;; don't set input-size; it is set only after a read
|
|
(set-textual-port-output-size! p 0)))]))
|
|
|
|
(module ((make-ready-for-output $make-ready-for-output))
|
|
(define $make-ready-for-output
|
|
(lambda (who p get-position set-position!)
|
|
(unless (eq? (textual-port-input-size p) 0)
|
|
(unless (port-input-empty? p)
|
|
(position-warning who "cannot set position for write after read on ~s" p))
|
|
(set-textual-port-input-size! p 0))
|
|
(set-port-eof! p #f)
|
|
(set-textual-port-output-size! p
|
|
(fx1- (string-length (textual-port-output-buffer p))))))
|
|
|
|
(define-syntax make-ready-for-output
|
|
(syntax-rules ()
|
|
[(_ ?who ?p ?get-position ?set-position!)
|
|
(let ([p ?p])
|
|
(when (eq? (textual-port-output-size p) 0)
|
|
($make-ready-for-output ?who p ?get-position ?set-position!)))])))
|
|
|
|
;; Ports start with a non-ill-defined position.
|
|
;; Unless get-position and set-position! are provided,
|
|
;; doing a buffered read operation makes the position ill-defined.
|
|
;;
|
|
;; A put, put-some or (textual)port-position operation may give
|
|
;; unexpected results when the position is ill-defined.
|
|
;;
|
|
;; A set-port-position is sufficient to make
|
|
;; the position no longer ill-defined.
|
|
;;
|
|
;; Buffered read operations include lookahead, port-eof?, and unget.
|
|
;; Buffered read operations also include get and get-some if buffer-mode is not none.
|
|
|
|
(set-who! make-custom-textual-input/output-port
|
|
(lambda (id read! write! get-position set-position! close)
|
|
(unless (string? id) ($oops who "~s is not a string" id))
|
|
(unless (procedure? read!) ($oops who "~s is not a procedure" read!))
|
|
(unless (procedure? write!) ($oops who "~s is not a procedure" write!))
|
|
(unless (or (not get-position) (procedure? get-position))
|
|
($oops who "~s is not a procedure or #f" get-position))
|
|
(unless (or (not set-position!) (procedure? set-position!))
|
|
($oops who "~s is not a procedure or #f" set-position!))
|
|
(unless (or (not close) (procedure? close))
|
|
($oops who "~s is not a procedure or #f" close))
|
|
(let ([handler
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(or (not (port-input-empty? p))
|
|
(port-flag-eof-set? p)
|
|
(read-oops who p "cannot determine ready status")))]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(textual-custom-port-lookahead who p write!))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(textual-custom-port-unget who p x))]
|
|
[get
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(textual-custom-port-get who p read!))]
|
|
[get-some
|
|
(lambda (who p str start count)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-input who p write!)
|
|
(textual-custom-port-get-some who p read! str start count))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-clear-input who p))]
|
|
[put
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-output who p get-position set-position!)
|
|
(textual-custom-port-put who p write! x))]
|
|
[put-some
|
|
(lambda (who p str start count)
|
|
(assert-not-closed who p)
|
|
(make-ready-for-output who p get-position set-position!)
|
|
(textual-custom-port-put-some who p write! str start count))]
|
|
[flush
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
; textual-custom-port-flush must be a no-op in input mode
|
|
(textual-custom-port-flush who p write!))]
|
|
[clear-output
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-clear-output who p))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
; textual-custom-port-flush must be a no-op in input mode
|
|
(textual-custom-port-flush who p write!)
|
|
(textual-custom-port-close-port who p close)))]
|
|
[port-position
|
|
(and get-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(unless (port-input-empty? p)
|
|
(position-warning who
|
|
"cannot determine accurate position after read on ~s"
|
|
p))
|
|
(textual-custom-port-flush who p write!)
|
|
(get-position)))]
|
|
[set-port-position!
|
|
(and set-position!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(textual-custom-port-flush who p write!)
|
|
(set-textual-port-input-size! p 0) ;; junk the buffer data
|
|
(set-port-eof! p #f)
|
|
(set-position! x)))]
|
|
[port-length #f]
|
|
[set-port-length! #f]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f])])
|
|
(let ([bufsiz (custom-port-buffer-size)])
|
|
(let ([p ($make-textual-input/output-port id handler
|
|
(make-string bufsiz)
|
|
(make-string bufsiz)
|
|
#f)])
|
|
($set-port-flags! p (constant port-flag-block-buffered))
|
|
($set-port-flags! p (constant port-flag-bol))
|
|
(set-textual-port-input-size! p 0)
|
|
(set-textual-port-output-size! p (fx1- bufsiz)) ;; leave room for put to work
|
|
p))))))
|
|
|
|
;;;; 8.3 Simple I/O: (rnrs io simple (6))
|
|
(let ()
|
|
;; eof-object in 8.2
|
|
;; eof-object? in 8.2
|
|
|
|
;; call-with-input-file in 8.2 (to share helpers)
|
|
;; call-with-output-file in 8.2 (to share helpers)
|
|
|
|
;; input-port? in 8.2
|
|
;; output-port? in 8.2
|
|
;; current-input-port in 8.2
|
|
;; current-output-port in 8.2
|
|
;; current-error-port in 8.2
|
|
|
|
;; with-input-from-file in 8.2 (to share helpers)
|
|
;; with-output-to-file in 8.2 (to share helpers)
|
|
|
|
;; open-input-file in 8.2 (to share helpers)
|
|
;; open-output-file in 8.2 (to share helpers)
|
|
|
|
(set-who! close-input-port
|
|
(lambda (input-port)
|
|
(unless (input-port? input-port)
|
|
($oops who "~s is not an input port" input-port))
|
|
(close-port input-port)))
|
|
|
|
(set-who! close-output-port
|
|
(lambda (output-port)
|
|
(unless (output-port? output-port)
|
|
($oops who "~s is not an output port" output-port))
|
|
(close-port output-port)))
|
|
)
|
|
|
|
(let ()
|
|
(define ($block-read who p s count)
|
|
(if (fx= count 0)
|
|
(if (port-eof? p) (eof-object) 0)
|
|
(call-port-handler get-some who p s 0 count)))
|
|
(set-who! block-read
|
|
(case-lambda
|
|
[(p s)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual input port" p))
|
|
(unless (string? s)
|
|
($oops who "invalid buffer argument ~s" s))
|
|
($block-read who p s (string-length s))]
|
|
[(p s n)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual input port" p))
|
|
(unless (string? s) ($oops who "invalid buffer argument ~s" s))
|
|
(unless (and (fixnum? n) (fx<= 0 n (string-length s)))
|
|
($oops who "invalid count argument ~s" n))
|
|
($block-read who p s n)])))
|
|
|
|
(let ()
|
|
(define ($block-write who p s count)
|
|
(let loop ([i 0] [count count])
|
|
(unless (fx= count 0)
|
|
(let ([n (call-port-handler put-some who p s i count)])
|
|
(loop (fx+ i n) (fx- count n)))))
|
|
(call-port-handler flush who p))
|
|
(set-who! block-write
|
|
(case-lambda
|
|
[(p s)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(unless (string? s) ($oops who "invalid buffer argument ~s" s))
|
|
($block-write who p s (string-length s))]
|
|
[(p s n)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(unless (string? s) ($oops who "invalid buffer argument ~s" s))
|
|
(unless (and (fixnum? n) (fx<= 0 n (string-length s)))
|
|
($oops who "invalid count argument ~s" n))
|
|
($block-write who p s n)])))
|
|
|
|
(let ()
|
|
(define ($char-ready? input-port who)
|
|
(or (not (port-input-empty? input-port))
|
|
(port-flag-eof-set? input-port)
|
|
(call-port-handler ready? who input-port)))
|
|
(set-who! char-ready?
|
|
(case-lambda
|
|
[() ($char-ready? (current-input-port) who)]
|
|
[(input-port)
|
|
(unless (and (input-port? input-port) (textual-port? input-port))
|
|
($oops who "~s is not a textual input port" input-port))
|
|
($char-ready? input-port who)])))
|
|
|
|
(set-who! clear-input-port
|
|
(rec clear-input-port
|
|
(case-lambda
|
|
[() (let ([p (current-input-port)])
|
|
(call-port-handler clear-input who p))]
|
|
[(p)
|
|
(unless (input-port? p)
|
|
($oops who "~s is not an input port" p))
|
|
(call-port-handler clear-input who p)])))
|
|
|
|
(set-who! clear-output-port
|
|
(rec clear-output-port
|
|
(case-lambda
|
|
[() (let ([p (current-output-port)])
|
|
(call-port-handler clear-output who p))]
|
|
[(p)
|
|
(unless (output-port? p)
|
|
($oops who "~s is not an output port" p))
|
|
(call-port-handler clear-output who p)])))
|
|
|
|
(set-who! fresh-line
|
|
(rec fresh-line
|
|
(case-lambda
|
|
[() (fresh-line (current-output-port))]
|
|
[(p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(assert-not-closed who p)
|
|
(unless ($textual-port-bol? p)
|
|
(call-port-handler put who p #\newline))])))
|
|
|
|
(set-who! port-bol?
|
|
(lambda (p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(assert-not-closed who p)
|
|
($textual-port-bol? p)))
|
|
|
|
(let ()
|
|
(define (binary-fd-port? bp)
|
|
($port-flags-set? bp (constant port-flag-file)))
|
|
|
|
(set-who! file-port?
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(if (binary-port? p)
|
|
(binary-fd-port? p)
|
|
(let ([info ($port-info p)])
|
|
(and (codec-info? info) (binary-fd-port? (codec-info-bp info)))))))
|
|
|
|
(set-who! port-file-descriptor
|
|
(let ()
|
|
(define gzfile-fd (foreign-procedure "(cs)gzxfile_fd" (ptr) int))
|
|
(define (binary-port-fd p bp)
|
|
(unless (binary-fd-port? bp)
|
|
($oops who "~s is not a file port" p))
|
|
(let ([x ($port-info bp)])
|
|
(if (port-gz-mode bp)
|
|
(gzfile-fd x)
|
|
x)))
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(if (binary-port? p)
|
|
(binary-port-fd p p)
|
|
(let ([info ($port-info p)])
|
|
(unless (codec-info? info)
|
|
($oops who "~s is not a file port" p))
|
|
(binary-port-fd p (codec-info-bp info))))))))
|
|
|
|
(let ()
|
|
(define $generic-port-handler
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(and (($port-info p) 'char-ready? p) #t))]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(let ([c (($port-info p) 'peek-char p)])
|
|
(unless (or (char? c) (eof-object? c))
|
|
($oops 'generic-port-handler "invalid peek-char return value ~s" c))
|
|
c))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(unless (eof-object? x) (($port-info p) 'unread-char x p))
|
|
(void))]
|
|
[get
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(let ([c (($port-info p) 'read-char p)])
|
|
(unless (or (char? c) (eof-object? c))
|
|
($oops 'generic-port-handler "invalid read-char return value ~s" c))
|
|
c))]
|
|
[get-some
|
|
(lambda (who p st start count)
|
|
(if (= start 0)
|
|
(let ([n (($port-info p) 'block-read p st count)])
|
|
(unless (or (and (fixnum? n) (not ($fxu< count n)))
|
|
(eof-object? n))
|
|
($oops 'generic-port-handler "invalid block-read return value ~s on ~s" n p))
|
|
n)
|
|
(let ([tmp (make-string count)])
|
|
(let ([n (($port-info p) 'block-read p tmp count)])
|
|
(cond
|
|
[(and (fixnum? n) (not ($fxu< count n)))
|
|
(string-copy! tmp 0 st start n)
|
|
n]
|
|
[(eof-object? n) n]
|
|
[else ($oops 'generic-port-handler "invalid block-read return value ~s on ~s" n p)])))))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(($port-info p) 'clear-input-port p)
|
|
(void))]
|
|
[put
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(($port-info p) 'write-char x p)
|
|
(void))]
|
|
[put-some
|
|
(lambda (who p st start count)
|
|
(assert-not-closed who p)
|
|
(if (= start 0)
|
|
(($port-info p) 'block-write p st count)
|
|
(let ([tmp (make-string count)])
|
|
(string-copy! st start tmp 0 count)
|
|
(($port-info p) 'block-write p tmp count)))
|
|
count)]
|
|
[flush
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(($port-info p) 'flush-output-port p)
|
|
(void))]
|
|
[clear-output
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(($port-info p) 'clear-output-port p)
|
|
(void))]
|
|
[close-port
|
|
(lambda (who p)
|
|
(unless (port-closed? p)
|
|
(($port-info p) 'close-port p))
|
|
(void))]
|
|
[port-position
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(($port-info p) 'file-position p))]
|
|
[set-port-position!
|
|
(lambda (who p x)
|
|
(assert-not-closed who p)
|
|
(($port-info p) 'file-position p x))]
|
|
[port-length
|
|
(lambda (who p)
|
|
(assert-not-closed who p)
|
|
(($port-info p) 'file-length p))]
|
|
[set-port-length!
|
|
(lambda (who p pos)
|
|
(assert-not-closed who p)
|
|
(($port-info p) 'truncate-file p pos))]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f]))
|
|
|
|
(define (set-name p)
|
|
(guard (c [#t (void)])
|
|
(let ([name (($port-info p) 'port-name p)])
|
|
(when (string? name) (set-port-name! p name))))
|
|
p)
|
|
|
|
(set-who! make-input-port
|
|
(lambda (handler buffer)
|
|
(unless (procedure? handler)
|
|
(if (and (fixnum? handler) (fx>= handler 0))
|
|
($oops who "fixnum handler no longer supported; use open-fd-input-port")
|
|
($oops who "~s is not a procedure" handler)))
|
|
(unless (string? buffer) ($oops who "~s is not a string" buffer))
|
|
(set-name
|
|
($make-textual-input-port "generic"
|
|
$generic-port-handler
|
|
buffer handler))))
|
|
|
|
(set-who! make-output-port
|
|
(lambda (handler buffer)
|
|
(unless (procedure? handler)
|
|
(if (and (fixnum? handler) (fx>= handler 0))
|
|
($oops who "fixnum handler no longer supported; use open-fd-input-port")
|
|
($oops who "~s is not a procedure" handler)))
|
|
(unless (string? buffer) ($oops who "~s is not a string" buffer))
|
|
(set-name
|
|
($make-textual-output-port "generic"
|
|
$generic-port-handler
|
|
buffer handler))))
|
|
|
|
(set-who! make-input/output-port
|
|
(lambda (handler ibuffer obuffer)
|
|
(unless (procedure? handler)
|
|
(if (and (fixnum? handler) (fx>= handler 0))
|
|
($oops who "fixnum handler no longer supported; use open-fd-input-port")
|
|
($oops who "~s is not a procedure" handler)))
|
|
(unless (string? ibuffer) ($oops who "~s is not a string" ibuffer))
|
|
(unless (string? obuffer) ($oops who "~s is not a string" obuffer))
|
|
(set-name
|
|
($make-textual-input/output-port "generic"
|
|
$generic-port-handler
|
|
ibuffer obuffer handler))))
|
|
|
|
(set-who! port-handler
|
|
(let ()
|
|
(define check
|
|
(lambda (msg n)
|
|
(unless (cond
|
|
[(assq n
|
|
'((1 char-ready? clear-input-port clear-output-port close-port
|
|
file-length file-position flush-output-port peek-char
|
|
port-name read-char)
|
|
(2 file-position unread-char write-char)
|
|
(3 block-read block-write))) =>
|
|
(lambda (ls) (memq msg (cdr ls)))]
|
|
[else #f])
|
|
($oops 'non-generic-port-handler
|
|
"cannot handle message ~s with argument count ~s"
|
|
msg n))))
|
|
(define non-generic-port-handler
|
|
(lambda (msg . args)
|
|
(check msg (length args))
|
|
(apply ($top-level-value msg) args)))
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(if (eq? ($port-handler p) $generic-port-handler)
|
|
($port-info p)
|
|
non-generic-port-handler))))
|
|
)
|
|
|
|
(record-writer (type-descriptor codec)
|
|
(lambda (x p wr)
|
|
(fprintf p "#<codec ~a>" (codec-name x))))
|
|
|
|
(record-writer (type-descriptor transcoder)
|
|
(lambda (x p wr)
|
|
(fprintf p "#<transcoder ~a ~s ~s>"
|
|
(codec-name ($transcoder-codec x))
|
|
($transcoder-eol-style x)
|
|
($transcoder-error-handling-mode x))))
|
|
|
|
(set-who! #(r6rs: current-input-port)
|
|
(lambda ()
|
|
(#2%current-input-port)))
|
|
|
|
(set-who! #(r6rs: current-output-port)
|
|
(lambda ()
|
|
(#2%current-output-port)))
|
|
|
|
(set-who! #(r6rs: current-error-port)
|
|
(lambda ()
|
|
(#2%current-error-port)))
|
|
|
|
; thread-safe transcript-on, transcript-off, transcript-cafe
|
|
(let ()
|
|
(define-record-type xscript-info
|
|
(nongenerative)
|
|
(opaque #t)
|
|
(sealed #t)
|
|
(fields ip op xp (mutable ungot))
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda (ip op xp)
|
|
(new ip op xp '())))))
|
|
|
|
(module (make-xscript-port xscript-port? constituent-ports)
|
|
(define-syntax with-xscript-info
|
|
(syntax-rules ()
|
|
[(_ (p ip op xp ungot) e1 e2 ...)
|
|
(andmap identifier? #'(ip op xp ungot))
|
|
(let ([x ($port-info p)])
|
|
(let ([ip (xscript-info-ip x)]
|
|
[op (xscript-info-op x)]
|
|
[xp (xscript-info-xp x)])
|
|
(define-syntax ungot
|
|
(identifier-syntax
|
|
[id (xscript-info-ungot x)]
|
|
[(set! id e) (xscript-info-ungot-set! x e)]))
|
|
e1 e2 ...))]))
|
|
|
|
(define-syntax thread-safe
|
|
(syntax-rules ()
|
|
[(_ (p ip op xp ungot) e1 e2 ...)
|
|
(with-xscript-info (p ip op xp ungot)
|
|
(with-tc-mutex e1 e2 ...))]))
|
|
|
|
(define-syntax call-xp-handler
|
|
(syntax-rules ()
|
|
[(_ msg who xp arg ...)
|
|
(identifier? #'xp)
|
|
(and (not (port-closed? xp))
|
|
(call-port-handler msg who xp arg ...))]))
|
|
|
|
(define slurp-input
|
|
(lambda (who p)
|
|
(with-xscript-info (p ip op xp ungot)
|
|
(let ([tognu (reverse ungot)])
|
|
(guard (c [#t (void)]) ; guard ready? calls
|
|
(let loop ()
|
|
(when (call-port-handler ready? who ip)
|
|
(let ([c (call-port-handler get who ip)])
|
|
(unless (eof-object? c)
|
|
(call-xp-handler put who xp c)
|
|
(set! tognu (cons c tognu))
|
|
(loop))))))
|
|
(set! ungot (reverse tognu))))))
|
|
|
|
; similar in structure to thread-safe console-port handler
|
|
(define xscript-handler
|
|
(make-port-handler
|
|
[ready?
|
|
(lambda (who p)
|
|
(thread-safe (p ip op xp ungot)
|
|
(or (not (null? ungot))
|
|
(begin
|
|
(call-port-handler flush who op)
|
|
(call-port-handler ready? who ip)))))]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(thread-safe (p ip op xp ungot)
|
|
(if (not (null? ungot))
|
|
(car ungot)
|
|
(begin
|
|
(call-port-handler flush who op)
|
|
(let ([c (call-port-handler get who ip)])
|
|
(set! ungot (list c))
|
|
(unless (eof-object? c) (call-xp-handler put who xp c))
|
|
c)))))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(thread-safe (p ip op xp ungot)
|
|
(set! ungot (cons x ungot))))]
|
|
[get
|
|
(lambda (who p)
|
|
(thread-safe (p ip op xp ungot)
|
|
(if (not (null? ungot))
|
|
(let ([c (car ungot)])
|
|
(set! ungot (cdr ungot))
|
|
c)
|
|
(begin
|
|
(call-port-handler flush who op)
|
|
(let ([c (call-port-handler get who ip)])
|
|
(unless (eof-object? c) (call-xp-handler put who xp c))
|
|
c)))))]
|
|
[get-some
|
|
(lambda (who p str start count)
|
|
(thread-safe (p ip op xp ungot)
|
|
(if (and (fx> count 0) (not (null? ungot)))
|
|
(let ([c (car ungot)])
|
|
(set! ungot (cdr ungot))
|
|
(if (eof-object? c)
|
|
c
|
|
(begin (string-set! str start c) 1)))
|
|
(begin
|
|
(call-port-handler flush who op)
|
|
(let ([count (call-port-handler get-some who ip str start count)])
|
|
(unless (or (eof-object? count) (fx= count 0))
|
|
(call-xp-handler put-some who xp str start count))
|
|
count)))))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(thread-safe (p ip op xp ungot)
|
|
(set! ungot '())
|
|
(call-port-handler clear-input who ip)))]
|
|
[put
|
|
(lambda (who p x)
|
|
(thread-safe (p ip op xp ungot)
|
|
(slurp-input who p)
|
|
(call-port-handler put who op x)
|
|
(call-xp-handler put who xp x)
|
|
(if ($textual-port-bol? op)
|
|
($set-port-flags! p (constant port-flag-bol))
|
|
($reset-port-flags! p (constant port-flag-bol)))))]
|
|
[put-some
|
|
(lambda (who p str start count)
|
|
(thread-safe (p ip op xp ungot)
|
|
(slurp-input who p)
|
|
(let ([count (call-port-handler put-some who op str start count)])
|
|
(let f ([start start] [count count])
|
|
(unless (fx= count 0)
|
|
(let ([n (call-xp-handler put-some who xp str start count)])
|
|
(and n (f (fx+ start n) (fx- count n))))))
|
|
(if ($textual-port-bol? op)
|
|
($set-port-flags! p (constant port-flag-bol))
|
|
($reset-port-flags! p (constant port-flag-bol)))
|
|
count)))]
|
|
[flush
|
|
(lambda (who p)
|
|
(thread-safe (p ip op xp ungot)
|
|
(call-port-handler flush who op)
|
|
(call-xp-handler flush who xp)))]
|
|
[clear-output
|
|
(lambda (who p)
|
|
; clearing may put op and xp out of sync, so just flush instead
|
|
(thread-safe (p ip op xp ungot)
|
|
(call-port-handler flush who op)
|
|
(call-xp-handler flush who xp)))]
|
|
[close-port
|
|
(lambda (who p)
|
|
; refuse to close transcript ports, like console ports---just flush instead
|
|
(thread-safe (p ip op xp ungot)
|
|
(call-port-handler flush who op)
|
|
(call-xp-handler flush who xp)))]
|
|
[port-position #f]
|
|
[set-port-position! #f]
|
|
[port-length #f]
|
|
[set-port-length! #f]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f]))
|
|
|
|
(define (make-xscript-port ip op xp)
|
|
(let ([p ($make-textual-input/output-port
|
|
"transcript" xscript-handler "" ""
|
|
(make-xscript-info ip op xp))])
|
|
(when ($port-flags-set? ip (constant port-flag-r6rs))
|
|
($set-port-flags! p (constant port-flag-r6rs)))
|
|
(when ($port-flags-set? ip (constant port-flag-fold-case))
|
|
($set-port-flags! p (constant port-flag-fold-case)))
|
|
(when ($port-flags-set? ip (constant port-flag-no-fold-case))
|
|
($set-port-flags! p (constant port-flag-no-fold-case)))
|
|
(when ($textual-port-bol? op)
|
|
($set-port-flags! p (constant port-flag-bol)))
|
|
p))
|
|
|
|
(define xscript-port?
|
|
(lambda (p)
|
|
(eq? ($port-handler p) xscript-handler)))
|
|
|
|
(define constituent-ports
|
|
(lambda (p)
|
|
(with-xscript-info (p ip op xp ungot)
|
|
(values ip op xp)))))
|
|
|
|
(set-who! $xscript-port? (lambda (p) (xscript-port? p)))
|
|
|
|
(set-who! $constituent-ports (lambda (p) (constituent-ports p)))
|
|
|
|
(set-who! transcript-on
|
|
(lambda (pathname)
|
|
(unless (string? pathname) ($oops who "~s is not a string" pathname))
|
|
(let ([ip (console-input-port)] [op (console-output-port)])
|
|
(when (and (guard (c [#t #f]) (char-ready? ip))
|
|
(eqv? (peek-char ip) #\newline))
|
|
(read-char ip))
|
|
(let ([xp ($open-file-output-port who pathname (file-options replace)
|
|
(buffer-mode block)
|
|
(current-transcoder))])
|
|
(let ([p (make-xscript-port ip op xp)])
|
|
(when (eq? (console-error-port) op) (console-error-port p))
|
|
(when (eq? (current-input-port) ip) (current-input-port p))
|
|
(when (eq? (current-output-port) op) (current-output-port p))
|
|
(when (eq? (current-error-port) op) (current-error-port p))
|
|
(when (eq? (trace-output-port) op) (trace-output-port p))
|
|
(console-input-port p)
|
|
(console-output-port p)))
|
|
(printf "Chez Scheme Transcript [~a]\n" (date-and-time)))))
|
|
|
|
(set-who! transcript-off
|
|
(lambda ()
|
|
(cond
|
|
[(ormap (lambda (p) (and (xscript-port? p) p))
|
|
(list (console-input-port)
|
|
(console-output-port)
|
|
(console-error-port)
|
|
(current-input-port)
|
|
(current-output-port)
|
|
(current-error-port)
|
|
(trace-output-port))) =>
|
|
(lambda (p)
|
|
(let-values ([(ip op xp) (constituent-ports p)])
|
|
(when (eq? (console-input-port) p) (console-input-port ip))
|
|
(when (eq? (console-output-port) p) (console-output-port op))
|
|
(when (eq? (console-error-port) p) (console-error-port op))
|
|
(when (eq? (current-input-port) p) (current-input-port ip))
|
|
(when (eq? (current-output-port) p) (current-output-port op))
|
|
(when (eq? (current-error-port) p) (current-error-port op))
|
|
(when (eq? (trace-output-port) p) (trace-output-port op))
|
|
(flush-output-port p)
|
|
(close-port xp)))])))
|
|
|
|
(set-who! transcript-cafe
|
|
(lambda (pathname)
|
|
(unless (string? pathname) ($oops who "~s is not a string" pathname))
|
|
(let ([ip (console-input-port)] [op (console-output-port)])
|
|
(when (and (guard (c [#t #f]) (char-ready? (console-input-port)))
|
|
(eqv? (peek-char (console-input-port)) #\newline))
|
|
(read-char (console-input-port)))
|
|
(let ([xp ($open-file-output-port who pathname (file-options replace)
|
|
(buffer-mode block)
|
|
(current-transcoder))])
|
|
(let ([p (make-xscript-port ip op xp)])
|
|
(with-values
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(when (eq? (console-input-port) ip) (console-input-port p))
|
|
(when (eq? (console-output-port) op) (console-output-port p))
|
|
(when (eq? (console-error-port) op) (console-error-port p))
|
|
(when (eq? (current-input-port) ip) (current-input-port p))
|
|
(when (eq? (current-output-port) op) (current-output-port p))
|
|
(when (eq? (current-error-port) op) (current-error-port p))
|
|
(when (eq? (trace-output-port) op) (trace-output-port p)))
|
|
(lambda ()
|
|
(printf "Chez Scheme Transcript [~a]\n" (date-and-time))
|
|
(new-cafe))
|
|
(lambda ()
|
|
(when (eq? (console-input-port) p) (console-input-port ip))
|
|
(when (eq? (console-output-port) p) (console-output-port op))
|
|
(when (eq? (console-error-port) p) (console-error-port op))
|
|
(when (eq? (current-input-port) p) (current-input-port ip))
|
|
(when (eq? (current-output-port) p) (current-output-port op))
|
|
(when (eq? (current-error-port) p) (current-error-port op))
|
|
(when (eq? (trace-output-port) p) (trace-output-port op))
|
|
(flush-output-port p)))
|
|
(lambda vals
|
|
(close-port xp)
|
|
(apply values vals)))))))))
|
|
|
|
#;(let ()
|
|
(define debug-port-handler
|
|
(make-port-handler
|
|
[ready? (lambda (who p) (input-port-ready? ($port-info p)))]
|
|
[lookahead
|
|
(lambda (who p)
|
|
(let ([b (lookahead-u8 ($port-info p))])
|
|
(if (eof-object? b) b (integer->char b))))]
|
|
[unget
|
|
(lambda (who p x)
|
|
(unget-u8 ($port-info p) (if (eof-object? x) x (char->integer x))))]
|
|
[get
|
|
(lambda (who p)
|
|
(let ([b (get-u8 ($port-info p))])
|
|
(if (eof-object? b) b (integer->char b))))]
|
|
[get-some
|
|
(lambda (who p str start count)
|
|
(if (fx= count 0)
|
|
0
|
|
(let ([b (get-u8 ($port-info p))])
|
|
(if (eof-object? b)
|
|
b
|
|
(begin
|
|
(string-set! str start (integer->char b))
|
|
1)))))]
|
|
[clear-input
|
|
(lambda (who p)
|
|
(clear-input-port ($port-info p)))]
|
|
[put
|
|
(lambda (who p x)
|
|
(put-u8 ($port-info p) (char->integer x)))]
|
|
[put-some
|
|
(lambda (who p str start count)
|
|
(if (fx= count 0)
|
|
0
|
|
(begin
|
|
(put-u8 ($port-info p) (char->integer (string-ref str start)))
|
|
1)))]
|
|
[flush
|
|
(lambda (who p)
|
|
(flush-output-port ($port-info p)))]
|
|
[clear-output
|
|
(lambda (who p)
|
|
(clear-output-port ($port-info p)))]
|
|
[close-port (lambda (who p) (flush-output-port ($port-info p)) (void))]
|
|
[port-position
|
|
(lambda (who p)
|
|
(port-position ($port-info p)))]
|
|
[set-port-position!
|
|
(lambda (who p x)
|
|
(set-port-position! ($port-info p) x))]
|
|
[port-length
|
|
(lambda (who p)
|
|
(port-length ($port-info p)))]
|
|
[set-port-length!
|
|
(lambda (who p x)
|
|
(set-port-length! ($port-info p) x))]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f]))
|
|
(set! $console-input-port ($make-textual-input-port "debug-stdin" debug-port-handler "" (standard-input-port (buffer-mode block))))
|
|
(set! $console-output-port ($make-textual-output-port "debug-stdout" debug-port-handler "" (standard-output-port (buffer-mode none))))
|
|
(set! $console-output-port ($make-textual-output-port "debug-stderr" debug-port-handler "" (standard-error-port (buffer-mode none)))))
|
|
|
|
(let ([ip (standard-input-port (buffer-mode block) (current-transcoder))]
|
|
[op (standard-output-port (buffer-mode line) (current-transcoder))])
|
|
(define same-device? (foreign-procedure "(cs)same_devicep" (int int) boolean))
|
|
(if-feature pthreads
|
|
(let ()
|
|
; it would be nice to make port->thread-safe-port available generally,
|
|
; but since it grabs the tc mutex, making it public would be
|
|
; inappropriate. tried using a fresh mutex, but the thread mat
|
|
; that runs compile-file freezes, possibly due to a deadlock where one
|
|
; thread has the tc mutex and another has the port's mutex. should
|
|
; revisit...
|
|
(define (make-thread-safe-handler ip op)
|
|
(make-port-handler
|
|
[ready?
|
|
(and ip
|
|
(lambda (who p)
|
|
(with-tc-mutex
|
|
(call-port-handler flush who op)
|
|
(call-port-handler ready? who ip))))]
|
|
[lookahead
|
|
(and ip
|
|
(lambda (who p)
|
|
(with-tc-mutex
|
|
(call-port-handler flush who op)
|
|
(call-port-handler lookahead who ip))))]
|
|
[unget
|
|
(and ip
|
|
(lambda (who p x)
|
|
(with-tc-mutex
|
|
(call-port-handler unget who ip x))))]
|
|
[get
|
|
(and ip
|
|
(lambda (who p)
|
|
(with-tc-mutex
|
|
(call-port-handler flush who op)
|
|
(call-port-handler get who ip))))]
|
|
[get-some
|
|
(and ip
|
|
(lambda (who p str start count)
|
|
(with-tc-mutex
|
|
(call-port-handler flush who op)
|
|
(call-port-handler get-some who ip str start count))))]
|
|
[clear-input
|
|
(and ip
|
|
(lambda (who p)
|
|
(with-tc-mutex
|
|
(call-port-handler clear-input who ip))))]
|
|
[put
|
|
(and op
|
|
(lambda (who p x)
|
|
(with-tc-mutex
|
|
(call-port-handler put who op x)
|
|
(if ($textual-port-bol? op)
|
|
($set-port-flags! p (constant port-flag-bol))
|
|
($reset-port-flags! p (constant port-flag-bol))))))]
|
|
[put-some
|
|
(and op
|
|
(lambda (who p str start count)
|
|
(with-tc-mutex
|
|
(let ([count (call-port-handler put-some who op str start count)])
|
|
(if ($textual-port-bol? op)
|
|
($set-port-flags! p (constant port-flag-bol))
|
|
($reset-port-flags! p (constant port-flag-bol)))
|
|
count))))]
|
|
[flush
|
|
(and op
|
|
(lambda (who p)
|
|
(with-tc-mutex
|
|
(call-port-handler flush who op))))]
|
|
[clear-output
|
|
(and op
|
|
(lambda (who p)
|
|
(with-tc-mutex
|
|
(call-port-handler clear-output who op))))]
|
|
[close-port ; refuse to close console ports---just flush instead
|
|
(if op
|
|
(lambda (who p)
|
|
(with-tc-mutex
|
|
(call-port-handler flush who op)))
|
|
(lambda (who p)
|
|
(void)))]
|
|
[port-position #f]
|
|
[set-port-position! #f]
|
|
[port-length #f]
|
|
[set-port-length! #f]
|
|
[port-nonblocking? #f]
|
|
[set-port-nonblocking! #f]))
|
|
(define thread-safe-console-input/output-port
|
|
(lambda (name ip op)
|
|
(let ([p ($make-textual-input/output-port name (make-thread-safe-handler ip op) "" "" #f)])
|
|
(when ($port-flags-set? ip (constant port-flag-r6rs))
|
|
($set-port-flags! p (constant port-flag-r6rs)))
|
|
(when ($port-flags-set? ip (constant port-flag-fold-case))
|
|
($set-port-flags! p (constant port-flag-fold-case)))
|
|
(when ($port-flags-set? ip (constant port-flag-no-fold-case))
|
|
($set-port-flags! p (constant port-flag-no-fold-case)))
|
|
(when ($textual-port-bol? op)
|
|
($set-port-flags! p (constant port-flag-bol)))
|
|
p)))
|
|
(define thread-safe-console-output-port
|
|
(lambda (name op)
|
|
(let ([p ($make-textual-output-port name (make-thread-safe-handler #f op) "" #f)])
|
|
(when ($textual-port-bol? op)
|
|
($set-port-flags! p (constant port-flag-bol)))
|
|
p)))
|
|
(let ([p (thread-safe-console-input/output-port "stdin/out" ip op)])
|
|
(set! $console-input-port p)
|
|
(set! $console-output-port p)
|
|
(set! $console-error-port
|
|
(if (same-device? 1 2)
|
|
p
|
|
(thread-safe-console-output-port "stderr" (standard-error-port (buffer-mode line) (current-transcoder)))))))
|
|
(begin
|
|
(set! $console-input-port ip)
|
|
(set! $console-output-port op)
|
|
(set! $console-error-port
|
|
(if (same-device? 1 2)
|
|
op
|
|
(standard-error-port (buffer-mode line) (current-transcoder)))))))
|
|
|
|
(current-input-port $console-input-port)
|
|
(current-output-port $console-output-port)
|
|
(current-error-port $console-error-port)
|
|
(set-who! console-input-port
|
|
(make-parameter
|
|
$console-input-port
|
|
(lambda (ip)
|
|
(unless (and (input-port? ip) (textual-port? ip))
|
|
($oops who "~s is not a textual input port" ip))
|
|
ip)))
|
|
(set-who! console-output-port
|
|
(make-parameter
|
|
$console-output-port
|
|
(lambda (op)
|
|
(unless (and (output-port? op) (textual-port? op))
|
|
($oops who "~s is not a textual output port" op))
|
|
op)))
|
|
(set-who! console-error-port
|
|
(make-parameter
|
|
$console-error-port
|
|
(lambda (op)
|
|
(unless (and (output-port? op) (textual-port? op))
|
|
($oops who "~s is not a textual output port" op))
|
|
op)))
|
|
(set! $io-init
|
|
(lambda ()
|
|
(clear-open-files)
|
|
; reregister the console ports
|
|
(register-open-file $console-input-port)
|
|
(register-open-file $console-output-port)
|
|
(unless (eq? $console-error-port $console-output-port)
|
|
(register-open-file $console-error-port))))
|
|
|
|
; utf8->string, etc., are in prims.ss, since they are used by
|
|
; foreign procedures argument and return values
|
|
)
|
|
)
|