racket/s/io.ss
dyb 82b2cda639 compress-level parameter, improvement in lz4 compression, and various other related improvements
- added compress-level parameter to select a compression level for
  file writing and changed the default for lz4 compression to do a
  better job compressing.  finished splitting glz input routines
  apart from glz output routines and did a bit of other restructuring.
  removed gzxfile struct-as-bytevector wrapper and moved its fd
  into glzFile.  moved DEACTIVATE to before glzdopen_input calls
  in S_new_open_input_fd and S_compress_input_fd, since glzdopen_input
  reads from the file and could block.  the compress format and now
  level are now recorded directly the thread context.  replaced
  as-gz? flag bit in compressed bytevector header word with a small
  number of bits recording the compression format at the bottom of
  the header word.  flushed a couple of bytevector compression mats
  that depended on the old representation.  (these last few changes
  should make adding new compression formats easier.)  added
  s-directory build options to choose whether to compress and, if
  so, the format and level.
    compress-io.h, compress-io.c, new-io.c, equates.h, system.h,
    scheme.c, gc.c,
    io.ss, cmacros.ss, back.ss, bytevector.ss, primdata.ss, s/Mf-base,
    io.ms, mat.ss, bytevector.ms, root-experr*,
    release_notes.stex, io.stex, system.stex, objects.stex
- improved the effectiveness of LZ4 boot-file compression to within
  15% of gzip by increasing the lz4 output-port in_buffer size to
  1<<18.  With the previous size (1<<14) LZ4-compressed boot files
  were about 50% larger.  set the lz4 input-port in_buffer and
  out_buffer sizes to 1<<12 and 1<<14.  there's no clear win at
  present for larger input-port buffer sizes.
    compress-io.c
- To reduce the memory hit for the increased output-port in_buffer
  size and the corresponding increase in computed out_buffer size,
  one output-side out_buffer is now allocated (lazily) per thread
  and stored in the thread context.  The other buffers are now
  directly a part of the lz4File_out and lz4File_in structures
  rather than allocated separately.
    compress-io.c, scheme.c, gc.c,
    cmacros.ss
- split out the buffer emit code from glzwrite_lz4 into a
  separate glzemit_lz4 helper that is now also used by gzclose
  so we can avoid dealing with a NULL buffer in glzwrite_lz4.
  glzwrite_lz4 also uses it to writing large buffers directly and
  avoid the memcpy.
    compress-io.c
- replaced lz4File_out and lz4File_in mode enumeration with the
  compress format and inputp boolean.  using switch to check and
  raising exceptions for unexpected values to further simplify
  adding new compression formats in the future.
    compress-io.c
- replaced the never-defined struct lz4File pointer in glzFile
  union with the more specific struct lz4File_in_r and Lz4File_out_r
  pointers.
    compress-io.h, compress-io.c
- added free of lz4 structures to gzclose.  also changed file-close
  logic generally so that (1) port is marked closed before anything is
  freed to avoid dangling pointers in the case of an interrupt or
  error, and (2) structures are freed even in the case of a write
  or close error, before the error is reported.  also now mallocing
  glz and lz4 structures after possibility of errors have passed where
  possible and freeing them when not.
    compress-io.c,
    io.ss
- added return-value checks to malloc calls and to a couple of other
  C-library calls.
    compress-io.c
- corrected EINTR checks to look at errno rather than return codes.
    compress-io.c
- added S_ prefixes to the glz* exports
    externs.h, compress-io.c, new-io.c, scheme.c, fasl.c
- added entries for mutex-name and mutex-thread
    threads.stex

original commit: 722ffabef4c938bc92c0fe07f789a9ba350dc6c6
2019-04-18 05:47:19 -07:00

6311 lines
286 KiB
Scheme

"io.ss"
;;; 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.
|#
(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-size! 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
;; Invarient: info-index <= index
;; Invarient: size = (max length index)
;; Invarient: if no put/put-some after last set-pos/set-length,
;; then info-index = index and true length = info-length
;; Invarient: 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)
;; set size to one less than real size so 'put' always has room
(set-binary-port-output-size! p (fx1- new-length)))))
(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())
(set-binary-port-output-size! p 0)
(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)
;; set size to one less than real size so 'put' always has room
(set-textual-port-output-size! p (fx1- new-length)))))
(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 "")
(set-textual-port-output-size! p 0)
(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)])))
(set-who! char-ready?
(lambda (input-port)
(unless (and (input-port? input-port) (textual-port? input-port))
($oops who "~s is not a textual input port" input-port))
(or (not (port-input-empty? input-port))
(port-flag-eof-set? input-port)
(call-port-handler ready? who input-port))))
(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
)