;;; io.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; possible extensions:
;;;  - mechanism for overriding default #o666 mode
;;;  - user-defined handler records
;;;    - say user-supplied handler procedures "should" return appropriate
;;;      values (e.g., octet/eof for get on binary port), wrap procedures
;;;      in return-value checkers, or allow user to choose whether
;;;      procedures are wrapped in return-value checkers

;;; r6rs custom ports are fubar:
;;;  - binary and textual output ports: no known problems
;;;  - binary input ports: no problem except just after a
;;;    lookahead-u8 returns #!eof or just after unget-u8 of #!eof,
;;;    at which point port position is ill-defined.
;;;  - binary input/output ports: can't work without working
;;;    get-position and set-position! procedures to switch between
;;;    input and output mode
;;;  - textual input ports: no way to implement port-position,
;;;    since get-position returns an arbitrary object, no way to adjust for
;;;    amount we've buffered, and we must buffer at least one character to
;;;    support lookahead-char.  also same problem as custom binary input
;;;    ports with #!eof.
;;;  - textual input/output ports: no way to switch between input
;;;    and output modes, since we cannot implement port-position.
;;;
;;; all problems derive from need to buffer at least one element to
;;; support lookahead-u8 and lookahead-char.
;;;
;;; our workarounds:
;;;  - custom binary and textual output ports:
;;;    - none
;;;  - custom binary input ports:
;;;    - treat eof as zero width
;;;    - assume sequential indices from get-position to compute port-position
;;;      with adjustment for buffered characters
;;;  - custom textual input ports:
;;;    - treat eof as zero width
;;;    - port-position undefined after read
;;;    - no warning for port-position if:
;;;      - no reads (including lookahead and port-eof?) have been done
;;;      - a set-port-position! occurred after last read
;;;      - buffer-mode is none and last read operation was not a lookahead,
;;;        port-eof?, or unget
;;;  - custom binary or textual input/output ports:
;;;    - position for write undefined after read
;;;    - port-position undefined after read
;;;    - no warning for write or port-position if:
;;;      - no reads (including lookahead and port-eof?) have been done
;;;      - a write or set-port-position occurred after last read
;;;      - buffer-mode is none and last read operation was not a lookahead,
;;;        port-eof?, or unget (efficient input can be had with buffer-mode
;;;        none if only get-bytevector operations are used.  sequence of
;;;        gets will relatively slow with buffer-mode none.)
;;;    - exception: we use supplied get-position and
;;;      set-position! on a custom binary input/output port to sync
;;;      position and avoid issuing warnings under assumption that
;;;      get-position indices are sequential

#|
implementation notes:
  - for binary input/output file ports, we can always distinguish input
    mode from output mode by the fact that output-size is zero iff port is
    in input mode.  this does not work for textual ports, because
    output-size can be zero even in output mode for line-buffered ports.
    so we instead use an input-mode flag in the port header.
|#

(begin
(set-who! file-buffer-size
  ($make-thread-parameter $c-bufsiz
    (lambda (x)
      (unless (and (fixnum? x) (fx> x 0))
        ($oops who "~s is not a positive fixnum" x))
      x)))

(set-who! custom-port-buffer-size
  ($make-thread-parameter 128
    (lambda (x)
      (unless (and (fixnum? x) (fx> x 0))
        ($oops who "~s is not a positive fixnum" x))
      x)))

(let ()
 ; choose whether to issue warnings when custom-port implementation
 ; cannot determine position for port-position or write operation
  #;(define position-warning warning)
  (define (position-warning who msg . args) (void))

  (include "io-types.ss")

  (define-syntax call-port-handler
    (lambda (x)
      (syntax-case x ()
        [(_ msg who ?p arg ...)
         (identifier? #'msg)
         (with-syntax ([port-handler-msg (construct-name #'msg "port-handler-" #'msg)])
           #'(let ([p ?p]) ((port-handler-msg ($port-handler p)) who p arg ...)))])))

  (define-port-handler (codec make-codec codec?) #f
    (name -> string)
    (make-info who tx bp bv -> codec-info))

 ; ioffsets is an fxvector mapping character positions in a port's input buffer
 ; to byte offsets from the starting byte position for the buffer.  ibytes
 ; is the byte offset of the character just beyond the end of the buffer,
 ; which is also the length in bytes of the data represented by the characters
 ; in the buffer.  ioffsets and ibytes together allow port positions to be
 ; reported in bytes.  ioffsets and ibytes are not consulted when a port's
 ; input buffer is empty, so there is no harm in modifying them when reading
 ; into a different string.  since ioffsets might not have as many elements
 ; as the different string, however, a codec should usually avoid modifying
 ; ioffsets to prevent writes beyond the end of the vector.  a codec's encode
 ; procedure is always called with start = 0 when string to fill is the port's
 ; input buffer, so ibytes should also start at 0.

  (define-record-type codec-info
    (nongenerative)
    (opaque #t)
    (fields
      (immutable tx)           ; transcoder
      (mutable bp)             ; binary port (clone)
      (immutable bv)           ; bytevector buffer (input or output, one at a time)
      (mutable next)           ; next pointer into buffer
      (mutable iend)           ; end of data (input only)
      (immutable ioffsets)     ; byte offset each char in port's buffer, relative to first (input only)
      (mutable ibytes)         ; byte offset of first char beyond port's buffer (input only)
      (mutable icr)            ; #\return seen when eol style is not none (input only)
      (mutable bom)            ; looking for byte-order-mark on input, or ready to write it on output
      (mutable zbom)           ; bom found or placed at position zero
      (mutable big)            ; big endian?
      (immutable decode)       ; input decoder
      (immutable encode)       ; output encoder
      (immutable close)))

 ; keep make-fd in sync with types.h MAKE_FD
  (define (make-fd intfd) intfd)

  (define (port-oops who p msg)
    ($oops/c who
      (make-i/o-port-error p)
      "failed on ~s: ~(~a~)" p msg))

  (define (read-oops who p msg)
    ($oops/c who
      (condition (make-i/o-read-error) (make-i/o-port-error p))
      "failed on ~s: ~(~a~)" p msg))

  (define (write-oops who p msg)
    ($oops/c who
      (condition (make-i/o-write-error) (make-i/o-port-error p))
      "failed on ~s: ~(~a~)" p msg))

  (define (position-oops who p pos msg)
    ($oops/c who
      (condition
        (make-i/o-invalid-position-error pos)
        (make-i/o-port-error p))
      "failed for position ~s on ~s: ~(~a~)" pos p msg))

  (define (open-oops who filename file-options err.msg)
    ($oops/c who
      (let ([err (car err.msg)])
        (cond
          [(eqv? err (constant OPEN-ERROR-PROTECTION))
           (make-i/o-file-protection-error filename)]
          [(eqv? err (constant OPEN-ERROR-EXISTS))
           (make-i/o-file-already-exists-error filename)]
          [(eqv? err (constant OPEN-ERROR-EXISTSNOT))
           (make-i/o-file-does-not-exist-error filename)]
          [else (make-i/o-filename-error filename)]))
      "failed for ~a: ~(~a~)"
      filename
      (cdr err.msg)))

  (define (unget-error who p x)
    ($oops who "cannot unget ~s on ~s" x p))

  (define eol-char?
    (lambda (c)
      (memv c '(#\newline #\return #\nel #\ls))))

  (define-syntax port-gz-mode
    (syntax-rules ()
      [(_ port) ($port-flags-set? port (constant port-flag-compressed))]))
  (define-syntax port-flag-eof-set?
    (syntax-rules ()
      [(_ port) ($port-flags-set? port (constant port-flag-eof))]))
  (define-syntax assert-not-closed
    (syntax-rules ()
      [(_ who port)
       (when (port-closed? port)
         ($oops who "not permitted on closed port ~s" port))]))

  (define-syntax file-options-list
    (syntax-rules ()
      [(_)
       '(no-create no-fail no-truncate compressed replace exclusive append
         perm-set-user-id perm-set-group-id perm-sticky
         perm-no-user-read perm-no-user-write perm-user-execute
         perm-no-group-read perm-no-group-write perm-group-execute
         perm-no-other-read perm-no-other-write perm-other-execute)]))

  (define-syntax eol-style-list
    (syntax-rules ()
      [(_) '(lf cr crlf nel crnel ls none)]))

  (define-syntax error-handling-mode-list
    (syntax-rules ()
      [(_) '(ignore raise replace)]))

  (define ($textual-port-bol? p)
    (let ([index (textual-port-output-index p)])
      (if (fx= index 0)
          ($port-flags-set? p (constant port-flag-bol))
          (eol-char? (string-ref (textual-port-output-buffer p) (fx- index 1))))))

  (define-record-type (transcoder $make-transcoder $transcoder?)
    (nongenerative)
    (opaque #t)
    (sealed #t)
    (fields
      (immutable codec $transcoder-codec)
      (immutable eol-style $transcoder-eol-style)
      (immutable error-handling-mode $transcoder-error-handling-mode)))

  ;; minimum-file-buffer-length is not 0 because of lookahead-u8 and
  ;; unget-u8 and to simplify the logic for setting size and index based
  ;; on length.  the single byte will never be used for output ports.
  (define minimum-file-buffer-length 1)
  (define bytevector-buffer-length 128)
  (define string-buffer-length 16)
  (define buffered-transcoded-port-buffer-length 1024)
  (define unbuffered-transcoded-port-buffer-length 1)
  (define codec-buffer-length 1024)

  (define check-option ; for Chez Scheme list-based file open options
    (lambda (who x y)
      (when (and x (not (eq? x y)))
        ($oops who "incompatible options ~s and ~s" x y))))

  ;; Foreign calls to file system
  ;; use critical-section to increment/decrement disable count.
  ;; once we arrive in C code (e.g., bytevector-write) allow deactivation if
  ;; disable-count == 1.  this makes our port operations multitasking
  ;; safe (within a single posix thread if threaded).
  (define $open-input-fd
    (foreign-procedure "(cs)new_open_input_fd"
      (string boolean) scheme-object))
  (define $open-output-fd
    (foreign-procedure "(cs)new_open_output_fd"
      (string int
       boolean boolean boolean
       boolean boolean boolean boolean)
      scheme-object))
  (define $open-input/output-fd
    (foreign-procedure "(cs)new_open_input_output_fd"
      (string int
       boolean boolean boolean
       boolean boolean boolean boolean)
      scheme-object))
  (define $close-fd
    (foreign-procedure "(cs)close_fd"
      (scheme-object boolean) scheme-object))
  (define $bytevector-read
    (foreign-procedure "(cs)bytevector_read"
      (scheme-object scheme-object iptr iptr boolean) scheme-object))
  (define $bytevector-read-nb
    (foreign-procedure "(cs)bytevector_read_nb"
      (scheme-object scheme-object iptr iptr boolean) scheme-object))
  (define $bytevector-write
    (foreign-procedure "(cs)bytevector_write"
      (scheme-object scheme-object iptr iptr boolean) scheme-object))
  (define $put-byte
    (foreign-procedure "(cs)put_byte"
      (scheme-object int boolean) scheme-object))
  (define $set-fd-pos
    (foreign-procedure "(cs)set_fd_pos"
      (scheme-object scheme-object boolean) scheme-object))
  (define $get-fd-pos
    (foreign-procedure "(cs)get_fd_pos"
      (scheme-object boolean) scheme-object))
  (define $get-fd-nonblocking
    (foreign-procedure "(cs)get_fd_non_blocking"
      (scheme-object boolean) scheme-object))
  (define $set-fd-nonblocking
    (foreign-procedure "(cs)set_fd_non_blocking"
      (scheme-object boolean boolean) scheme-object))
  (define $get-fd-length
    (foreign-procedure "(cs)get_fd_length"
      (scheme-object boolean) scheme-object))
  (define $set-fd-length
    (foreign-procedure "(cs)set_fd_length"
      (scheme-object scheme-object boolean) scheme-object))
  (define $fd-regular?
    (foreign-procedure "(cs)fd_regularp" (int) boolean))
  (define $compress-input-fd
    (foreign-procedure "(cs)compress_input_fd" (int integer-64) scheme-object))
  (define $compress-output-fd
    (foreign-procedure "(cs)compress_output_fd" (int) scheme-object))
  (module (clear-open-files register-open-file registered-open-file? unregister-open-file)
    (define open-files #f)
    (define file-guardian)
    (define clear-open-files
     ; called from single-threaded $scheme-init
      (lambda ()
        (set! open-files (make-weak-eq-hashtable))
        (set! file-guardian (make-guardian))))
   ; should register only ports with known system handlers/transcoders
   ; we don't want to get into arbitrary user code when automatically
   ; closing.  when files are closed, we close text ports first, then
   ; binary ports, so it won't generally work to register a text port that
   ; depends on another text port being open or a binary port that
   ; depends on another binary port being open.
    (define register-open-file
      (lambda (p)
        (when open-files
          (with-tc-mutex
            (eq-hashtable-set! open-files p #t)
            (file-guardian p)))))
    (define registered-open-file?
      (lambda (p)
        (and open-files
          (with-tc-mutex
            (eq-hashtable-contains? open-files p)))))
    (define unregister-open-file
      (lambda (p)
        (when open-files
          (with-tc-mutex
            (eq-hashtable-delete! open-files p)))))
    (define silent-close
      (lambda (pvec)
       ; do textual ports first, since they may encapsulate a binary port
        (vector-for-each
          (lambda (x)
            (when (textual-port? x)
              (guard (c [#t (void)]) (close-port x))))
           pvec)
       ; now do binary ports
        (vector-for-each
          (lambda (x)
            (when (binary-port? x)
              (guard (c [#t (void)]) (close-port x))))
           pvec)))
    (set! $close-resurrected-files
     ; called from single-threaded docollect
      (lambda ()
        (when open-files
          (silent-close
            (let f ([i 0])
              (let ([p (file-guardian)])
                (if p
                    (let ([v (f (fx+ i 1))]) (vector-set! v i p) v)
                      (make-vector i))))))))
    (set! $close-files
     ; called from Sscheme_deinit
      (lambda ()
        (with-tc-mutex
          ; don't attempt to close ports if other threads are still running, since the other threads might be
          ; using one or more of the ports up to the bitter end, and port operations are not thread-safe when
          ; two threads operate on the same port.  in particular, trying to close a compressed port here and
          ; in one of the other threads concurrently can result in a double free in gzclose.
          (when (and open-files (if-feature pthreads (= (length ($thread-list)) 1) #t))
            (silent-close (hashtable-keys open-files)))))))

  ;; Helpers for binary-file-ports
  (define (extract-permission-mask options)
    (fxlogor
      (if (enum-set-subset? (file-options perm-set-user-id) options) #o4000 0)
      (if (enum-set-subset? (file-options perm-set-group-id) options) #o2000 0)
      (if (enum-set-subset? (file-options perm-sticky) options) #o1000 0)
      (if (enum-set-subset? (file-options perm-no-user-read) options) 0 #o400)
      (if (enum-set-subset? (file-options perm-no-user-write) options) 0 #o200)
      (if (enum-set-subset? (file-options perm-user-execute) options) #o100 0)
      (if (enum-set-subset? (file-options perm-no-group-read) options) 0 #o40)
      (if (enum-set-subset? (file-options perm-no-group-write) options) 0 #o20)
      (if (enum-set-subset? (file-options perm-group-execute) options) #o10 0)
      (if (enum-set-subset? (file-options perm-no-other-read) options) 0 #o4)
      (if (enum-set-subset? (file-options perm-no-other-write) options) 0 #o2)
      (if (enum-set-subset? (file-options perm-other-execute) options) #o1 0)))

  (define-syntax do-read
    (syntax-rules ()
      [(_ read p_)
       (let ([p p_])
         (do-read read p
                  (binary-port-input-buffer p)
                  0 (bytevector-length (binary-port-input-buffer p))))]
      [(_ read p_ buffer start count)
       (let ([p p_])
         (read ($port-info p) buffer start count (port-gz-mode p)))]))
  (define-syntax bytevector-read
    (syntax-rules ()
      [(_ args ...) (do-read $bytevector-read args ...)]))
  (define-syntax bytevector-read-nb
    (syntax-rules ()
      [(_ args ...) (do-read $bytevector-read-nb args ...)]))

  (define bytevector-write
    (lambda (who p buffer start count)
      (let ([n ($bytevector-write ($port-info p) buffer start count (port-gz-mode p))])
        (unless (fixnum? n) (write-oops who p n))
        n)))

  (define bytevector-flush
    (lambda (who p buffer start count)
      (let ([fd ($port-info p)] [gz (port-gz-mode p)])
        (let loop ([start start] [count count])
          (unless (eq? 0 count)
            (let ([n ($bytevector-write fd buffer start count gz)])
              (unless (fixnum? n) (write-oops who p n))
              (loop (fx+ start n) (fx- count n))))))))

  (define binary-file-port-flush
    (lambda (who p)
      (bytevector-flush who p (binary-port-output-buffer p) 0
        (binary-port-output-index p))
      (set-binary-port-output-index! p 0)))

  (define binary-file-port-ready?
    (lambda (who p)
      (or (not (port-input-empty? p))
          (port-flag-eof-set? p)
          (let ([n (bytevector-read-nb p)])
            (cond
              [(fixnum? n) (set-binary-port-input-size! p n) (not (eq? n 0))]
              [(eof-object? n) (set-port-eof! p #t) #t]
              [(equal? n "interrupt") 'interrupt]
              [else (read-oops who p n)])))))

  (define binary-file-port-lookahead
    (lambda (who p)
      (cond
        [(not (port-input-empty? p))
         (bytevector-u8-ref (binary-port-input-buffer p)
                            (binary-port-input-index p))]
        [(port-flag-eof-set? p) (eof-object)]
        [else (let loop ()
                (let ([n (bytevector-read p)])
                  (cond
                    [(eq? 0 n) (loop)]
                    [(fixnum? n)
                     (set-binary-port-input-size! p n)
                     (bytevector-u8-ref (binary-port-input-buffer p) 0)]
                    [(eof-object? n) (set-port-eof! p #t) n]
                    [(equal? n "interrupt") 'interrupt]
                    [else (read-oops who p n)])))])))

  (define binary-file-port-unget
    (lambda (who p x)
      (when (port-flag-eof-set? p) (unget-error who p x))
      (if (eof-object? x)
          (let ()
            (unless (port-input-empty? p) (unget-error who p x))
            (set-port-eof! p #t))
          (let ([index (binary-port-input-index p)])
            (when (eq? 0 index) (unget-error who p x))
            (set-binary-port-input-index! p (fx1- index))))))

  (define binary-file-port-get
    (lambda (who p)
      (cond
        [(not (port-input-empty? p))
         (let ([index (binary-port-input-index p)])
           (set-binary-port-input-index! p (fx1+ index))
           (bytevector-u8-ref (binary-port-input-buffer p) index))]
        [(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
        [else (let loop ()
                (let ([n (bytevector-read p)])
                  (cond
                    [(eq? 0 n) (loop)]
                    [(fixnum? n)
                     (set-binary-port-input-size! p n)
                     (set-binary-port-input-index! p 1)
                     (bytevector-u8-ref (binary-port-input-buffer p) 0)]
                    [(eof-object? n) n]
                    [(equal? n "interrupt") 'interrupt]
                    [else (read-oops who p n)])))])))

  (define binary-file-port-get-some
    (lambda (who p bv start count)
      (let ([port-count (binary-port-input-count p)])
        (cond
          [(not (eq? 0 port-count))
           (let ([count (fxmin count port-count)]
                 [index (binary-port-input-index p)])
             (bytevector-copy! (binary-port-input-buffer p) index bv start count)
             (set-binary-port-input-index! p (fx+ index count))
             count)]
          [(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
          [(and (fx<= count max-get-copy) (fx<= count (bytevector-length (binary-port-input-buffer p))))
           (let ([n (bytevector-read p)])
             (cond
               [(fixnum? n)
                (let ([count (fxmin n count)])
                  (set-binary-port-input-size! p n)
                  (set-binary-port-input-index! p count)
                  (bytevector-copy! (binary-port-input-buffer p) 0 bv start count)
                  count)]
               [(eof-object? n) n]
               [(equal? n "interrupt") 'interrupt]
               [else (read-oops who p n)]))]
          [else (let ([n (bytevector-read p bv start count)])
                  (cond
                    [(fixnum? n) n]
                    [(eof-object? n) n]
                    [(equal? n "interrupt") 'interrupt]
                    [else (read-oops who p n)]))]))))

  (define binary-file-port-clear-input
    (lambda (who p)
      (set-binary-port-input-size! p 0)))

  (define binary-file-port-put
    (lambda (who p x)
      (let ([index (binary-port-output-index p)]
            [buffer (binary-port-output-buffer p)])
        (cond
          [(not (port-output-full? p))
           (bytevector-u8-set! buffer index x)
           (set-binary-port-output-index! p (fx1+ index))]
          [(fx= index 0) ; since full, => size is 0 => unbuffered
           (let loop ()
             (let ([n ($put-byte ($port-info p) x (port-gz-mode p))])
               (unless (fixnum? n) (write-oops who p n))
               (when (fx= n 0) (loop))))]
          [else
           (bytevector-u8-set! buffer index x)
           (bytevector-flush who p buffer 0 (fx1+ index))
           (set-binary-port-output-index! p 0)]))))

  ;; The following diagram shows the control flow of put-some.
  ;; It is complicated because it must handle nonblocking ports
  ;; while also trying to minimize the number of operating system calls and
  ;; being smart about when to buffer.
  ;;
  ;; Arrows marked with "@" are guarded with a try-fill that
  ;; will try to exit the function early by copying the new bytevector
  ;; into the old bytevector.  Arrows marked with "@@" are the same
  ;; but in future versions might be willing to partially copy
  ;; the old buffer where as the "@" lines will only copy if
  ;; the entire new data fits in the old buffer.
  ;;
  ;; old is the port's buffer
  ;; new is the byte vector being passed in
  ;;
  ;; len(x)=0 tests whether x is empty and returns #t or #f
  ;; write(x) writes the old buffer to the operating system and
  ;;   returns either ALL if all data was written or PARTIAL if
  ;;   one part of the data was written
  ;; shift(old) bytevector copies to the front of old
  ;;   the part of old that wasn't written

  #|
   --@-> len(old)=0 --(#f)--> write(old) --(PARTIAL)--> shift(old) --@@--> DONE
             |                   |
             |                   |
            (#t) <---@---(ALL)---+
             |
             V
         len(new)=0 --(#f)--> write(new) --(PARTIAL)-----------------@@--> DONE
             |                   |
             |                   |
            (#t)               (ALL)
             |                   |
             V                   V
            DONE                DONE
  |#

  (define binary-file-port-put-some
    (lambda (who p bv start count)
      ;; from-start: where to fill from
      ;; from-count: how much to fill from (i.e. how much we want to put)
      ;; to-start: where to fill to
      ;; to-count: how much to fill to (i.e. how much room we have)
      ;; body: what to do if not filling
      (define-syntax try-fill
        (syntax-rules ()
          [(_ from-start from-count to-start to-count body)
           (if (and (fx<= from-count max-put-copy)
                    (fx<= from-count to-count))
               (begin
                 (bytevector-copy! bv from-start
                                   (binary-port-output-buffer p) to-start
                                   from-count)
                 (set-binary-port-output-index! p (fx+ to-start from-count))
                 (fx+ (fx- from-start start) from-count))
               body)]))

      ;; buffer: what to write from
      ;; start: where to write from
      ;; count: how much to write from
      ;; (n): var to bind to how many written
      ;; zero: what to do if count is zero
      ;; normal: what to do if all count written
      ;; interrupted: what to do not all count written
      (define-syntax try-write
        (syntax-rules ()
          [(_ buffer start count (n) zero normal partial)
           (if (eq? 0 count)
               zero
               (let ([n (bytevector-write who p buffer start count)])
                 (if (eq? n count)
                     normal
                     partial)))]))

      ;; On entry: old buffer has been completely written
      ;; and we need to write the new buffer
      (define (write-new)
        (try-write bv start count (n) 0 count
          (try-fill (fx+ start n) (fx- count n) 0 (binary-port-output-size p) n)))

      (let ([port-index (binary-port-output-index p)]
            [port-count (binary-port-output-count p)]
            [port-size (binary-port-output-size p)]
            [port-buffer (binary-port-output-buffer p)])
        (try-fill start count port-index port-count
          (try-write port-buffer 0 port-index (n)
            (write-new)
            (try-fill start count 0 port-size
              (begin
                (set-binary-port-output-index! p 0) ;; may be reset by try-fill
                (write-new)))
            (let ([new-index (fx- port-index n)])
              (bytevector-copy! port-buffer n port-buffer 0 new-index)
              (set-binary-port-output-index! p new-index)
              (try-fill start count new-index (fx- port-size new-index) 0)))))))

  (define binary-file-port-clear-output
    (lambda (who p)
      (set-binary-port-output-index! p 0)))

  (define binary-file-port-close-port
    (lambda (who p)
      (when (input-port? p)
        (set-port-eof! p #f)
        (set-binary-port-input-size! p 0))
      (when (output-port? p) (set-binary-port-output-size! p 0))
      (unregister-open-file p)
      ; mark port closed before closing fd.  if an interrupt occurs, we'd prefer
      ; that the fd's resources never be freed than to have an open port floating
      ; around with fd resources that have already been freed.
      (mark-port-closed! p)
      (let ([msg ($close-fd ($port-info p) (port-gz-mode p))])
        (unless (eq? #t msg) (port-oops who p msg)))))

  (define-syntax binary-file-port-port-position
    (syntax-rules ()
      [(_ mode who ?p)
       (member (datum mode) '(in out in/out))
       (let ([p ?p])
         (let ([n ($get-fd-pos ($port-info p) (port-gz-mode p))])
           (unless (or (fixnum? n) (bignum? n)) (port-oops who p n))
           (- (+ n (if (eq? 'mode 'in) 0 (binary-port-output-index p)))
              (if (eq? 'mode 'out) 0 (binary-port-input-count p)))))]))

  (define binary-file-port-set-port-position!
    (lambda (who p x)
      (unless (and (integer? x) (exact? x) (<= 0 x (- (expt 2 63) 1)))
        ($oops who "~s is not a valid position" x))
      (let ([n ($set-fd-pos ($port-info p) x (port-gz-mode p))])
        (unless (eq? n #t) (position-oops who p x n)))))

  (define binary-file-port-port-nonblocking?
    (lambda (who p)
      (let ([n ($get-fd-nonblocking ($port-info p) (port-gz-mode p))])
        (unless (boolean? n) (port-oops who p n))
        n)))

  (define binary-file-port-set-port-nonblocking!
    (lambda (who p x)
      (let ([n ($set-fd-nonblocking ($port-info p) x (port-gz-mode p))])
        (unless (eq? n #t) (port-oops who p n)))))

  (define binary-file-port-port-length
    (lambda (who p)
      (let ([n ($get-fd-length ($port-info p) (port-gz-mode p))])
        (unless (or (fixnum? n) (bignum? n)) (port-oops who p n))
        n)))

  (define binary-file-port-set-port-length!
    (lambda (who p x)
      (unless (and (integer? x) (exact? x) (<= 0 x (- (expt 2 63) 1)))
        ($oops who "~s is not a valid length" x))
      (let ([n ($set-fd-length ($port-info p) x (port-gz-mode p))])
        (unless (eq? n #t) (port-oops who p n)))))

  ;; Helpers for binary-custom-ports
  (define (bv-read! who p read! bv start count)
    (let ([n (read! bv start count)])
      (unless (and (fixnum? n) (fx<= 0 n count))
        ($oops who "invalid result ~s from read! on ~s" n p))
      n))

  (define (binary-port-read! who p read!)
    (let ([bv (binary-port-input-buffer p)])
      (let ([n (bv-read! who p read! bv 0 (bytevector-length bv))])
        (if (eq? 0 n)
            (eof-object)
            (begin
              (set-binary-port-input-size! p n)
              (bytevector-u8-ref bv 0))))))

  (define bv-write! ;; loops until count written
    (lambda (who p write! bv start count)
      (let loop ([start start]
                 [count count])
        (unless (eq? 0 count)
          (let ([result (write! bv start count)])
            (unless (and (fixnum? result) (fx<= 0 result count))
              ($oops who "invalid result ~s from write! on ~s" result p))
            (loop (fx+ start result) (fx- count result)))))))

  (define binary-custom-port-lookahead
    (lambda (who p read!)
      (cond
        [(not (port-input-empty? p))
         (bytevector-u8-ref (binary-port-input-buffer p)
                            (binary-port-input-index p))]
        [(port-flag-eof-set? p) (eof-object)]
        [else (let ([x (binary-port-read! who p read!)])
                (when (eof-object? x)
                  (set-port-eof! p #t))
                x)])))

  (define binary-custom-port-unget
    (lambda (who p x)
      (when (port-flag-eof-set? p) (unget-error who p x))
      (if (eof-object? x)
          (let ()
            (unless (port-input-empty? p) (unget-error who p x))
            (set-port-eof! p #t))
          (let ([index (binary-port-input-index p)])
            (when (eq? 0 index) (unget-error who p x))
            (set-binary-port-input-index! p (fx1- index))))))

  (define binary-custom-port-get
    (lambda (who p read!)
      (cond
        [(not (port-input-empty? p))
         (let ([index (binary-port-input-index p)])
           (set-binary-port-input-index! p (fx1+ index))
           (bytevector-u8-ref (binary-port-input-buffer p) index))]
        [(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
        [else (let ([x (binary-port-read! who p read!)])
                (unless (eof-object? x)
                  (set-binary-port-input-index! p 1))
                x)])))

  (define binary-custom-port-get-some
    (lambda (who p read! bv start count)
      (let ([port-count (binary-port-input-count p)])
        (cond
          [(not (eq? 0 port-count))
           (let ([count (fxmin count port-count)]
                 [index (binary-port-input-index p)])
             (bytevector-copy! (binary-port-input-buffer p) index bv start count)
             (set-binary-port-input-index! p (fx+ index count))
             count)]
          [(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
          [else (let ([n (bv-read! who p read! bv start count)])
                  (if (eq? 0 n)
                      (eof-object)
                      n))]))))

  (define binary-custom-port-clear-input
    (lambda (who p)
      (set-binary-port-input-size! p 0)))

  (define binary-custom-port-put
    (lambda (who p write! x)
      (let ([buffer (binary-port-output-buffer p)]
            [index (binary-port-output-index p)])
        (bytevector-u8-set! buffer index x)
        (let ([new-index (fx1+ index)])
          (if (port-output-full? p)
              (begin
                (bv-write! who p write! buffer 0 new-index)
                (set-binary-port-output-index! p 0))
              (set-binary-port-output-index! p new-index))))))

  (define binary-custom-port-put-some
    (lambda (who p write! bv start count)
      (if (and (fx<= count max-put-copy) (fx<= count (binary-port-output-count p)))
          (begin
            (let ([index (binary-port-output-index p)])
              (bytevector-copy! bv start
                                (binary-port-output-buffer p) index
                                count)
              (set-binary-port-output-index! p (fx+ index count))
              count))
          (begin
            (bv-write! who p write! (binary-port-output-buffer p)
                       0 (binary-port-output-index p))
            (bv-write! who p write! bv start count)
            (set-binary-port-output-index! p 0)
            count))))

  (define-syntax binary-custom-port-flush
    (syntax-rules ()
      [(_ who p_ write!)
       (let ([p p_])
         (bv-write! who p write! (binary-port-output-buffer p)
                    0 (binary-port-output-index p))
         (set-binary-port-output-index! p 0))]))

  (define binary-custom-port-clear-output
    (lambda (who p)
      (set-binary-port-output-index! p 0)))

  (define binary-custom-port-close-port
    (lambda (who p close)
      (when close (close))
      (mark-port-closed! p)
      (when (input-port? p)
        (set-port-eof! p #f)
        (set-binary-port-input-size! p 0))
      (when (output-port? p) (set-binary-port-output-size! p 0))))

  (define-syntax binary-custom-port-port-position
    (syntax-rules ()
      [(_ mode who ?p get-position)
       (member (datum mode) '(in out in/out))
       (let ([p ?p])
         (let ([n (get-position)])
           (unless (or (and (fixnum? n) (fx>= n 0)) (and (bignum? n) (>= n 0)))
             ($oops who "invalid result ~s from get-position on ~s" n p))
           (- (+ n (if (eq? 'mode 'in) 0 (binary-port-output-index p)))
              (if (eq? 'mode 'out) 0 (binary-port-input-count p)))))]))

  ;; Helpers for textual-custom-ports
  (define (str-read! who p read! str start count)
    (let ([n (read! str start count)])
      (unless (and (fixnum? n) (fx<= 0 n count))
        ($oops who "invalid result ~s from read! on ~s" n p))
      n))

  (define (textual-port-read! who p read!)
    (let ([str (textual-port-input-buffer p)])
      (let ([n (str-read! who p read! str 0 (string-length str))])
        (if (fx= n 0)
            (eof-object)
            (begin
              (set-textual-port-input-size! p n)
              (string-ref str 0))))))

  (define str-write! ;; loops until count written
    (lambda (who p write! str start count)
      (let loop ([start start] [count count])
        (unless (fx= count 0)
          (let ([result (write! str start count)])
            (unless (and (fixnum? result) (fx<= 0 result count))
              ($oops who "invalid result ~s from write! on ~s" result p))
            (loop (fx+ start result) (fx- count result)))))))

  (define textual-custom-port-lookahead
    (lambda (who p read!)
      (cond
        [(not (port-input-empty? p))
         (string-ref
           (textual-port-input-buffer p)
           (textual-port-input-index p))]
        [(port-flag-eof-set? p) (eof-object)]
        [else
         (let ([x (textual-port-read! who p read!)])
           (when (eof-object? x) (set-port-eof! p #t))
           x)])))

  (define textual-custom-port-unget
    (lambda (who p x)
      (when (port-flag-eof-set? p) (unget-error who p x))
      (if (eof-object? x)
          (let ()
            (unless (port-input-empty? p) (unget-error who p x))
            (set-port-eof! p #t))
          (let ([index (textual-port-input-index p)])
            (when (eq? 0 index) (unget-error who p x))
            (set-textual-port-input-index! p (fx1- index))))))

  (define textual-custom-port-get
    (lambda (who p read!)
      (cond
        [(not (port-input-empty? p))
         (let ([index (textual-port-input-index p)])
           (set-textual-port-input-index! p (fx1+ index))
           (string-ref (textual-port-input-buffer p) index))]
        [(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
        [else (let ([x (textual-port-read! who p read!)])
                (unless (eof-object? x)
                  (set-textual-port-input-index! p 1))
                x)])))

  (define textual-custom-port-get-some
    (lambda (who p read! str start count)
      (let ([port-count (textual-port-input-count p)])
        (cond
          [(not (fx= port-count 0))
           (let ([count (fxmin count port-count)]
                 [index (textual-port-input-index p)])
             (string-copy! (textual-port-input-buffer p) index str start count)
             (set-textual-port-input-index! p (fx+ index count))
             count)]
          [(port-flag-eof-set? p) (set-port-eof! p #f) (eof-object)]
          [else (let ([n (str-read! who p read! str start count)])
                  (if (eq? 0 n)
                      (eof-object)
                      n))]))))

  (define textual-custom-port-clear-input
    (lambda (who p)
      (set-textual-port-input-size! p 0)))

  (define textual-custom-port-put
    (lambda (who p write! x)
      (let ([buffer (textual-port-output-buffer p)]
            [index (textual-port-output-index p)])
        (string-set! buffer index x)
        (let ([new-index (fx1+ index)])
          (if (port-output-full? p)
              (begin
                (str-write! who p write! buffer 0 new-index)
                (set-port-bol! p (eol-char? (string-ref buffer index)))
                (set-textual-port-output-index! p 0))
              (set-textual-port-output-index! p new-index))))))

  (define textual-custom-port-put-some
    (lambda (who p write! str start count)
      (if (and (fx<= count max-put-copy) (fx<= count (textual-port-output-count p)))
          (begin
            (let ([index (textual-port-output-index p)])
              (string-copy! str start
                            (textual-port-output-buffer p) index
                            count)
              (set-textual-port-output-index! p (fx+ index count))
              count))
          (begin
            (str-write! who p write! (textual-port-output-buffer p)
                        0 (textual-port-output-index p))
            (str-write! who p write! str start count)
            (set-textual-port-output-index! p 0)
            (set-port-bol! p (eol-char? (string-ref str (fx- (fx+ start count) 1))))
            count))))

  (define textual-custom-port-flush
    (lambda (who p write!)
      (let ([n (textual-port-output-index p)])
        (unless (fx= n 0)
          (let ([buffer (textual-port-output-buffer p)])
            (str-write! who p write! buffer 0 n)
            (set-port-bol! p (eol-char? (string-ref buffer (fx- n 1))))
            (set-textual-port-output-index! p 0))))))

  (define textual-custom-port-clear-output
    (lambda (who p)
      (set-textual-port-output-index! p 0)))

  (define textual-custom-port-close-port
    (lambda (who p close)
      (when close (close))
      (mark-port-closed! p)
      (when (input-port? p)
        (set-port-eof! p #f)
        (set-textual-port-input-size! p 0))
      (when (output-port? p) (set-textual-port-output-size! p 0))))

  (define-syntax check-interrupt
    (syntax-rules ()
      [(_ e)
       (let loop ()
         (let ([x e])
           (if (eq? x 'interrupt)
               (begin ($event) (loop))
               x)))]))

  (module (open-binary-fd-input-port)
    ;; NOTE: port-info stores the file descriptor number or gzFile object
    (define (make-binary-file-input-handler regular?)
      (make-port-handler
        [ready?
         (lambda (who p)
           (check-interrupt
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-ready? who p))))]
        [lookahead
         (lambda (who p)
           (check-interrupt
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-lookahead who p))))]
        [unget
         (lambda (who p x)
           (critical-section
             (assert-not-closed who p)
             (binary-file-port-unget who p x)))]
        [get
         (lambda (who p)
           (check-interrupt
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-get who p))))]
        [get-some
         (lambda (who p bv start count)
           (check-interrupt
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-get-some who p bv start count))))]
        [clear-input
         (lambda (who p)
           (critical-section
             (assert-not-closed who p)
             (binary-file-port-clear-input who p)))]
        [put #f]
        [put-some #f]
        [flush #f]
        [clear-output #f]
        [close-port
         (lambda (who p)
           (critical-section
             (unless (port-closed? p)
               (binary-file-port-close-port who p))))]
        [port-position
         (and regular?
           (lambda (who p)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-port-position in who p))))]
        [set-port-position!
         (and regular?
           (lambda (who p x)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-set-port-position! who p x)
               (set-binary-port-input-size! p 0) ;; junk the buffer data
               (set-port-eof! p #f))))]
        [port-length
         (and regular?
           (lambda (who p)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-port-length who p))))]
        [set-port-length! #f]
        [port-nonblocking?
         (if-feature windows #f
           (lambda (who p)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-port-nonblocking? who p))))]
        [set-port-nonblocking!
         (if-feature windows #f
           (lambda (who p x)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-set-port-nonblocking! who p x))))]))

    (define open-binary-fd-input-port
      (lambda (who name fd regular? mode gzflag)
        (let ([buffer-length (if (eq? mode (buffer-mode none))
                                 minimum-file-buffer-length
                                 (file-buffer-size))])
          (let ([p ($make-binary-input-port
                    name ;; name
                    (make-binary-file-input-handler regular?) ;; handler
                    (make-bytevector buffer-length) ;; buffer
                    fd)]) ;; info
            (if (eq? mode (buffer-mode block))
                ($set-port-flags! p (constant port-flag-block-buffered))
                (when (eq? mode (buffer-mode line))
                  ($set-port-flags! p (constant port-flag-line-buffered))))
            ($set-port-flags! p (constant port-flag-file))
            (when gzflag
              ($set-port-flags! p (constant port-flag-compressed)))
            ;; size is set by $make-binary-input-port, but
            ;; we want it to trip the handler the first time so
            ;; re-set the size to zero
            (set-binary-port-input-size! p 0)
            (register-open-file p)
            p)))))

  (module (open-binary-fd-output-port)
    ;; NOTE: output-size is one less than actual buffer size so
    ;; we always have a place to put data before calling write
    (define (make-binary-file-output-handler regular?)
      (make-port-handler
        [ready? #f]
        [lookahead #f]
        [unget #f]
        [get #f]
        [get-some #f]
        [clear-input #f]
        [put
         (lambda (who p x)
           (critical-section
             (assert-not-closed who p)
             (binary-file-port-put who p x)))]
        [put-some
         (lambda (who p bv start count)
           (critical-section
             (assert-not-closed who p)
             (binary-file-port-put-some who p bv start count)))]
        [flush
         (lambda (who p)
           (critical-section
             (assert-not-closed who p)
             (binary-file-port-flush who p)))]
        [clear-output
         (lambda (who p)
           (critical-section
             (assert-not-closed who p)
             (binary-file-port-clear-output who p)))]
        [close-port
         (lambda (who p)
           (critical-section
             (unless (port-closed? p)
               (binary-file-port-flush who p)
               (binary-file-port-close-port who p))))]
        [port-position
         (and regular?
           (lambda (who p)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-port-position out who p))))]
        [set-port-position!
         (and regular?
           (lambda (who p x)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-flush who p)
               (binary-file-port-set-port-position! who p x))))]
        [port-length
         (and regular?
           (lambda (who p)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-flush who p)
               (binary-file-port-port-length who p))))]
        [set-port-length!
         (and regular?
           (lambda (who p x)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-flush who p)
               (binary-file-port-set-port-length! who p x))))]
        [port-nonblocking?
         (if-feature windows #f
           (lambda (who p)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-port-nonblocking? who p))))]
        [set-port-nonblocking!
         (if-feature windows #f
           (lambda (who p x)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-set-port-nonblocking! who p x))))]))

    (define open-binary-fd-output-port
      (lambda (who name fd regular? b-mode lock compressed)
        (let ([buffer-length (if (eq? b-mode (buffer-mode none))
                                 minimum-file-buffer-length
                                 (file-buffer-size))])
          (let ([p ($make-binary-output-port
                    name ;; name
                    (make-binary-file-output-handler regular?) ;; handler
                    (make-bytevector buffer-length) ;; buffer
                    fd)]) ;; info
            (if (eq? b-mode (buffer-mode block))
                ($set-port-flags! p (constant port-flag-block-buffered))
                (when (eq? b-mode (buffer-mode line))
                  ($set-port-flags! p (constant port-flag-line-buffered))))
            ($set-port-flags! p (constant port-flag-file))
            (when compressed
              ($set-port-flags! p (constant port-flag-compressed)))
            (when lock
              ($set-port-flags! p (constant port-flag-exclusive)))
            (set-binary-port-output-size! p (fx1- buffer-length)) ;; leave room for put to work
            (register-open-file p)
            p)))))

  (module (open-binary-fd-input/output-port)
    ;; Two modes: ready-for-input and ready-for-output
    ;;
    ;; ready-for-input: output-size == 0
    ;; ready-for-output: output-size == length-1 and input-size == 0
    ;;
    ;; unbuffered port (ports with length 1 buffers) may be both
    ;; ready-for-input and ready-for-output simultaneously,
    ;; but it is never the case that both
    ;; output-size != 0 and input-size != 0
    ;;
    ;; for our purposes having the eof flag set is the same as input-size != 0

    (define-syntax make-ready-for-input
      (syntax-rules ()
        [(_ who p_)
         (let ([p p_])
           (unless (eq? 0 (binary-port-output-size p))
             (binary-file-port-flush who p)
             ;; don't set input-size; it is set only after a read
             (set-binary-port-output-size! p 0)))]))

    (module ((make-ready-for-output $make-ready-for-output))
      (define $make-ready-for-output
        (lambda (who p)
          (unless (eq? (binary-port-input-size p) 0)
            (unless (port-input-empty? p)
              (binary-file-port-set-port-position! who p
                (binary-file-port-port-position in/out who p)))
            (set-binary-port-input-size! p 0))
          (set-port-eof! p #f)
          (set-binary-port-output-size! p
            (fx1- (bytevector-length (binary-port-output-buffer p))))))

      (define-syntax make-ready-for-output
        (syntax-rules ()
          [(_ ?who ?p)
           (let ([p ?p])
             (when (eq? (binary-port-output-size p) 0)
               ($make-ready-for-output ?who p)))])))

    (define (make-binary-file-input/output-handler regular?)
      (make-port-handler
        [ready?
         (lambda (who p)
           (check-interrupt
             (critical-section
               (assert-not-closed who p)
               (make-ready-for-input who p)
               (binary-file-port-ready? who p))))]
        [lookahead
         (lambda (who p)
           (check-interrupt
             (critical-section
               (assert-not-closed who p)
               (make-ready-for-input who p)
               (binary-file-port-lookahead who p))))]
        [unget
         (lambda (who p x)
           (critical-section
             (assert-not-closed who p)
             (make-ready-for-input who p)
             (binary-file-port-unget who p x)))]
        [get
         (lambda (who p)
           (check-interrupt
             (critical-section
               (assert-not-closed who p)
               (make-ready-for-input who p)
               (binary-file-port-get who p))))]
        [get-some
         (lambda (who p bv start count)
           (check-interrupt
             (critical-section
               (assert-not-closed who p)
               (make-ready-for-input who p)
               (binary-file-port-get-some who p bv start count))))]
        [clear-input
         (lambda (who p)
           (critical-section
             (assert-not-closed who p)
             (binary-file-port-clear-input who p)))]
        [put
         (lambda (who p x)
           (critical-section
             (assert-not-closed who p)
             (make-ready-for-output who p)
             (binary-file-port-put who p x)))]
        [put-some
         (lambda (who p bv start count)
           (critical-section
             (assert-not-closed who p)
             (make-ready-for-output who p)
             (binary-file-port-put-some who p bv start count)))]
        [flush
         (lambda (who p)
           (critical-section
             (assert-not-closed who p)
             (make-ready-for-output who p)
             (binary-file-port-flush who p)))]
        [clear-output
         (lambda (who p)
           (critical-section
             (assert-not-closed who p)
             (binary-file-port-clear-output who p)))]
        [close-port
         (lambda (who p)
           (critical-section
             (unless (port-closed? p)
               (binary-file-port-flush who p)
               (binary-file-port-close-port who p))))]
        [port-position
         (and regular?
           (lambda (who p)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-port-position in/out who p))))]
        [set-port-position!
         (and regular?
           (lambda (who p x)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-flush who p)
               (binary-file-port-set-port-position! who p x)
               (set-binary-port-input-size! p 0) ;; junk the buffer data
               (set-port-eof! p #f))))]
        [port-length
         (and regular?
           (lambda (who p)
             (critical-section
               (assert-not-closed who p)
               (binary-file-port-flush who p)
               (binary-file-port-port-length who p))))]
        [set-port-length!
         (and regular?
           (lambda (who p x)
             (critical-section
               (assert-not-closed who p)
               (cond
                 [(and (fx= (binary-port-input-size p) 0) (not (port-flag-eof-set? p)))
                  (binary-file-port-flush who p)
                  (binary-file-port-set-port-length! who p x)]
                 [else
                  (let ([pos (binary-file-port-port-position in/out who p)])
                    (set-binary-port-input-size! p 0) ;; junk the buffer data
                    (set-port-eof! p #f)
                    (binary-file-port-set-port-length! who p x)
                    (binary-file-port-set-port-position! who p pos))]))))]
        [port-nonblocking?
         (if-feature windows #f
           (lambda (who p)
             (critical-section
              (assert-not-closed who p)
              (binary-file-port-port-nonblocking? who p))))]
        [set-port-nonblocking!
         (if-feature windows #f
           (lambda (who p x)
             (critical-section
              (assert-not-closed who p)
              (binary-file-port-set-port-nonblocking! who p x))))]))

    (define open-binary-fd-input/output-port
      (lambda (who name fd regular? b-mode lock compressed)
        (let ([buffer-length (if (eq? b-mode (buffer-mode none))
                                 minimum-file-buffer-length
                                 (file-buffer-size))])
          (let ([p ($make-binary-input/output-port
                    name ;; name
                    (make-binary-file-input/output-handler regular?) ;; handler
                    (make-bytevector buffer-length) ;; input buffer
                    (make-bytevector buffer-length) ;; output buffer
                    fd)]) ;; info
            (if (eq? b-mode (buffer-mode block))
                ($set-port-flags! p (constant port-flag-block-buffered))
                (when (eq? b-mode (buffer-mode line))
                  ($set-port-flags! p (constant port-flag-line-buffered))))
            ($set-port-flags! p (constant port-flag-file))
            (when compressed
              ($set-port-flags! p (constant port-flag-compressed)))
            (when lock
              ($set-port-flags! p (constant port-flag-exclusive)))
            ;; size is set by $make-binary-input/output-port, but
            ;; we want it to trip the handler the first time so
            ;; re-set the size to zero
            (set-binary-port-input-size! p 0)
            (set-binary-port-output-size! p (fx1- buffer-length)) ;; leave room for put to work
            (register-open-file p)
            p)))))

;;;; Public functions
  ;; All section numbers are from ``R6RS -- Standard Libraries''

;;;; 8.1 Condition types (in exceptions.ss)

;;;; 8.2 Port I/O: (rnrs io ports (6))
;;;; 8.2.1 Filenames
;;;; 8.2.2 File options
  ;; file-options in syntax.ss
  (set-who! $file-options (make-enumeration (file-options-list)))
  (set-who! $make-file-options (enum-set-constructor $file-options))

;;;; 8.2.3 Buffer modes
  ;; buffer-mode in syntax.ss
  (set-who! buffer-mode?
    (lambda (mode) (and (memq mode '(none line block)) #t)))

;;;; 8.2.4 Transcoders
  (let ()
    (define (encode-oops who tp c)
      ($oops/c who
        (make-i/o-encoding-error tp c)
        (parameterize ([print-unicode #f])
          (let* ([tx (codec-info-tx ($port-info tp))]
                 [name (codec-name ($transcoder-codec tx))])
            (if (and (eqv? c #\newline) (not (memq ($transcoder-eol-style tx) '(none lf))))
                (format "~a codec cannot encode ~s with eol-style ~s"
                  name c ($transcoder-eol-style tx))
                (format "~a codec cannot encode ~s" name c))))))

    (define (decode-oops who tp msg . args)
      (apply $oops/c who
        (make-i/o-decoding-error tp)
         msg args))

    (define (flush-buffer who bp bv i k)
      (if (fx= k 0)
          0
          (let ([n (call-port-handler put-some who bp bv i k)])
            (if (fx= n 0)
                (begin
                  (unless (fx= i 0) (bytevector-copy! bv i bv 0 k))
                  k)
                (flush-buffer who bp bv (fx+ i n) (fx- k n))))))

    (define get-some-maybe-nb
     ; get some from binary port bp.  if ifready? is true, don't block if port
     ; isn't ready, even if port has not been set nonblocking
      (lambda (who bp bv start ifready?)
        (let ([h ($port-handler bp)])
         ; port-handler-ready? may raise an exception, but that's okay because ifready?
         ; is true only if this is called from transcoded-port's port-handler-ready?.
          (if (or (not ifready?) ((port-handler-ready? h) who bp))
              ((port-handler-get-some h) who bp bv start (fx- codec-buffer-length start))
              0))))

    (let ()
      (define latin-1-decode
        (let ()
          (define (return ans i iend cr? bytes info)
            (codec-info-next-set! info i)
            (codec-info-iend-set! info iend)
            (codec-info-ibytes-set! info bytes)
            (codec-info-icr-set! info cr?)
            ans)
          (lambda (who tp str start count ifready?)
            (let ([info ($port-info tp)])
              (let ([bp (codec-info-bp info)]
                    [ioffsets (and (eq? str (textual-port-input-buffer tp)) (codec-info-ioffsets info))]
                    [bv (codec-info-bv info)]
                    [jend (fx+ start count)])
                (let loop ([j start]
                           [i (codec-info-next info)]
                           [iend (codec-info-iend info)]
                           [cr? (codec-info-icr info)]
                           [bytes 0])
                  (cond
                    [(fx= j jend) (return count i iend cr? bytes info)]
                    [(fx= i iend)
                     (if (fx= j start)
                         (let ([n (get-some-maybe-nb who bp bv 0 ifready?)])
                           (cond
                             [(eof-object? n) (return #!eof i iend #f bytes info)]
                             [(fx= n 0) (return 0 i iend cr? bytes info)]
                             [else (loop j 0 n cr? bytes)]))
                        ; don't try to read in this case to avoid dealing with eof
                         (return (fx- j start) i iend cr? bytes info))]
                    [else
                     (let ([b (bytevector-u8-ref bv i)])
                       (cond
                         [(fx= b #x0d)
                          (cond
                            [(eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
                             (string-set! str j #\return)
                             (when ioffsets (fxvector-set! ioffsets j bytes))
                             (loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))]
                            [else
                             (string-set! str j #\newline)
                             (when ioffsets (fxvector-set! ioffsets j bytes))
                             (loop (fx+ j 1) (fx+ i 1) iend #t (fx+ bytes 1))])]
                         [(fx= b #x0a)
                          (cond
                            [cr? (loop j (fx+ i 1) iend #f (fx+ bytes 1))]
                            [else
                             (string-set! str j #\newline)
                             (when ioffsets (fxvector-set! ioffsets j bytes))
                             (loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))])]
                         [(fx= b #x85) ; NEL
                          (cond
                            [cr? (loop j (fx+ i 1) iend #f (fx+ bytes 1))]
                            [else
                             (string-set! str j
                               (if (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
                                   (integer->char #x85)
                                   #\newline))
                             (when ioffsets (fxvector-set! ioffsets j bytes))
                             (loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))])]
                         [else
                          (string-set! str j (integer->char b))
                          (when ioffsets (fxvector-set! ioffsets j bytes))
                          (loop (fx+ j 1) (fx+ i 1) iend #f (fx+ bytes 1))]))])))))))

      (define latin-1-encode
        (let ()
          (define (return ans o info)
            (codec-info-next-set! info o)
            ans)
          (lambda (who tp str start count)
            (let ([info ($port-info tp)])
              (let ([bp (codec-info-bp info)]
                    [bv (codec-info-bv info)]
                    [jend (fx+ start count)])
                (let loop ([j start] [o (codec-info-next info)])
                  (cond
                    [(fx= j jend) (return count o info)]
                    [(fx= o codec-buffer-length)
                     (let ([o (flush-buffer who bp bv 0 o)])
                       (if (fx= o codec-buffer-length)
                           (return (fx- j start) o info)
                           (loop j o)))]
                    [else
                     (let ([int (char->integer (string-ref str j))])
                       (cond
                         [(fx= int #x0a)
                          (let ([eol-style ($transcoder-eol-style (codec-info-tx info))])
                            (case eol-style
                              [(lf none)
                               (bytevector-u8-set! bv o #x0a)
                               (loop (fx+ j 1) (fx+ o 1))]
                              [(cr)
                               (bytevector-u8-set! bv o #x0d)
                               (loop (fx+ j 1) (fx+ o 1))]
                              [(nel)
                               (bytevector-u8-set! bv o #x85)
                               (loop (fx+ j 1) (fx+ o 1))]
                              [(crlf crnel)
                               (let f ([o o])
                                 (if (fx< o (fx- codec-buffer-length 1))
                                     (begin
                                       (bytevector-u8-set! bv o #x0d)
                                       (bytevector-u8-set! bv (fx+ o 1) (if (eq? eol-style 'crlf) #x0a #x85))
                                       (loop (fx+ j 1) (fx+ o 2)))
                                     (let ([new-o (flush-buffer who bp bv 0 o)])
                                       (if (fx= new-o o)
                                           (return (fx- j start) o info)
                                           (f new-o)))))]
                              [(ls)
                               (let ([error-mode ($transcoder-error-handling-mode (codec-info-tx info))])
                                 (case error-mode
                                   [(ignore) (loop (fx+ j 1) o)]
                                   [(replace)
                                    (bytevector-u8-set! bv o (char->integer #\?))
                                    (loop (fx+ j 1) (fx+ o 1))]
                                   [(raise) (encode-oops who tp #\newline)]
                                   [else ($oops who "unknown error handling mode ~s" error-mode)]))]
                              [else ($oops who "unrecognized eol style ~s" eol-style)]))]
                         [(fx<= int 255)
                          (bytevector-u8-set! bv o int)
                          (loop (fx+ j 1) (fx+ o 1))]
                         [else
                          (let ([error-mode ($transcoder-error-handling-mode (codec-info-tx info))])
                            (case ($transcoder-error-handling-mode (codec-info-tx info))
                              [(ignore) (loop (fx+ j 1) o)]
                              [(replace)
                               (bytevector-u8-set! bv o (char->integer #\?))
                               (loop (fx+ j 1) (fx+ o 1))]
                              [(raise) (encode-oops who tp (string-ref str j))]
                              [else ($oops who "unknown error handling mode ~s" error-mode)]))]))])))))))

      (set-who! latin-1-codec
        (let ()
          (define codec
            (make-codec
              [name "latin-1"]
              [make-info
               (lambda (who tx bp bv)
                 (make-codec-info tx bp bv 0 0
                   (and (input-port? bp) (make-fxvector (bytevector-length bv)))
                   0 #f #f #f #f
                   latin-1-decode latin-1-encode (lambda (info) #f)))]))
          (lambda () codec))))

    (let ()
      (define utf-8-decode
        (let ()
          (define (err who tp info i iend bytes b . b*)
            (codec-info-bom-set! info #f)
            (codec-info-next-set! info i)
            (codec-info-iend-set! info iend)
            (codec-info-ibytes-set! info (fx+ bytes 1 (length b*)))
            (codec-info-icr-set! info #f)
            (decode-oops who tp "invalid utf-8 encoding #x~2,'0x~{, ~a~}" b
              (map (lambda (b) (if (eof-object? b) "#!eof" (format "#x~2,'0x" b))) b*)))
          (define (eof-err who tp info i iend bytes)
            (unless (fx= bytes 0) (codec-info-bom-set! info #f))
            (codec-info-next-set! info iend)
            (codec-info-iend-set! info iend)
            (codec-info-ibytes-set! info (fx+ bytes (fx- iend i)))
            (codec-info-icr-set! info #f)
            (decode-oops who tp "unexpected end-of-file reading multibyte utf-8 encoding"))
          (define (return ans i iend cr? bytes info)
            (unless (fx= bytes 0) (codec-info-bom-set! info #f))
            (codec-info-next-set! info i)
            (codec-info-iend-set! info iend)
            (codec-info-ibytes-set! info bytes)
            (codec-info-icr-set! info cr?)
            ans)
          (lambda (who tp str start count ifready?)
            (let ([info ($port-info tp)])
              (let ([bp (codec-info-bp info)]
                    [ioffsets (and (eq? str (textual-port-input-buffer tp)) (codec-info-ioffsets info))]
                    [bv (codec-info-bv info)]
                    [jend (fx+ start count)])
                (define-syntax decode-error
                  (syntax-rules ()
                    [(_ j i iend bytes b1 b2 ...)
                     (case ($transcoder-error-handling-mode (codec-info-tx info))
                       [(ignore) j]
                       [(replace)
                        (string-set! str j #\xfffd)
                        (when ioffsets (fxvector-set! ioffsets j bytes))
                        (fx+ j 1)]
                       [else (err who tp info i iend bytes b1 b2 ...)])]))
                (define-syntax decode-eof-error
                  (syntax-rules ()
                    [(_ j i iend bytes)
                     (case ($transcoder-error-handling-mode (codec-info-tx info))
                       [(ignore) (return #!eof iend iend #f (fx+ bytes (fx- iend i)) info)]
                       [(replace)
                        (string-set! str j #\xfffd)
                        (when ioffsets (fxvector-set! ioffsets j bytes))
                        (return (fx- (fx+ j 1) start) iend iend #f (fx+ bytes (fx- iend i)) info)]
                       [else (eof-err who tp info i iend bytes)])]))
                (let loop ([j start]
                           [i (codec-info-next info)]
                           [iend (codec-info-iend info)]
                           [cr? (codec-info-icr info)]
                           [bytes 0])
                  (cond
                    [(fx= j jend) (pariah (return count i iend cr? bytes info))]
                    [(fx= i iend)
                     (pariah
                       (if (fx= j start)
                           (let ([n (get-some-maybe-nb who bp bv 0 ifready?)])
                             (cond
                               [(eof-object? n) (return #!eof 0 0 #f bytes info)]
                               [(fx= n 0) (return 0 0 0 cr? bytes info)]
                               [else (loop j 0 n cr? bytes)]))
                           ; don't try to read in this case to avoid dealing with eof
                           (return (fx- j start) i iend cr? bytes info)))]
                    [else
                     (let ([b1 (bytevector-u8-ref bv i)])
                       (cond
                         [(fx<= b1 #x7f) ; one-byte encoding
                          (cond
                            [(fx= b1 #x0d)
                             (pariah
                               (cond
                                 [(eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
                                  (string-set! str j #\return)
                                  (when ioffsets (fxvector-set! ioffsets j bytes))
                                  (loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))]
                                 [else
                                  (string-set! str j #\newline)
                                  (when ioffsets (fxvector-set! ioffsets j bytes))
                                  (loop (fx+ j 1) (fx+ i 1) iend #t (fx+ bytes 1))]))]
                            [(fx= b1 #x0a)
                             (pariah
                               (cond
                                 [cr? (loop j (fx+ i 1) iend #f (fx+ bytes 1))]
                                 [else
                                  (string-set! str j #\newline)
                                  (when ioffsets (fxvector-set! ioffsets j bytes))
                                  (loop (fx+ j 1) (fx+ i 1) iend cr? (fx+ bytes 1))]))]
                            [else
                             (string-set! str j (integer->char b1))
                             (when ioffsets (fxvector-set! ioffsets j bytes))
                             (loop (fx+ j 1) (fx+ i 1) iend #f (fx+ bytes 1))])]
                         [else
                          (pariah
                            (cond
                              [(fx<= #xc2 b1 #xdf) ; two-byte encoding
                               (let f ([i i] [iend iend])
                                 (if (fx< (fx+ i 1) iend) ; have at least two bytes?
                                     (let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
                                       (if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
                                           (let ([x (fxlogor (fxsll (fxlogand b1 #b11111) 6) (fxlogand b2 #b111111))]
                                                 [i (fx+ i 2)])
                                             (cond
                                               [(fx= x #x85) ; NEL
                                                (cond
                                                  [cr? (loop j i iend #f (fx+ bytes 2))]
                                                  [else
                                                   (string-set! str j
                                                     (if (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
                                                         (integer->char #x85)
                                                         #\newline))
                                                   (when ioffsets (fxvector-set! ioffsets j bytes))
                                                   (loop (fx+ j 1) i iend cr? (fx+ bytes 2))])]
                                               [else
                                                (string-set! str j (integer->char x))
                                                (when ioffsets (fxvector-set! ioffsets j bytes))
                                                (loop (fx+ j 1) i iend #f (fx+ bytes 2))]))
                                          ; second byte is not a continuation byte
                                           (let ([j (decode-error j (fx+ i 1) iend bytes b1)])
                                             (loop j (fx+ i 1) iend #f (fx+ bytes 1)))))
                                    ; have only one byte
                                     (begin
                                       (bytevector-u8-set! bv 0 b1)
                                       (let ([i 0] [iend 1])
                                         (let ([n (get-some-maybe-nb who bp bv iend ifready?)])
                                           (cond
                                             [(eof-object? n) (decode-eof-error j i iend bytes)]
                                             [(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
                                             [else (f i (fx+ iend n))]))))))]
                             [(fx<= #xe0 b1 #xef) ; three-byte encoding
                              (let f ([i i] [iend iend])
                                (if (fx< (fx+ i 1) iend) ; have at least two bytes?
                                    (let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
                                      (if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
                                          (if (fx< (fx+ i 2) iend) ; have at least three bytes?
                                              (let ([b3 (bytevector-u8-ref bv (fx+ i 2))])
                                                (if (fx= (fxsrl b3 6) #b10) ; third byte a continuation byte?
                                                    (let ([x (fxlogor
                                                               (fxsll (fxlogand b1 #b1111) 12)
                                                               (fxsll (fxlogand b2 #b111111) 6)
                                                               (fxlogand b3 #b111111))]
                                                          [i (fx+ i 3)])
                                                      (cond
                                                        [(and (fx= x #xfeff) (fx= bytes 0) (codec-info-bom info))
                                                         (loop j i iend #f (fx+ bytes 3))]
                                                        [(and (fx>= x #x800) (not (fx<= #xd800 x #xdfff)))
                                                         (string-set! str j
                                                           (if (and (fx= x #x2028) ; LS
                                                                    (not (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)))
                                                               #\newline
                                                               (integer->char x)))
                                                         (when ioffsets (fxvector-set! ioffsets j bytes))
                                                         (loop (fx+ j 1) i iend #f (fx+ bytes 3))]
                                                        [else
                                                         (let ([j (decode-error j i iend bytes b1 b2 b3)])
                                                           (loop j i iend #f (fx+ bytes 3)))]))
                                                   ; third byte is not a continuation byte
                                                    (let ([j (decode-error j (fx+ i 2) iend bytes b1 b2)])
                                                      (loop j (fx+ i 2) iend #f (fx+ bytes 2)))))
                                             ; have only two bytes
                                              (begin
                                                (bytevector-u8-set! bv 0 b1)
                                                (bytevector-u8-set! bv 1 b2)
                                                (let ([i 0] [iend 2])
                                                  (let ([n (get-some-maybe-nb who bp bv iend ifready?)])
                                                    (cond
                                                      [(eof-object? n) (decode-eof-error j i iend bytes)]
                                                      [(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
                                                      [else (f i (fx+ iend n))])))))
                                         ; second byte is not a continuation byte
                                          (let ([j (decode-error j (fx+ i 1) iend bytes b1)])
                                            (loop j (fx+ i 1) iend #f (fx+ bytes 1)))))
                                   ; have only one byte
                                    (begin
                                      (bytevector-u8-set! bv 0 b1)
                                      (let ([i 0] [iend 1])
                                        (let ([n (get-some-maybe-nb who bp bv iend ifready?)])
                                          (cond
                                            [(eof-object? n) (decode-eof-error j i iend bytes)]
                                            [(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
                                            [else (f i (fx+ iend n))]))))))]
                             [(fx<= #xf0 b1 #xf4) ; four-byte encoding
                              (let f ([i i] [iend iend])
                                (if (fx< (fx+ i 1) iend) ; have at least two bytes?
                                    (let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
                                      (if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
                                          (if (fx< (fx+ i 2) iend) ; have at least three bytes?
                                              (let ([b3 (bytevector-u8-ref bv (fx+ i 2))])
                                                (if (fx= (fxsrl b3 6) #b10) ; third byte a continuation byte?
                                                    (if (fx< (fx+ i 3) iend) ; have at least four bytes?
                                                        (let ([b4 (bytevector-u8-ref bv (fx+ i 3))])
                                                          (if (fx= (fxsrl b4 6) #b10) ; fourth byte a continuation byte?
                                                              (let ([x (fxlogor
                                                                         (fxsll (fxlogand b1 #b111) 18)
                                                                         (fxsll (fxlogand b2 #b111111) 12)
                                                                         (fxsll (fxlogand b3 #b111111) 6)
                                                                         (fxlogand b4 #b111111))]
                                                                    [i (fx+ i 4)])
                                                                (cond
                                                                  [(fx<= #x10000 x #x10ffff)
                                                                   (string-set! str j (integer->char x))
                                                                   (when ioffsets (fxvector-set! ioffsets j bytes))
                                                                   (loop (fx+ j 1) i iend #f (fx+ bytes 4))]
                                                                  [else
                                                                   (let ([j (decode-error j i iend bytes b1 b2 b3)])
                                                                     (loop j i iend #f (fx+ bytes 3)))]))
                                                             ; fourth byte is not a continuation byte
                                                              (let ([j (decode-error j (fx+ i 3) iend bytes b1 b2 b3)])
                                                                (loop j (fx+ i 3) iend #f (fx+ bytes 3)))))
                                                       ; have only three bytes
                                                        (begin
                                                          (bytevector-u8-set! bv 0 b1)
                                                          (bytevector-u8-set! bv 1 b2)
                                                          (bytevector-u8-set! bv 2 b3)
                                                          (let ([i 0] [iend 3])
                                                            (let ([n (get-some-maybe-nb who bp bv iend ifready?)])
                                                              (cond
                                                                [(eof-object? n) (decode-eof-error j i iend bytes)]
                                                                [(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
                                                                [else (f i (fx+ iend n))])))))
                                                   ; third byte is not a continuation byte
                                                    (let ([j (decode-error j (fx+ i 2) iend bytes b1 b2)])
                                                      (loop j (fx+ i 2) iend #f (fx+ bytes 2)))))
                                             ; have only two bytes
                                              (begin
                                                (bytevector-u8-set! bv 0 b1)
                                                (bytevector-u8-set! bv 1 b2)
                                                (let ([i 0] [iend 2])
                                                  (let ([n (get-some-maybe-nb who bp bv iend ifready?)])
                                                    (cond
                                                      [(eof-object? n) (decode-eof-error j i iend bytes)]
                                                      [(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
                                                      [else (f i (fx+ iend n))])))))
                                         ; second byte is not a continuation byte
                                          (let ([j (decode-error j (fx+ i 1) iend bytes b1)])
                                            (loop j (fx+ i 1) iend #f (fx+ bytes 1)))))
                                   ; have only one byte
                                    (begin
                                      (bytevector-u8-set! bv 0 b1)
                                      (let ([i 0] [iend 1])
                                        (let ([n (get-some-maybe-nb who bp bv iend ifready?)])
                                          (cond
                                            [(eof-object? n) (decode-eof-error j i iend bytes)]
                                            [(fx= n 0) (return (fx- j start) i iend cr? bytes info)]
                                            [else (f i (fx+ iend n))]))))))]
                             [else
                              (let ([j (decode-error j (fx+ i 1) iend bytes b1)])
                                (loop j (fx+ i 1) iend #f (fx+ bytes 1)))]))]))])))))))

      (define utf-8-encode
        (let ()
          (define (return ans o info)
            (codec-info-next-set! info o)
            ans)
          (define (write-two-byte bv o x)
            (bytevector-u8-set! bv o (fxlogor #b11000000 (fxsrl x 6)))
            (bytevector-u8-set! bv (fx+ o 1) (fxlogor #b10000000 (fxlogand x #b111111))))
          (define (write-three-byte bv o x)
            (bytevector-u8-set! bv o (fxlogor #b11100000 (fxsrl x 12)))
            (bytevector-u8-set! bv (fx+ o 1) (fxlogor #b10000000 (fxlogand (fxsrl x 6) #b111111)))
            (bytevector-u8-set! bv (fx+ o 2) (fxlogor #b10000000 (fxlogand x #b111111))))
          (lambda (who tp str start count)
            (let ([info ($port-info tp)])
              (codec-info-bom-set! info #f)
              (let ([bp (codec-info-bp info)]
                    [bv (codec-info-bv info)]
                    [jend (fx+ start count)])
                (let loop ([j start] [o (codec-info-next info)])
                  (cond
                    [(fx= j jend) (return count o info)]
                    [(fx= o codec-buffer-length)
                     (let ([o (flush-buffer who bp bv 0 o)])
                       (if (fx= o codec-buffer-length)
                           (return (fx- j start) o info)
                           (loop j o)))]
                    [else
                     (let ([x (char->integer (string-ref str j))])
                       (cond
                         [(fx= x #x0a)
                          (let ([eol-style ($transcoder-eol-style (codec-info-tx info))])
                            (case eol-style
                              [(lf none)
                               (bytevector-u8-set! bv o #x0a)
                               (loop (fx+ j 1) (fx+ o 1))]
                              [(cr)
                               (bytevector-u8-set! bv o #x0d)
                               (loop (fx+ j 1) (fx+ o 1))]
                              [(crlf nel)
                               (let f ([o o])
                                 (if (fx< o (fx- codec-buffer-length 1))
                                     (begin
                                       (case eol-style
                                         [(crlf)
                                          (bytevector-u8-set! bv o #x0d)
                                          (bytevector-u8-set! bv (fx+ o 1) #x0a)]
                                         [else (write-two-byte bv o #x85)])
                                       (loop (fx+ j 1) (fx+ o 2)))
                                     (let ([new-o (flush-buffer who bp bv 0 o)])
                                       (if (fx= new-o o)
                                           (return (fx- j start) o info)
                                           (f new-o)))))]
                              [(crnel ls)
                               (let f ([o o])
                                 (if (fx< o (fx- codec-buffer-length 2))
                                     (begin
                                       (case eol-style
                                         [(crnel)
                                          (bytevector-u8-set! bv o #x0d)
                                          (write-two-byte bv (fx+ o 1) #x85)]
                                         [else (write-three-byte bv o #x2028)])
                                       (loop (fx+ j 1) (fx+ o 3)))
                                     (let ([new-o (flush-buffer who bp bv 0 o)])
                                       (if (fx= new-o o)
                                           (return (fx- j start) o info)
                                           (f new-o)))))]
                              [else ($oops who "unrecognized eol style ~s" eol-style)]))]
                         [(fx<= x #x7f) ; one-byte encoding
                          (bytevector-u8-set! bv o x)
                          (loop (fx+ j 1) (fx+ o 1))]
                         [(fx<= x #x7ff) ; two-byte encoding
                          (let f ([o o])
                            (if (fx< o (fx- codec-buffer-length 1))
                                (begin
                                  (write-two-byte bv o x)
                                  (loop (fx+ j 1) (fx+ o 2)))
                                (let ([new-o (flush-buffer who bp bv 0 o)])
                                  (if (fx= new-o o)
                                      (return (fx- j start) o info)
                                      (f new-o)))))]
                         [(fx<= x #xffff) ; three-byte encoding
                          (let f ([o o])
                            (if (fx< o (fx- codec-buffer-length 2))
                                (begin
                                  (write-three-byte bv o x)
                                  (loop (fx+ j 1) (fx+ o 3)))
                                (let ([new-o (flush-buffer who bp bv 0 o)])
                                  (if (fx= new-o o)
                                      (return (fx- j start) o info)
                                      (f new-o)))))]
                         [else ; four-byte encoding
                          (let f ([o o])
                            (if (fx< o (fx- codec-buffer-length 3))
                                (begin
                                  (bytevector-u8-set! bv o (fxlogor #b11110000 (fxsrl x 18)))
                                  (bytevector-u8-set! bv (fx+ o 1) (fxlogor #b10000000 (fxlogand (fxsrl x 12) #b111111)))
                                  (bytevector-u8-set! bv (fx+ o 2) (fxlogor #b10000000 (fxlogand (fxsrl x 6) #b111111)))
                                  (bytevector-u8-set! bv (fx+ o 3) (fxlogor #b10000000 (fxlogand x #b111111)))
                                  (loop (fx+ j 1) (fx+ o 4)))
                                (let ([new-o (flush-buffer who bp bv 0 o)])
                                  (if (fx= new-o o)
                                      (return (fx- j start) o info)
                                      (f new-o)))))]))])))))))

      (set-who! utf-8-codec
        (let ()
          (define codec
            (make-codec
              [name "utf-8"]
              [make-info
               (lambda (who tx bp bv)
                 (make-codec-info tx bp bv 0 0
                   (and (input-port? bp) (make-fxvector (bytevector-length bv)))
                   0 #f #t #f #f
                   utf-8-decode utf-8-encode (lambda (info) #f)))]))
          (lambda () codec))))

    (let ()
      (define utf-16-decode
        (let ()
          (define (err who tp info i iend bytes b . b*)
            (codec-info-bom-set! info #f)
            (codec-info-next-set! info i)
            (codec-info-iend-set! info iend)
            (codec-info-ibytes-set! info (fx+ bytes 1 (length b*)))
            (codec-info-icr-set! info #f)
            (decode-oops who tp "invalid utf-16 encoding #x~2,'0x~{, ~a~}" b
              (map (lambda (b) (if (eof-object? b) "#!eof" (format "#x~2,'0x" b))) b*)))
          (define (eof-err who tp info i iend bytes)
            (unless (fx= bytes 0) (codec-info-bom-set! info #f))
            (codec-info-next-set! info iend)
            (codec-info-iend-set! info iend)
            (codec-info-ibytes-set! info (fx+ bytes (fx- iend i)))
            (codec-info-icr-set! info #f)
            (decode-oops who tp "unexpected end-of-file reading two-word utf-16 encoding"))
          (define (return ans i iend cr? bytes info)
            (unless (fx= bytes 0) (codec-info-bom-set! info #f))
            (codec-info-next-set! info i)
            (codec-info-iend-set! info iend)
            (codec-info-ibytes-set! info bytes)
            (codec-info-icr-set! info cr?)
            ans)
          (lambda (who tp str start count ifready?)
            (let ([info ($port-info tp)])
              (let ([bp (codec-info-bp info)]
                    [ioffsets (and (eq? str (textual-port-input-buffer tp)) (codec-info-ioffsets info))]
                    [bv (codec-info-bv info)]
                    [jend (fx+ start count)])
                (define-syntax decode-error
                  (syntax-rules ()
                    [(_ j i iend bytes b1 b2 ...)
                     (case ($transcoder-error-handling-mode (codec-info-tx info))
                       [(ignore) j]
                       [(replace)
                        (string-set! str j #\xfffd)
                        (when ioffsets (fxvector-set! ioffsets j bytes))
                        (fx+ j 1)]
                       [else (err who tp info i iend bytes b1 b2 ...)])]))
                (define-syntax decode-eof-error
                  (syntax-rules ()
                    [(_ j i iend bytes)
                     (case ($transcoder-error-handling-mode (codec-info-tx info))
                       [(ignore) (return #!eof iend iend #f (fx+ bytes (fx- iend i)) info)]
                       [(replace)
                        (string-set! str j #\xfffd)
                        (when ioffsets (fxvector-set! ioffsets j bytes))
                        (return (fx- (fx+ j 1) start) iend iend #f (fx+ bytes (fx- iend i)) info)]
                       [else (eof-err who tp info i iend bytes)])]))
                (let loop ([j start]
                           [i (codec-info-next info)]
                           [iend (codec-info-iend info)]
                           [cr? (codec-info-icr info)]
                           [bytes 0])
                  (cond
                    [(fx= j jend) (return count i iend cr? bytes info)]
                    [(fx= i iend)
                     (if (fx= j start)
                         (let ([n (get-some-maybe-nb who bp bv 0 ifready?)])
                           (cond
                             [(eof-object? n) (return #!eof 0 0 #f bytes info)]
                             [(fx= n 0) (return 0 0 0 cr? bytes info)]
                             [else (loop j 0 n cr? bytes)]))
                        ; don't try to read in this case to avoid dealing with eof
                         (return (fx- j start) i iend cr? bytes info))]
                    [(fx= i (fx- iend 1))
                     (bytevector-u8-set! bv 0 (bytevector-u8-ref bv i))
                     (let ([n (get-some-maybe-nb who bp bv 1 ifready?)])
                       (cond
                         [(eof-object? n) (decode-eof-error j 0 1 bytes)]
                         [(fx= n 0) (return (fx- j start) 0 1 cr? bytes info)]
                         [else (loop j 0 (fx+ n 1) cr? bytes)]))]
                    [else
                     (let ([b1 (bytevector-u8-ref bv i)]
                           [b2 (bytevector-u8-ref bv (fx+ i 1))])
                       (let ([w1 (if (codec-info-big info)
                                     (fxlogor (fxsll b1 8) b2)
                                     (fxlogor (fxsll b2 8) b1))])
                         (cond
                           [(and (fx= w1 #xfeff) (fx= i 0) (codec-info-bom info))
                            (when (and (port-has-port-position? bp)
                                       (guard (c [#t #f])
                                         (let ([n (port-position bp)])
                                           (eq? (- n iend) 0))))
                               (codec-info-zbom-set! info #t))
                            (loop j (fx+ i 2) iend cr? (fx+ bytes 2))]
                           [(and (fx= w1 #xfffe) (fx= i 0) (codec-info-bom info))
                            (when (and (port-has-port-position? bp)
                                       (guard (c [#t #f])
                                         (let ([n (port-position bp)])
                                           (eq? (- n iend) 0))))
                               (codec-info-zbom-set! info #t))
                            (codec-info-big-set! info (not (codec-info-big info)))
                            (loop j (fx+ i 2) iend cr? (fx+ bytes 2))]
                           [(fx<= #xD800 w1 #xDBFF) ; two-word encoding
                            (cond
                              [(fx<= i (fx- iend 4))
                               (let ([b3 (bytevector-u8-ref bv (fx+ i 2))]
                                     [b4 (bytevector-u8-ref bv (fx+ i 3))])
                                 (let ([w2 (if (codec-info-big info)
                                               (fxlogor (fxsll b3 8) b4)
                                               (fxlogor (fxsll b4 8) b3))])
                                   (cond
                                     [(fx<= #xDC00 w2 #xDFFF) ; valid encoding
                                      (string-set! str j
                                        (integer->char
                                          (fx+ (fxlogor (fxsll (fx- w1 #xD800) 10) (fx- w2 #xDC00))
                                               #x10000)))
                                      (loop (fx+ j 1) (fx+ i 4) iend #f (fx+ bytes 4))]
                                     [else
                                      (let ([i (fx+ i 4)])
                                        (let ([j (decode-error j i iend bytes b1 b2 b3 b4)])
                                          (loop j i iend #f (fx+ bytes 4))))])))]
                              [(fx= i (fx- iend 2))
                               (bytevector-u8-set! bv 0 b1)
                               (bytevector-u8-set! bv 1 b2)
                               (let ([n (get-some-maybe-nb who bp bv 2 ifready?)])
                                 (cond
                                   [(eof-object? n) (decode-eof-error j 0 2 bytes)]
                                   [(fx= n 0) (return (fx- j start) 0 2 cr? bytes info)]
                                   [else (loop j 0 (fx+ n 2) cr? bytes)]))]
                              [else ; must have three bytes of the four we need
                               (bytevector-u8-set! bv 0 b1)
                               (bytevector-u8-set! bv 1 b2)
                               (bytevector-u8-set! bv 2 (bytevector-u8-ref bv (fx+ i 2)))
                               (let ([n (get-some-maybe-nb who bp bv 3 ifready?)])
                                 (cond
                                   [(eof-object? n) (decode-eof-error j 0 3 bytes)]
                                   [(fx= n 0) (return (fx- j start) 0 3 cr? bytes info)]
                                   [else (loop j 0 (fx+ n 3) cr? bytes)]))])]
                           [(fx<= #xDC00 w1 #xDFFF) ; bogus encoding
                            (let ([i (fx+ i 2)])
                              (let ([j (decode-error j i iend bytes b1 b2)])
                                (loop j i iend #f (fx+ bytes 2))))]
                           [(fx= w1 #x0d)
                            (cond
                              [(eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
                               (string-set! str j #\return)
                               (when ioffsets (fxvector-set! ioffsets j bytes))
                               (loop (fx+ j 1) (fx+ i 2) iend cr? (fx+ bytes 2))]
                              [else
                               (string-set! str j #\newline)
                               (when ioffsets (fxvector-set! ioffsets j bytes))
                               (loop (fx+ j 1) (fx+ i 2) iend #t (fx+ bytes 2))])]
                           [(fx= w1 #x0a) ; LF
                            (cond
                              [cr? (loop j (fx+ i 2) iend #f (fx+ bytes 2))]
                              [else
                               (string-set! str j #\newline)
                               (when ioffsets (fxvector-set! ioffsets j bytes))
                               (loop (fx+ j 1) (fx+ i 2) iend cr? (fx+ bytes 2))])]
                           [(fx= w1 #x85) ; NEL
                            (cond
                              [cr? (loop j (fx+ i 2) iend #f (fx+ bytes 2))]
                              [else
                               (string-set! str j
                                 (if (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
                                     (integer->char w1)
                                     #\newline))
                               (when ioffsets (fxvector-set! ioffsets j bytes))
                               (loop (fx+ j 1) (fx+ i 2) iend cr? (fx+ bytes 2))])]
                           [(fx= w1 #x2028) ; LS
                            (string-set! str j
                              (if (eq? ($transcoder-eol-style (codec-info-tx info)) 'none)
                                  (integer->char w1)
                                  #\newline))
                            (when ioffsets (fxvector-set! ioffsets j bytes))
                            (loop (fx+ j 1) (fx+ i 2) iend #f (fx+ bytes 2))]
                           [else
                            (string-set! str j (integer->char w1))
                            (when ioffsets (fxvector-set! ioffsets j bytes))
                            (loop (fx+ j 1) (fx+ i 2) iend #f (fx+ bytes 2))])))])))))))

      (define utf-16-encode
        (let ()
          (define (return ans o info)
            (codec-info-next-set! info o)
            ans)
          (lambda (who tp str start count)
            (let ([info ($port-info tp)])
              (let ([bp (codec-info-bp info)]
                    [bv (codec-info-bv info)]
                    [jend (fx+ start count)])
                (when (codec-info-bom info)
                  (codec-info-bom-set! info #f)
                  (when (and (port-has-port-position? bp)
                             (guard (c [#t #f])
                               (eq? (port-position bp) 0)))
                     (codec-info-zbom-set! info #t))
                  (call-port-handler put-some who bp
                    (if (codec-info-big info) #vu8(#xfe #xff) #vu8(#xff #xfe))
                    0 2))
                (let loop ([j start] [o (codec-info-next info)])
                  (cond
                    [(fx= j jend) (return count o info)]
                    [(fx>= o (fx- codec-buffer-length 1))
                     (let ([new-o (flush-buffer who bp bv 0 o)])
                       (if (fx= new-o o)
                           (return (fx- j start) o info)
                           (loop j new-o)))]
                    [else
                     (let ([x (char->integer (string-ref str j))])
                       (cond
                         [(fx= x #x0a)
                          (let ([eol-style ($transcoder-eol-style (codec-info-tx info))])
                            (case eol-style
                              [(lf none)
                               (cond
                                 [(codec-info-big info)
                                  (bytevector-u8-set! bv o #x0)
                                  (bytevector-u8-set! bv (fx+ o 1) #x0a)]
                                 [else
                                  (bytevector-u8-set! bv (fx+ o 1) #x0)
                                  (bytevector-u8-set! bv o #x0a)])
                               (loop (fx+ j 1) (fx+ o 2))]
                              [(cr)
                               (cond
                                 [(codec-info-big info)
                                  (bytevector-u8-set! bv o #x0)
                                  (bytevector-u8-set! bv (fx+ o 1) #x0d)]
                                 [else
                                  (bytevector-u8-set! bv (fx+ o 1) #x0)
                                  (bytevector-u8-set! bv o #x0d)])
                               (loop (fx+ j 1) (fx+ o 2))]
                              [(nel)
                               (cond
                                 [(codec-info-big info)
                                  (bytevector-u8-set! bv o #x0)
                                  (bytevector-u8-set! bv (fx+ o 1) #x85)]
                                 [else
                                  (bytevector-u8-set! bv (fx+ o 1) #x0)
                                  (bytevector-u8-set! bv o #x85)])
                               (loop (fx+ j 1) (fx+ o 2))]
                              [(ls)
                               (cond
                                 [(codec-info-big info)
                                  (bytevector-u8-set! bv o #x20)
                                  (bytevector-u8-set! bv (fx+ o 1) #x28)]
                                 [else
                                  (bytevector-u8-set! bv (fx+ o 1) #x20)
                                  (bytevector-u8-set! bv o #x28)])
                               (loop (fx+ j 1) (fx+ o 2))]
                              [(crlf crnel)
                               (if (fx< o (fx- codec-buffer-length 3))
                                   (begin
                                     (cond
                                       [(codec-info-big info)
                                        (bytevector-u8-set! bv o #x0)
                                        (bytevector-u8-set! bv (fx+ o 1) #x0d)
                                        (bytevector-u8-set! bv (fx+ o 2) #x0)
                                        (bytevector-u8-set! bv (fx+ o 3)
                                          (case eol-style [(crlf) #x0a] [(crnel) #x85]))]
                                       [else
                                        (bytevector-u8-set! bv (fx+ o 1) #x0)
                                        (bytevector-u8-set! bv o #x0d)
                                        (bytevector-u8-set! bv (fx+ o 3) #x0)
                                        (bytevector-u8-set! bv (fx+ o 2)
                                          (case eol-style [(crlf) #x0a] [(crnel) #x85]))])
                                     (loop (fx+ j 1) (fx+ o 4)))
                                   (let ([new-o (flush-buffer who bp bv 0 o)])
                                     (if (fx= new-o o)
                                         (return (fx- j start) o info)
                                         (loop j new-o))))]
                              [else ($oops who "unrecognized eol style ~s" eol-style)]))]
                         [(fx<= x #xffff) ; two-byte encoding
                          (cond
                            [(codec-info-big info)
                             (bytevector-u8-set! bv o (fxsrl x 8))
                             (bytevector-u8-set! bv (fx+ o 1) (fxand x #xff))]
                            [else
                             (bytevector-u8-set! bv (fx+ o 1) (fxsrl x 8))
                             (bytevector-u8-set! bv o (fxand x #xff))])
                          (loop (fx+ j 1) (fx+ o 2))]
                         [else ; four-byte encoding
                          (if (fx< o (fx- codec-buffer-length 3))
                              (let ([x (fx- x #x10000)])
                                (let ([w1 (fxior #xd800 (fxsrl x 10))]
                                      [w2 (fxior #xdc00 (fxand x #x3ff))])
                                  (cond
                                    [(codec-info-big info)
                                     (bytevector-u8-set! bv o (fxsrl w1 8))
                                     (bytevector-u8-set! bv (fx+ o 1) (fxand w1 #xff))
                                     (bytevector-u8-set! bv (fx+ o 2) (fxsrl w2 8))
                                     (bytevector-u8-set! bv (fx+ o 3) (fxand w2 #xff))]
                                    [else
                                     (bytevector-u8-set! bv (fx+ o 1) (fxsrl w1 8))
                                     (bytevector-u8-set! bv o (fxand w1 #xff))
                                     (bytevector-u8-set! bv (fx+ o 3) (fxsrl w2 8))
                                     (bytevector-u8-set! bv (fx+ o 2) (fxand w2 #xff))])
                                  (loop (fx+ j 1) (fx+ o 4))))
                              (let ([new-o (flush-buffer who bp bv 0 o)])
                                (if (fx= new-o o)
                                    (return (fx- j start) o info)
                                    (loop j new-o))))]))])))))))

      (define make-utf-16-codec
        (lambda (bom big)
          (make-codec
            [name "utf-16"]
            [make-info
             (lambda (who tx bp bv)
               (make-codec-info tx bp bv 0 0
                 (and (input-port? bp) (make-fxvector (bytevector-length bv)))
                 0 #f bom #f big
                 utf-16-decode utf-16-encode (lambda (info) #f)))])))

      (let ([codec-bom-be (make-utf-16-codec #t #t)]
            [codec-bom-le (make-utf-16-codec #t #f)])
        (set-who! #(r6rs: utf-16-codec)
          (lambda () codec-bom-be))
        (set-who! utf-16-codec
          (case-lambda
            [() codec-bom-be]
            [(eness)
             (unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
             (if (eq? eness 'big) codec-bom-be codec-bom-le)])))

      (set-who! utf-16le-codec
        (let ([codec (make-utf-16-codec #f #f)])
          (lambda () codec)))

      (set-who! utf-16be-codec
        (let ([codec (make-utf-16-codec #f #t)])
          (lambda () codec))))

    (when-feature iconv
      (let ()
        (define-record-type iconv-info
          (parent codec-info)
          (nongenerative)
          (opaque #t)
          (fields decode-desc encode-desc))

        (define $iconv-open (foreign-procedure "(cs)s_iconv_open" (string string) ptr))
        (define $iconv-close (foreign-procedure "(cs)s_iconv_close" (uptr) void))
        (define $iconv-from-string (foreign-procedure "(cs)s_iconv_from_string" (uptr ptr uptr uptr ptr uptr uptr) ptr))
        (define $iconv-to-string (foreign-procedure "(cs)s_iconv_to_string" (uptr ptr uptr uptr ptr uptr uptr) ptr))

        (define iconv-decode
          (let ()
            (define (err who tp info i iend bv)
              (codec-info-next-set! info i)
              (codec-info-iend-set! info iend)
              (codec-info-icr-set! info #f)
              (let ([ls (let f ([k 4] [i i])
                          (if (fx= k 0)
                              (list "etc")
                              (if (fx= i iend)
                                  (list "#!eof")
                                  (cons (format "#x~2,'0x" (bytevector-u8-ref bv i))
                                        (f (fx- k 1) (fx+ i 1))))))])
                (decode-oops who tp "decoding failed for byte sequence ~a~{, ~a~}" (car ls) (cdr ls))))
            (define (return-count str start count i iend info)
              (let ([eol-style ($transcoder-eol-style (codec-info-tx info))])
                (if (eq? eol-style 'none)
                    (return count i iend info)
                    (let ([end (fx+ start count)])
                      (let loop ([jold start] [jnew start] [cr? (codec-info-icr info)])
                        (if (fx= jold end)
                            (return/cr (fx- jnew start) i iend cr? info)
                            (let ([c (string-ref str jold)])
                              (case c
                                [(#\nel #\newline)
                                 (if cr?
                                     (loop (fx+ jold 1) jnew #f)
                                     (begin
                                       (string-set! str jnew #\newline)
                                       (loop (fx+ jold 1) (fx+ jnew 1) #f)))]
                                [(#\return)
                                 (string-set! str jnew #\newline)
                                 (loop (fx+ jold 1) (fx+ jnew 1) #t)]
                                [(#\ls)
                                 (string-set! str jnew #\newline)
                                 (loop (fx+ jold 1) (fx+ jnew 1) #f)]
                                [else
                                 (string-set! str jnew c)
                                 (loop (fx+ jold 1) (fx+ jnew 1) #f)]))))))))
            (define (return/cr ans i iend cr? info)
              (codec-info-icr-set! info cr?)
              (return ans i iend info))
            (define (return ans i iend info)
              (codec-info-next-set! info i)
              (codec-info-iend-set! info iend)
              ans)
            (lambda (who tp str start count ifready?)
              (let ([info ($port-info tp)])
                (let ([bp (codec-info-bp info)]
                      [bv (codec-info-bv info)]
                      [jend (fx+ start count)])
                  (let loop ([j start]
                             [i (codec-info-next info)]
                             [iend (codec-info-iend info)])
                    (cond
                      [(fx= j jend) (return-count str start count i iend info)]
                      [(fx= i iend)
                       (if (fx= j start)
                           (let ([n (get-some-maybe-nb who bp bv 0 ifready?)])
                             (cond
                               [(eof-object? n) (return/cr #!eof i iend #f info)]
                               [(fx= n 0) (return 0 i iend info)]
                               [else (loop j 0 n)]))
                          ; don't try to read in this case to avoid dealing with eof
                           (return-count str start (fx- j start) i iend info))]
                      [else
                       (let ([newi.newj ($iconv-to-string (iconv-info-decode-desc info) bv i iend str j jend)])
                         (cond
                           [(pair? newi.newj) (loop (cdr newi.newj) (car newi.newj) iend)]
                          ; one of the following presumably happened:
                          ;  - too few input bytes to make progress
                          ;  - invalid input sequence found
                          ; assuming problem can't have been too little output space since
                          ; j != jend implies enough room for at least one character
                           [(or (eq? newi.newj (constant SICONV-INVALID))
                               ; assuming bv is large enough to hold any valid encoding sequence
                                (and (eq? newi.newj (constant SICONV-DUNNO))
                                     (and (fx= i 0) (fx= iend (bytevector-length bv)))))
                            (case ($transcoder-error-handling-mode (codec-info-tx info))
                              [(ignore) (loop j (fx+ i 1) iend)]
                              [(replace)
                               (string-set! str j #\xfffd)
                               (loop (fx+ j 1) (fx+ i 1) iend)]
                              [else (err who tp info i iend bv)])]
                           [else
                            ; try again with more bytes
                            (unless (fx= i 0) (bytevector-copy! bv i bv 0 (fx- iend i)))
                            (let ([i 0] [iend (fx- iend i)])
                              (let ([n (get-some-maybe-nb who bp bv iend ifready?)])
                                (cond
                                  [(eof-object? n)
                                   (set-port-eof! bp #t)
                                   (case ($transcoder-error-handling-mode (codec-info-tx info))
                                     [(ignore) (loop j (fx+ i 1) iend)]
                                     [(replace)
                                      (string-set! str j #\xfffd)
                                      (loop (fx+ j 1) (fx+ i 1) iend)]
                                     [else (err who tp info i iend bv)])]
                                  [(fx= n 0) (return 0 i iend info)]
                                  [else (loop j 0 (fx+ iend n))])))]))])))))))

        (define iconv-encode
          (let ()
            (define (return ans o info)
              (codec-info-next-set! info o)
              ans)
            (define (do-iconv who info str j jend bv o)
              (let ([eol-style ($transcoder-eol-style (codec-info-tx info))]
                    [desc (iconv-info-encode-desc info)])
                (cond
                  [(memq eol-style '(none lf))
                   ($iconv-from-string desc str j jend bv o codec-buffer-length)]
                  [(eqv? (string-ref str j) #\newline)
                   (let ()
                     (define (iconv-newline s k)
                       (let ([newj.newo ($iconv-from-string desc s 0 k bv o codec-buffer-length)])
                         (if (pair? newj.newo)
                             (if (fx= (car newj.newo) k)
                                 (cons (fx+ j 1) (cdr newj.newo))
                                 (constant SICONV-NOROOM))
                             newj.newo)))
                     (case eol-style
                       [(cr) (iconv-newline "\r" 1)]
                       [(nel) (iconv-newline "\x85;" 1)]
                       [(ls) (iconv-newline "\x2028;" 1)]
                       [(crlf) (iconv-newline "\r\n" 2)]
                       [(crnel) (iconv-newline "\r\x85;" 2)]
                       [else ($oops who "unrecognized eol style ~s" eol-style)]))]
                  [else
                   (do ([k (fx+ j 1) (fx+ k 1)])
                       ((or (fx= k jend) (eqv? (string-ref str k) #\newline))
                        ($iconv-from-string desc str j k bv o codec-buffer-length)))])))
            (lambda (who tp str start count)
              (let ([info ($port-info tp)])
                (let ([bp (codec-info-bp info)]
                      [bv (codec-info-bv info)]
                      [jend (fx+ start count)])
                  (let loop ([j start] [o (codec-info-next info)])
                    (cond
                      [(fx= j jend) (return count o info)]
                      [(fx= o codec-buffer-length)
                       (let ([o (flush-buffer who bp bv 0 o)])
                         (if (fx= o codec-buffer-length)
                             (return (fx- j start) o info)
                             (loop j o)))]
                      [else
                       (let ([newj.newo (do-iconv who info str j jend bv o)])
                         (cond
                           [(pair? newj.newo) (loop (car newj.newo) (cdr newj.newo))]
                          ; one of the following presumably happened:
                          ;  - unencodeable character found
                          ;  - too little output space to make progress
                           [(fx= o 0) ; assuming bv is large enough to hold any valid encoding sequence
                            (case ($transcoder-error-handling-mode (codec-info-tx info))
                              [(ignore) (loop (fx+ j 1) o)]
                              [(replace)
                              ; try to write the Unicode replacement character
                               (let ([newj.newo ($iconv-from-string (iconv-info-encode-desc info) "\xfffd;" 0 1 bv o codec-buffer-length)])
                                 (if (pair? newj.newo)
                                     (loop (fx+ j 1) (cdr newj.newo))
                                    ; if that failed, try to write ?
                                     (let ([newj.newo ($iconv-from-string (iconv-info-encode-desc info) "?" 0 1 bv o codec-buffer-length)])
                                       (if (pair? newj.newo)
                                           (loop (fx+ j 1) (cdr newj.newo))
                                          ; if even that failed, just ignore
                                           (loop (fx+ j 1) o)))))]
                              [else (encode-oops who tp (string-ref str j))])]
                           [else (let ([newo (flush-buffer who bp bv 0 o)])
                                   (if (fx= newo o)
                                       (return (fx- j start) o info)
                                       (loop j newo)))]))])))))))

        (define iconv-close
          (lambda (info)
            (cond [(iconv-info-decode-desc info) => $iconv-close])
            (cond [(iconv-info-encode-desc info) => $iconv-close])))

        (set-who! iconv-codec
          (lambda (code)
            (unless (string? code) ($oops who "~s is not a string" code))
            (make-codec
              [name (format "iconv ~a" code)]
              [make-info
               (lambda (who tx bp bv)
                 (define UTF-32B/LE
                   (constant-case native-endianness
                     [(little) "UTF-32LE"]
                     [(big) "UTF-32BE"]))
                 (define (iconv-open to from)
                   (let ([desc ($iconv-open to from)])
                     (when (string? desc) ($oops who "~a" desc))
                     (unless desc ($oops who "unsupported encoding ~a" code))
                     desc))
                 (let ([decode-desc (and (input-port? bp) (iconv-open UTF-32B/LE code))]
                       [encode-desc (and (output-port? bp) (iconv-open code UTF-32B/LE))])
                   (make-iconv-info tx bp bv 0 0 #f 0 #f #f #f #f
                     (if decode-desc
                         iconv-decode
                         (lambda args ($oops who "unexpected decode from non-input-port ~s" bp)))
                     (if encode-desc
                         iconv-encode
                         (lambda args ($oops who "unexpected encode to non-output-port ~s" bp)))
                     iconv-close decode-desc encode-desc)))]))))))

  ;; eol-style in syntax.ss
  (set-who! $eol-style?
    (lambda (style) (and (memq style (eol-style-list)) #t)))

  (set-who! native-eol-style
    (lambda ()
      (eol-style none)))

  ;; &i/o-decoding in exceptions.ss
  ;; make-i/o-decoding-error in exceptions.ss
  ;; i/o-decoding-error? in exceptions.ss
  ;; &i/o-encoding in exceptions.ss
  ;; make-i/o-encoding-error in exceptions.ss
  ;; i/o-encoding-error? in exceptions.ss
  ;; i/o-encoding-error-char in exceptions.ss

  ;; error-handling-mode in syntax.ss
  (set-who! $error-handling-mode?
    (lambda (mode) (and (memq mode (error-handling-mode-list)) #t)))

  (set-who! make-transcoder
    (rec make-transcoder
      (case-lambda
       [(codec) (make-transcoder codec (native-eol-style) (error-handling-mode replace))]
       [(codec eol-style) (make-transcoder codec eol-style (error-handling-mode replace))]
       [(codec eol-style handling-mode)
        (unless (codec? codec) ($oops who "~s is not a codec" codec))
        (unless ($eol-style? eol-style) ($oops who "~s is not an eol-style" eol-style))
        (unless ($error-handling-mode? handling-mode)
          ($oops who "~s is not an error-handling-mode" handling-mode))
        ($make-transcoder codec eol-style handling-mode)])))

  (set-who! transcoder? (lambda (x) ($transcoder? x)))

  (let ([transcoder (make-transcoder (utf-8-codec))])
    (set-who! native-transcoder (lambda () transcoder))
    (set-who! current-transcoder
      ($make-thread-parameter transcoder
        (lambda (tx)
          (unless ($transcoder? tx) ($oops who "~s is not a transcoder" tx))
          tx))))

  ;; transcoder-codec, transcoder-eol-style, transcoder-error-handling-mode
  (let ()
    (define-syntax define-accessor
      (syntax-rules ()
        [(_ name $name)
         (set-who! name
           (lambda (transcoder)
             (unless ($transcoder? transcoder)
               ($oops who "~s is not a transcoder" transcoder))
             ($name transcoder)))]))

    (define-accessor transcoder-codec $transcoder-codec)
    (define-accessor transcoder-eol-style $transcoder-eol-style)
    (define-accessor transcoder-error-handling-mode $transcoder-error-handling-mode))

;;;; 8.2.5 End-of-file object
  ;; eof-object in prims.ss
  ;; eof-object? in prims.ss

;;;; 8.2.6 Input and output ports
  ;; port? in prims.ss

  (set-who! port-transcoder
    (lambda (port)
      (unless (port? port)
        ($oops who "~s is not a port" port))
      (let ([info ($port-info port)])
        (and (codec-info? info)
             (codec-info-tx info)))))

  ;; textual-port? in prims.ss
  ;; binary-port? in prims.ss

  ;; transcoded-port
  (let ()
    (module (make-transcoded-port-handler)
      (define read-from-codec
        (lambda (who tp str start count ifready?)
          (when (eq? tp $console-input-port)
            (guard (c [else (void)]) (flush-output-port $console-output-port))
            (unless (eq? $console-error-port $console-output-port)
              (guard (c [else (void)]) (flush-output-port $console-error-port))))
          ((codec-info-decode ($port-info tp)) who tp str start count ifready?)))
      (define fill-from-codec
        (lambda (who tp ifready?)
          (let ([buf (textual-port-input-buffer tp)])
            (let ([n (read-from-codec who tp buf 0 (string-length buf) ifready?)])
              (if (eof-object? n)
                  (begin
                    (set-textual-port-input-size! tp 0)
                    (set-port-eof! tp #t))
                  (set-textual-port-input-size! tp n))
              n))))
      (define write-to-codec
        (lambda (who tp str start count)
          (let ([n ((codec-info-encode ($port-info tp)) who tp str start count)])
            (unless (fx= n 0)
              (set-port-bol! tp (eol-char? (string-ref str (fx- (fx+ start n) 1)))))
            n)))
      (define flush-to-codec
        (case-lambda
          [(who tp) (flush-to-codec who tp (textual-port-output-index tp))]
          [(who tp count)
           (unless (fx= count 0)
            ; push the chars from port's buffer into the codec's buffer
             (let loop ([start 0] [count count])
               (let ([n (write-to-codec who tp (textual-port-output-buffer tp) start count)])
                 (unless (fx= n count) (loop (fx+ start n) (fx- count n)))))
             (if ($port-flags-set? tp (constant port-flag-line-buffered))
                 (set-textual-port-output-size! tp 0)
                 (set-textual-port-output-index! tp 0)))]))
      (define try-flush-to-codec
        (lambda (who tp)
          (let ([count (textual-port-output-index tp)])
            (or (fx= count 0)
                (let ([buf (textual-port-output-buffer tp)])
                  (let loop ([start 0] [count count])
                    (let ([n (write-to-codec who tp buf start count)])
                      (cond
                        [(fx= n count)
                         (if ($port-flags-set? tp (constant port-flag-line-buffered))
                             (set-textual-port-output-size! tp 0)
                             (set-textual-port-output-index! tp 0))
                         #t]
                        [(fx= n 0)
                         (unless (fx= start 0)
                           (string-copy! buf start buf 0 count)
                           (when ($port-flags-set? tp (constant port-flag-line-buffered))
                             (set-textual-port-output-size! tp count))
                           (set-textual-port-output-index! tp count))
                         #f]
                        [else (loop (fx+ start n) (fx- count n))]))))))))
      (define flush-from-codec
        (lambda (who tp)
         ; push the bytes from codec's buffer into the binary port
          (let ([info ($port-info tp)])
            (let loop ([start 0] [count (codec-info-next info)])
              (unless (fx= count 0)
                (let ([n (let ([bp (codec-info-bp info)])
                           (call-port-handler put-some who bp (codec-info-bv info) start count))])
                  (loop (fx+ start n) (fx- count n)))))
            (codec-info-next-set! info 0))))
      (define flush-from-bp
        (lambda (who tp)
          (let ([bp (codec-info-bp ($port-info tp))])
            (call-port-handler flush who bp))))
      (module ((make-ready-for-input $make-ready-for-input))
        (define $make-ready-for-input
          (lambda (who tp)
            (flush-to-codec who tp)
            (flush-from-codec who tp)
            (set-textual-port-output-size! tp 0)
            (let ([info ($port-info tp)])
              (codec-info-next-set! info 0)
              (codec-info-iend-set! info 0)
              (codec-info-icr-set! info #f))
            ($set-port-flags! tp (constant port-flag-input-mode))))
        (define-syntax make-ready-for-input
          (syntax-rules ()
            [(_ who ?tp)
             (let ([tp ?tp])
               (unless ($port-flags-set? tp (constant port-flag-input-mode))
                 ($make-ready-for-input who tp)))])))
      (module ((make-ready-for-output $make-ready-for-output))
        (define $make-ready-for-output
          (lambda (who tp)
           ; rewind if textual port or codec has something buffered.
           ; if underlying binary port has something buffered, we'll let
           ; the first write to the binary port take care of it
            (unless (and (fx= (textual-port-input-size tp) 0)
                         (let ([info ($port-info tp)])
                           (fx= (codec-info-next info) (codec-info-iend info))))
              (if (port-handler-port-position ($port-handler tp))
                  (if (port-handler-set-port-position! ($port-handler tp))
                      (let ([bp (codec-info-bp ($port-info tp))])
                        (call-port-handler set-port-position! who bp
                          (call-port-handler port-position who tp)))
                      (position-warning who "cannot set position for write after read on ~s" tp))
                  (position-warning who "cannot determine position for write after read on ~s" tp)))
            (set-textual-port-input-size! tp 0)
            (set-port-eof! tp #f)
            (codec-info-next-set! ($port-info tp) 0)
            (unless ($port-flags-set? tp (constant port-flag-line-buffered))
              (set-textual-port-output-size! tp (fx1- (string-length (textual-port-output-buffer tp)))))
            ($reset-port-flags! tp (constant port-flag-input-mode))))
        (define-syntax make-ready-for-output
          (syntax-rules ()
            [(_ ?who ?tp)
             (let ([tp ?tp])
               (when ($port-flags-set? tp (constant port-flag-input-mode))
                 ($make-ready-for-output ?who tp)))])))
      (define contains-eol-char?
        (lambda (s i end)
          (let f ([i i])
            (and (not (fx= i end))
              (or (eol-char? (string-ref s i))
                  (f (fx+ i 1)))))))
      (define transcoded-port-ready?
        (lambda (who tp)
          (assert-not-closed who tp)
          (make-ready-for-input who tp)
          (or (not (port-input-empty? tp))
              (port-flag-eof-set? tp)
              (not (eq? (fill-from-codec who tp #t) 0)))))
      (define transcoded-port-lookahead
        (lambda (who tp)
          (assert-not-closed who tp)
          (make-ready-for-input who tp)
          (cond
            [(not (port-input-empty? tp))
             (string-ref (textual-port-input-buffer tp)
                         (textual-port-input-index tp))]
            [(port-flag-eof-set? tp) (eof-object)]
            [else (let loop ()
                    (let ([n (fill-from-codec who tp #f)])
                      (cond
                        [(eq? n 0) (loop)]
                        [(eof-object? n) n]
                        [else (string-ref (textual-port-input-buffer tp) 0)])))])))
      (define transcoded-port-unget
        (lambda (who tp x)
          (assert-not-closed who tp)
          (make-ready-for-input who tp)
          (when (port-flag-eof-set? tp) (unget-error who tp x))
          (if (eof-object? x)
              (let ()
                (unless (port-input-empty? tp) (unget-error who tp x))
                (set-port-eof! tp #t))
              (let ([index (textual-port-input-index tp)])
                (when (fx= index 0) (unget-error who tp x))
                (set-textual-port-input-index! tp (fx- index 1))))))
      (define transcoded-port-get
        (lambda (who tp)
          (assert-not-closed who tp)
          (make-ready-for-input who tp)
          (cond
            [(not (port-input-empty? tp))
             (let ([index (textual-port-input-index tp)])
               (set-textual-port-input-index! tp (fx1+ index))
               (string-ref (textual-port-input-buffer tp) index))]
            [(port-flag-eof-set? tp) (set-port-eof! tp #f) (eof-object)]
            [else (let loop ()
                    (let ([n (fill-from-codec who tp #f)])
                      (cond
                        [(eq? 0 n) (loop)]
                        [(eof-object? n) (set-port-eof! tp #f) (eof-object)]
                        [else
                         (set-textual-port-input-index! tp 1)
                         (string-ref (textual-port-input-buffer tp) 0)])))])))
      (define transcoded-port-get-some
        (lambda (who tp str start count)
          (assert-not-closed who tp)
          (make-ready-for-input who tp)
          (let ([port-count (textual-port-input-count tp)])
            (cond
              [(not (fx= port-count 0))
               (let ([count (fxmin count port-count)]
                     [index (textual-port-input-index tp)])
                 (string-copy! (textual-port-input-buffer tp) index str start count)
                 (set-textual-port-input-index! tp (fx+ index count))
                 count)]
              [(port-flag-eof-set? tp) (set-port-eof! tp #f) (eof-object)]
              [else (read-from-codec who tp str start count #f)]))))
      (define transcoded-port-clear-input
        (lambda (who tp)
          (assert-not-closed who tp)
          (when ($port-flags-set? tp (constant port-flag-input-mode))
           ; position will be wrong after this.  c'est la vie.
            (set-textual-port-input-size! tp 0)
            (set-port-eof! tp #f)
            (let ([info ($port-info tp)])
              (codec-info-next-set! info 0)
              (codec-info-iend-set! info 0)
              (codec-info-icr-set! info #f)
              (let ([bp (codec-info-bp info)])
                (call-port-handler clear-input who bp))))))
      (define transcoded-port-put
        (lambda (who tp elt)
          (assert-not-closed who tp)
          (make-ready-for-output who tp)
          (let ([index (textual-port-output-index tp)])
            (string-set! (textual-port-output-buffer tp) index elt)
            (let ([index (fx+ index 1)])
              (cond
                [(not (port-output-full? tp))
                 (set-textual-port-output-index! tp index)]
                [($port-flags-set? tp (constant port-flag-line-buffered))
                 (cond
                   [(eol-char? elt)
                    (flush-to-codec who tp index)
                    (flush-from-codec who tp)
                    (flush-from-bp who tp)]
                   [(fx< (textual-port-output-size tp) (fx- (string-length (textual-port-output-buffer tp)) 1))
                    (set-textual-port-output-size! tp index)
                    (set-textual-port-output-index! tp index)]
                   [else (flush-to-codec who tp index)])]
                [else (flush-to-codec who tp index)])))))
      (define transcoded-port-put-some
        (lambda (who tp str start count)
          (assert-not-closed who tp)
          (make-ready-for-output who tp)
          (cond
            [($port-flags-set? tp (constant port-flag-line-buffered))
             (if (contains-eol-char? str start (fx+ start count))
                 (begin
                  ; line-buffering trumps nonblocking
                   (flush-to-codec who tp)
                   (let loop ([start start] [count count])
                     (unless (fx= count 0)
                       (let ([n (write-to-codec who tp str start count)])
                         (loop (fx+ start n) (fx- count n)))))
                   (flush-from-codec who tp)
                   (flush-from-bp who tp)
                   count)
                 (let ([buf (textual-port-output-buffer tp)]
                       [index (textual-port-output-index tp)])
                   (if (and (fx<= count max-put-copy) (fx< (fx+ index count) (string-length buf)))
                      ; there's room to copy str with one character to spare
                       (begin
                         (string-copy! str start buf index count)
                         (let ([index (fx+ index count)])
                           (set-textual-port-output-size! tp index)
                           (set-textual-port-output-index! tp index))
                         count)
                       (if (try-flush-to-codec who tp) (write-to-codec who tp str start count) 0))))]
            [else (if (try-flush-to-codec who tp) (write-to-codec who tp str start count) 0)])))
      (define transcoded-port-flush
        (lambda (who tp)
          (assert-not-closed who tp)
          (make-ready-for-output who tp)
          (flush-to-codec who tp)
          (flush-from-codec who tp)
          (flush-from-bp who tp)))
      (define transcoded-port-clear-output
        (lambda (who tp)
          (assert-not-closed who tp)
          (unless ($port-flags-set? tp (constant port-flag-input-mode))
           ; position will be wrong after this.  c'est la vie.
            (if ($port-flags-set? tp (constant port-flag-line-buffered))
                (set-textual-port-output-size! tp 0)
                (set-textual-port-output-index! tp 0))
            (let ([info ($port-info tp)])
              (codec-info-next-set! info 0)
              (let ([bp (codec-info-bp info)])
                (call-port-handler clear-output who bp))))))
      (define transcoded-port-close-port
        (lambda (who tp)
          (unless (port-closed? tp)
            (when (output-port? tp)
              (make-ready-for-output who tp)
              (flush-to-codec who tp)
              (flush-from-codec who tp)
              (flush-from-bp who tp))
            (unless (or (eq? tp $console-input-port)  ; refuse to close original console ports
                        (eq? tp $console-output-port)
                        (eq? tp $console-error-port))
              (when (output-port? tp)
                (set-textual-port-output-size! tp 0))
              (when (input-port? tp)
                (set-textual-port-input-size! tp 0)
                (set-port-eof! tp #f))
              (let ([info ($port-info tp)])
                (close-port (codec-info-bp info))
                ((codec-info-close info) info))
              (unregister-open-file tp)
              (mark-port-closed! tp)))))
      (define transcoded-port-port-position
        (lambda (who tp)
          (assert-not-closed who tp)
          (cond
            [($port-flags-set? tp (constant port-flag-input-mode))
            ; (port-position bp) gives us position in bytes after characters and bytes
            ; we haven't yet consumed.  to get position of first unconsumed character or
            ; byte, need to adjust downward by the number of bytes buffered, using
            ; ioffsets to determine the byte position of the first unconsumed character
            ; relative to the start of the port's buffer, ibytes to determine the total
            ; number of bytes represented by the characters in the port's buffer, and
            ; (- iend next) to determine the number of bytes not yet converted
            ; into characters.  if ioffsets is not available, the reported port-position
            ; may not be accurate.
             (let ([info ($port-info tp)])
               (- (call-port-handler port-position who (codec-info-bp info))
                  (let ([buffered-bytes (fx- (codec-info-iend info) (codec-info-next info))])
                    (cond
                      [(port-input-empty? tp) buffered-bytes]
                      [(codec-info-ioffsets info) =>
                       (lambda (ioffsets)
                         (fx- (fx+ (codec-info-ibytes info) buffered-bytes)
                              (fxvector-ref ioffsets (textual-port-input-index tp))))]
                      [else
                       (position-warning who "cannot determine accurate position for operation on ~s" tp)
                       buffered-bytes]))))]
            [else
             (flush-to-codec who tp)
             (flush-from-codec who tp)
             (let ([bp (codec-info-bp ($port-info tp))])
               (call-port-handler port-position who bp))])))
      (define transcoded-port-set-port-position!
        (lambda (who tp pos)
          (assert-not-closed who tp)
          (let ([info ($port-info tp)])
            (if ($port-flags-set? tp (constant port-flag-input-mode))
                (begin
                  (set-textual-port-input-size! tp 0)
                  (set-port-eof! tp #f)
                  (codec-info-next-set! info 0)
                  (codec-info-iend-set! info 0)
                  (codec-info-icr-set! info #f))
                (begin
                  (flush-to-codec who tp)
                  (flush-from-codec who tp)))
            (let ([bp (codec-info-bp info)])
              (call-port-handler set-port-position! who bp
               ; position past bom if known to be present at position 0
               ; if it was found or put elsewhere, all bets are off
                (if (and (eq? pos 0) (codec-info-zbom info)) 2 pos))))))
      (define transcoded-port-port-length
        (lambda (who tp)
          (assert-not-closed who tp)
          (unless ($port-flags-set? tp (constant port-flag-input-mode))
            (flush-to-codec who tp)
            (flush-from-codec who tp))
          (let ([bp (codec-info-bp ($port-info tp))])
            (call-port-handler port-length who bp))))
      (define transcoded-port-set-port-length!
        (lambda (who tp pos)
          (assert-not-closed who tp)
          (unless ($port-flags-set? tp (constant port-flag-input-mode))
            (flush-to-codec who tp)
            (flush-from-codec who tp))
          (let ([bp (codec-info-bp ($port-info tp))])
            (call-port-handler set-port-length! who bp pos))))
      (define transcoded-port-port-nonblocking?
        (lambda (who tp)
          (assert-not-closed who tp)
          (port-nonblocking? (codec-info-bp ($port-info tp)))))
      (define transcoded-port-set-port-nonblocking!
        (lambda (who tp b)
          (assert-not-closed who tp)
          (set-port-nonblocking! (codec-info-bp ($port-info tp)) b)))
      (define (make-transcoded-port-handler bp)
       ; could cache these, but the savings would be minimal
        (make-port-handler
          [ready? (and (input-port? bp) transcoded-port-ready?)]
          [lookahead (and (input-port? bp) transcoded-port-lookahead)]
          [unget (and (input-port? bp) transcoded-port-unget)]
          [get (and (input-port? bp) transcoded-port-get)]
          [get-some (and (input-port? bp) transcoded-port-get-some)]
          [clear-input (and (input-port? bp) transcoded-port-clear-input)]
          [put (and (output-port? bp) transcoded-port-put)]
          [put-some (and (output-port? bp) transcoded-port-put-some)]
          [flush (and (output-port? bp) transcoded-port-flush)]
          [clear-output (and (output-port? bp) transcoded-port-clear-output)]
          [close-port transcoded-port-close-port]
          [port-position
           (and (port-handler-port-position ($port-handler bp))
                transcoded-port-port-position)]
          [set-port-position!
           (and (port-handler-set-port-position! ($port-handler bp))
                transcoded-port-set-port-position!)]
          [port-length
           (and (port-handler-port-length ($port-handler bp))
                transcoded-port-port-length)]
          [set-port-length!
           (and (port-handler-set-port-length! ($port-handler bp))
                transcoded-port-set-port-length!)]
          [port-nonblocking?
           (and (port-handler-port-nonblocking? ($port-handler bp))
                transcoded-port-port-nonblocking?)]
          [set-port-nonblocking!
           (and (port-handler-set-port-nonblocking! ($port-handler bp))
                transcoded-port-set-port-nonblocking!)])))
    (set-who! transcoded-port
      (lambda (bp tx)
        (define-syntax copy-flag!
          (syntax-rules ()
            [(_ from to flag)
             (when ($port-flags-set? from (constant flag))
               ($set-port-flags! to (constant flag)))]))
        (define (clone-port bp)
          (let ([bpc ($make-textual-input/output-port "" ($port-handler bp) "" "" #f)])
            ($byte-copy! bp (constant port-type-disp) bpc (constant port-type-disp) (constant size-port))
            bpc))
        (unless (and (port? bp) (binary-port? bp)) ($oops who "~s is not a binary port" bp))
        (unless ($transcoder? tx) ($oops who "~s is not a transcoder" tx))
        (let* ([bpc (clone-port bp)]
               [name (port-name bpc)]
               [buffer-length (if (or ($port-flags-set? bp (constant port-flag-block-buffered))
                                      ($port-flags-set? bp (constant port-flag-line-buffered)))
                                  buffered-transcoded-port-buffer-length
                                  unbuffered-transcoded-port-buffer-length)]
               [codec ($transcoder-codec tx)]
               [info ((codec-make-info codec) who tx bpc (make-bytevector codec-buffer-length))]
               [handler (make-transcoded-port-handler bpc)]
               [tp (if (input-port? bpc)
                       (if (output-port? bpc)
                           ($make-textual-input/output-port name handler
                             (make-string buffer-length)
                             (make-string buffer-length)
                             info)
                           ($make-textual-input-port name handler
                             (make-string buffer-length) info))
                       ($make-textual-output-port name handler
                         (make-string buffer-length) info))])
          (copy-flag! bpc tp port-flag-block-buffered)
          (copy-flag! bpc tp port-flag-line-buffered)
          (mark-port-closed! bp)
          (when (input-port? bp)
            (set-binary-port-input-size! bp 0)
            (set-port-eof! bp #f)
            (set-textual-port-input-size! tp 0))
          (when (output-port? bp)
            (set-binary-port-output-size! bp 0)
            (set-textual-port-output-size! tp
              (if ($port-flags-set? tp (constant port-flag-line-buffered))
                  0
                  (fx1- buffer-length)))
            ($set-port-flags! tp (constant port-flag-bol)))
          ($set-port-info! bp tp) ; back-link for bytevector-output-port extractor
          (when (registered-open-file? bp)
            (unregister-open-file bp)
            (register-open-file tp))
          tp))))

  (let ()
    (define-syntax set-who!-port-has
      (lambda (x)
        (syntax-case x ()
          [(_ name)
           (with-syntax ([name (construct-name #'name "port-has-" #'name "?")]
                         [field (construct-name #'name "port-handler-" #'name)])
             #'(set-who! name
                 (lambda (p)
                   (unless (port? p) ($oops who "~s is not a port" p))
                   (and (field ($port-handler p)) #t))))])))

    (define-syntax set-who!-port
      (lambda (x)
        (syntax-case x ()
          [(_ name (args ...))
           (with-syntax ([field (construct-name #'name "port-handler-" #'name)])
             #'(set-who! name
                 (lambda (p args ...)
                   (unless (port? p) ($oops who "~s is not a port" p))
                   (let ([op (field ($port-handler p))])
                     (unless op ($oops who "~s does not support operation" p))
                     (op who p args ...)))))])))

    (set-who!-port-has port-position)
    (set-who!-port     port-position ())
    (set-who!-port-has set-port-position!)
    (set-who!-port     set-port-position! (x))

    ;; The following are not in R6RS
    (set-who!-port-has port-nonblocking?)
    (set-who!-port     port-nonblocking? ())
    (set-who!-port-has set-port-nonblocking!)
    (set-who!-port     set-port-nonblocking! (x))
    (set-who!-port-has port-length)
    (set-who!-port     port-length ())
    (set-who!-port-has set-port-length!)
    (set-who!-port     set-port-length! (x)))

  (set-who! file-position
    (case-lambda
      [(p)
       (unless (port? p) ($oops who "~s is not a port" p))
       (let ([op (port-handler-port-position ($port-handler p))])
         (unless op ($oops who "~s does not support operation" p))
         (op who p))]
      [(p pos)
       (unless (port? p) ($oops who "~s is not a port" p))
       (let ([op (port-handler-set-port-position! ($port-handler p))])
         (unless op ($oops who "~s does not support operation" p))
         (op who p pos))]))

  (set-who! file-length
    (lambda (p)
      (unless (port? p) ($oops who "~s is not a port" p))
      (let ([op (port-handler-port-length ($port-handler p))])
        (unless op ($oops who "~s does not support operation" p))
        (op who p))))

  ;; Not in R6RS
  ;; truncate-file is set-port-length and set-port-position combined
  (let ()
    (define (tp who port pos)
      (unless (output-port? port) ($oops who "~s is not an output port" port))
      (let ([handler ($port-handler port)])
        (let ([set-len! (port-handler-set-port-length! handler)]
              [set-pos! (port-handler-set-port-position! handler)])
          (unless (and set-len! set-pos!)
            ($oops who "~s does not support operation" port))
          (set-len! who port pos)
          (set-pos! who port pos))))

    (set-who! truncate-port
      (case-lambda
        [(port) (tp who port 0)]
        [(port pos) (tp who port pos)]))

    (set-who! truncate-file
      (case-lambda
        [(port) (tp who port 0)]
        [(port pos) (tp who port pos)])))

  (set-who! close-port
    (lambda (port)
      (unless (port? port) ($oops who "~s is not a port" port))
      (call-port-handler close-port who port)))

  (set-who! call-with-port
    (lambda (port proc)
      (unless (port? port) ($oops who "~s is not a port" port))
      (unless (procedure? proc) ($oops who "~s is not a procedure" proc))
      (call-with-values
        (lambda () (proc port))
        (case-lambda
          [(x)
           (call-port-handler close-port who port)
           x]
          [args
           (call-port-handler close-port who port)
           (apply values args)]))))

;;;; 8.2.7 Input ports
  ;; input-port? in prims.ss
  ;; port-eof? in prims.ss

  ;; Not in R6RS
  (set-who! input-port-ready?
    (lambda (input-port)
      (unless (input-port? input-port)
        ($oops who "~s is not an input port" input-port))
      (or (not (port-input-empty? input-port))
          (port-flag-eof-set? input-port)
          (call-port-handler ready? who input-port))))

  (let ()
  ;; open-file-input-port
    (define open-binary-file-input-port
      (lambda (who filename options mode)
        (unless (string? filename)
          ($oops who "~s is not a string" filename))
        (unless (and (enum-set? options)
                     (enum-set-subset? options $file-options))
          ($oops who "~s is not a file-options object" options))
        (unless (buffer-mode? mode)
          ($oops who "~s is not a valid buffer mode" mode))
        (when (enum-set-subset? (file-options exclusive) options)
          ($oops who "exclusive option not supported for file input ports"))
        (let ([fd (critical-section ($open-input-fd filename (enum-set-subset? (file-options compressed) options)))])
          (when (pair? fd) (open-oops who filename options fd))
          (if (box? fd) ; box iff file opened with compressed option is actually gzip'd
              (open-binary-fd-input-port who filename (unbox fd) #t mode #t)
              (open-binary-fd-input-port who filename fd #t mode #f)))))

    (define open-binary-standard-input-port
      (lambda (b-mode)
        (define who 'standard-input-port)
        (unless (buffer-mode? b-mode)
          ($oops who "~s is not a valid buffer mode" b-mode))
        (open-binary-fd-input-port who "stdin" (make-fd 0) ($fd-regular? 0) b-mode #f)))

    (define help-open-file-input-port
      (lambda (who filename options buffer-mode maybe-transcoder)
        (let ([binary-port (open-binary-file-input-port who filename options buffer-mode)])
          (if maybe-transcoder
              (transcoded-port binary-port maybe-transcoder)
              binary-port))))

    (set-who! port-file-compressed!
      (lambda (p)
        (unless (port? p) ($oops who "~s is not a port" p))
        (when (and (input-port? p) (output-port? p)) ($oops who "cannot compress input/output port ~s" p))
        (let ([bp (if (binary-port? p)
                      p
                      (let ([info ($port-info p)])
                        (and (codec-info? info) (codec-info-bp info))))])
          (unless (and bp ($port-flags-set? bp (constant port-flag-file))) ($oops who "~s is not a file port" p))
          (unless ($port-flags-set? bp (constant port-flag-compressed))
            (let ([fd ($port-info bp)])
              (unless ($fd-regular? fd) ($oops who "~s is not a regular file" p))
              ; flush any uncompressed data in the output buffer
              (when (output-port? p) (flush-output-port p))
              (critical-section
                (let ([gzfd (if (input-port? p)
                                (let ([fp (port-position p)])
                                  ; reposition to 'unread' any compressed data in the input buffer
                                  (set-port-position! p fp)
                                  ($compress-input-fd fd fp))
                                ($compress-output-fd fd))])
                  (when (string? gzfd) ($oops who "failed for ~s: ~(~a~)" p gzfd))
                  (unless (eqv? gzfd fd) ; uncompressed input port
                    (assert (box? gzfd))
                    ($set-port-info! bp (unbox gzfd))
                    ($set-port-flags! bp (constant port-flag-compressed))))))))))

    (set-who! open-fd-input-port
      (case-lambda
        [(fd)
         (unless (and (fixnum? fd) (fx>= fd 0))
           ($oops who "~s is not a file descriptor" fd))
         (open-binary-fd-input-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) (buffer-mode block) #f)]
        [(fd buffer-mode)
         (unless (and (fixnum? fd) (fx>= fd 0))
           ($oops who "~s is not a file descriptor" fd))
         (unless (buffer-mode? buffer-mode)
           ($oops who "~s is not a buffer mode" buffer-mode))
         (open-binary-fd-input-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f)]
        [(fd buffer-mode maybe-transcoder)
         (unless (and (fixnum? fd) (fx>= fd 0))
           ($oops who "~s is not a file descriptor" fd))
         (unless (buffer-mode? buffer-mode)
           ($oops who "~s is not a buffer mode" buffer-mode))
         (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
           ($oops who "~s is not #f or a transcoder" maybe-transcoder))
         (let ([binary-port (open-binary-fd-input-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f)])
           (if maybe-transcoder
               (transcoded-port binary-port maybe-transcoder)
               binary-port))]))

    (let ()
      (define s-process (foreign-procedure "(cs)s_process" (string boolean) scheme-object))
      (define (subprocess-port who what fd pid b-mode maybe-transcoder)
        (unless (buffer-mode? b-mode)
          ($oops who "~s is not a valid buffer mode" b-mode))
        (let ([name (format "pid ~s ~a" pid what)])
          (let ([bp (if (eq? what 'stdin)
                        (open-binary-fd-output-port who name (make-fd fd) #f b-mode #f #f)
                        (open-binary-fd-input-port who name (make-fd fd) #f b-mode #f))])
           (if maybe-transcoder (transcoded-port bp maybe-transcoder) bp))))
      (set-who! process
        (lambda (s)
          (unless (string? s) ($oops who "~s is not a string" s))
          (apply (lambda (ifd ofd pid)
                   (list
                     (subprocess-port who 'stdout ifd pid (buffer-mode block) (current-transcoder))
                     (subprocess-port who 'stdin ofd pid (buffer-mode line) (current-transcoder))
                     pid))
            (s-process s #f))))
      (set-who! open-process-ports
        (case-lambda
          [(s)
           (unless (string? s) ($oops who "~s is not a string" s))
           (apply (lambda (ifd efd ofd pid)
                    (values
                      (subprocess-port who 'stdin ofd pid (buffer-mode block) #f)
                      (subprocess-port who 'stdout ifd pid (buffer-mode block) #f)
                      (subprocess-port who 'stderr efd pid (buffer-mode block) #f)
                      pid))
             (s-process s #t))]
          [(s b-mode)
           (unless (string? s) ($oops who "~s is not a string" s))
           (apply (lambda (ifd efd ofd pid)
                    (values
                      (subprocess-port who 'stdin ofd pid b-mode #f)
                      (subprocess-port who 'stdout ifd pid b-mode #f)
                      (subprocess-port who 'stderr efd pid b-mode #f)
                      pid))
             (s-process s #t))]
          [(s b-mode maybe-transcoder)
           (unless (string? s) ($oops who "~s is not a string" s))
           (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
             ($oops who "~s is not #f or a transcoder" maybe-transcoder))
           (apply (lambda (ifd efd ofd pid)
                    (values
                      (subprocess-port who 'stdin ofd pid b-mode maybe-transcoder)
                      (subprocess-port who 'stdout ifd pid b-mode maybe-transcoder)
                      (subprocess-port who 'stderr efd pid b-mode maybe-transcoder)
                      pid))
             (s-process s #t))])))

    (set-who! open-file-input-port
      (case-lambda
        [(filename)
         (open-binary-file-input-port who filename (file-options) (buffer-mode block))]
        [(filename options)
         (open-binary-file-input-port who filename options (buffer-mode block))]
        [(filename options buffer-mode)
         (open-binary-file-input-port who filename options buffer-mode)]
        [(filename options buffer-mode maybe-transcoder)
         (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
           ($oops who "~s is not #f or a transcoder" maybe-transcoder))
         (help-open-file-input-port who filename options buffer-mode maybe-transcoder)]))

    (set! $open-file-input-port
      (case-lambda
        [(who filename)
         (open-binary-file-input-port who filename (file-options) (buffer-mode block))]
        [(who filename options)
         (open-binary-file-input-port who filename options (buffer-mode block))]
        [(who filename options buffer-mode)
         (open-binary-file-input-port who filename options buffer-mode)]
        [(who filename options buffer-mode maybe-transcoder)
         (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
           ($oops who "~s is not #f or a transcoder" maybe-transcoder))
         (help-open-file-input-port who filename options buffer-mode maybe-transcoder)]))

    (set-who! standard-input-port
      (case-lambda
        [() (open-binary-standard-input-port (buffer-mode block))]
        [(b-mode) (open-binary-standard-input-port b-mode)]
        [(b-mode maybe-transcoder)
         (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
           ($oops who "~s is not #f or a transcoder" maybe-transcoder))
         (let ([binary-port (open-binary-standard-input-port b-mode)])
           (if maybe-transcoder
               (transcoded-port binary-port maybe-transcoder)
               binary-port))]))

    (set-who! r6rs:standard-input-port
      (rec standard-input-port
        (lambda ()
          (open-binary-standard-input-port (buffer-mode block)))))

   ; simple i/o routines here to share helpers
    (let ()
      (define (oif who s o)
        (unless (string? s) ($oops who "~s is not a string" s))
        (let ([o (if (list? o) o (list o))])
          (let loop ([o o] [zmode #f] [bmode #f])
            (if (null? o)
                (help-open-file-input-port who s
                  (if (eq? zmode 'compressed) (file-options compressed) (file-options))
                  (if (eq? bmode 'unbuffered) (buffer-mode none) (buffer-mode block))
                  (current-transcoder))
                (case (car o)
                  [(compressed uncompressed)
                   (check-option who zmode (car o))
                   (loop (cdr o) (car o) bmode)]
                  [(buffered unbuffered)
                   (check-option who bmode (car o))
                   (loop (cdr o) zmode (car o))]
                  [else ($oops who "invalid option ~s" (car o))])))))

      (set-who! #(r6rs: open-input-file)
        (lambda (s) (oif who s '())))

      (set-who! open-input-file
        (case-lambda
          [(s) (oif who s '())]
          [(s o) (oif who s o)]))

      (let ()
        (define (cwif who s f o)
          (unless (procedure? f)
            ($oops 'call-with-input-file "~s is not a procedure" f))
          (let ([p (oif 'call-with-input-file s o)])
            (call-with-values
              (lambda () (f p))
              (lambda args (close-input-port p) (apply values args)))))
        (set-who! #(r6rs: call-with-input-file)
          (lambda (s f) (cwif who s f '())))
        (set-who! call-with-input-file
          (case-lambda
            [(s f) (cwif who s f '())]
            [(s f o) (cwif who s f o)])))

      (let ()
        (define (wiff who s f o)
          (unless (procedure? f)
            ($oops 'with-input-from-file "~s is not a procedure" f))
          (let ([p (oif 'with-input-from-file s o)])
            (call-with-values
              (lambda () (parameterize ([current-input-port p]) (f)))
              (lambda v (close-input-port p) (apply values v)))))
        (set-who! #(r6rs: with-input-from-file)
          (lambda (s f) (wiff who s f '())))
        (set-who! with-input-from-file
          (case-lambda
            [(s f) (wiff who s f '())]
            [(s f o) (wiff who s f o)]))))
    )

  ;; open-bytevector-input-port
  (let ()
    ;; port-info stores whether to claim it is nonblocking or not
    (define $bytevector-input-handler
      (make-port-handler
        [ready?
         (lambda (who p)
           (assert-not-closed who p)
           #t)]
        [lookahead
         (lambda (who p)
           (assert-not-closed who p)
           (if (port-input-empty? p)
               (eof-object)
               (bytevector-u8-ref (binary-port-input-buffer p)
                                  (binary-port-input-index p))))]
        [unget
         (lambda (who p x)
           (assert-not-closed who p)
           (if (eof-object? x)
               ;; We don't set port-eof b/c #!eof only comes at end anyway
               (unless (port-input-empty? p) (unget-error who p x))
               (let ([index (binary-port-input-index p)])
                 (when (eq? 0 index) (unget-error who p x))
                 (set-binary-port-input-index! p (fx1- index)))))]
        [get
         (lambda (who p)
           (assert-not-closed who p)
           (if (port-input-empty? p)
               (eof-object)
               (let ([index (binary-port-input-index p)])
                 (set-binary-port-input-index! p (fx1+ index))
                 (bytevector-u8-ref (binary-port-input-buffer p) index))))]
        [get-some
         (lambda (who p bv start count)
           (assert-not-closed who p)
           (let ([port-count (binary-port-input-count p)])
             (if (eq? 0 port-count)
                 (eof-object)
                 (let ([index (binary-port-input-index p)]
                       [count (fxmin count port-count)])
                   (bytevector-copy! (binary-port-input-buffer p) index
                                     bv start count)
                   (set-binary-port-input-index! p (fx+ index count))
                   count))))]
        [clear-input
         (lambda (who p)
           (assert-not-closed who p))]
        [put #f]
        [put-some #f]
        [flush #f]
        [clear-output #f]
        [close-port
         (lambda (who p)
           (unless (port-closed? p)
             (mark-port-closed! p)
             (set-binary-port-input-size! p 0)))]
        [port-position
         (lambda (who p)
           (assert-not-closed who p)
           (binary-port-input-index p))]
        [set-port-position!
         (lambda (who p x)
           (assert-not-closed who p)
           (unless (and (fixnum? x) (not ($fxu< (binary-port-input-size p) x)))
             (if (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
                 (position-oops who p x "out of range")
                 ($oops who "~s is not a valid position" x)))
           (set-binary-port-input-index! p x))]
        [port-length
         (lambda (who p)
           (assert-not-closed who p)
           (bytevector-length (binary-port-input-buffer p)))]
        [set-port-length! #f]
        [port-nonblocking?
         (lambda (who p)
           (assert-not-closed who p)
           ($port-info p))]
        [set-port-nonblocking!
         (lambda (who p x)
           (assert-not-closed who p)
           ($set-port-info! p x))]))

    (define open-binary-bytevector-input-port
      (lambda (bv)
        (define who 'open-bytevector-input-port)
        (unless (bytevector? bv)
          ($oops who "~s is not a bytevector" bv))
        (let ([p ($make-binary-input-port "bytevector" $bytevector-input-handler bv #f)])
          ($set-port-flags! p (constant port-flag-block-buffered))
          p)))

    (set-who! open-bytevector-input-port
      (case-lambda
       [(bv) (open-binary-bytevector-input-port bv)]
       [(bv maybe-transcoder)
        (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
          ($oops who "~s is not #f or a transcoder" maybe-transcoder))
        (let ([binary-port (open-binary-bytevector-input-port bv)])
          (if maybe-transcoder
              (transcoded-port binary-port maybe-transcoder)
              binary-port))]))
    )

  ;; open-string-input-port
  (let ()
    ;; port-info stores whether to claim it is nonblocking or not
    (define $string-input-handler
      (make-port-handler
        [ready?
         (lambda (who p)
           (assert-not-closed who p)
           #t)]
        [lookahead
         (lambda (who p)
           (assert-not-closed who p)
           (if (port-input-empty? p)
               (eof-object)
               (string-ref (textual-port-input-buffer p)
                           (textual-port-input-index p))))]
        [unget
         (lambda (who p x)
           (assert-not-closed who p)
           (if (eof-object? x)
               ;; We don't set port-eof b/c #!eof only comes at end anyway
               (unless (port-input-empty? p) (unget-error who p x))
               (let ([index (textual-port-input-index p)])
                 (when (eq? 0 index) (unget-error who p x))
                 (set-textual-port-input-index! p (fx1- index)))))]
        [get
         (lambda (who p)
           (assert-not-closed who p)
           (if (port-input-empty? p)
               (eof-object)
               (let ([index (textual-port-input-index p)])
                 (set-textual-port-input-index! p (fx1+ index))
                 (string-ref (textual-port-input-buffer p) index))))]
        [get-some
         (lambda (who p st start count)
           (assert-not-closed who p)
           (let ([port-count (textual-port-input-count p)])
             (if (eq? 0 port-count)
                 (eof-object)
                 (let ([index (textual-port-input-index p)]
                       [count (fxmin count port-count)])
                   (string-copy! (textual-port-input-buffer p) index
                                 st start count)
                   (set-textual-port-input-index! p (fx+ index count))
                   count))))]
        [clear-input
         (lambda (who p)
           (assert-not-closed who p))]
        [put #f]
        [put-some #f]
        [flush #f]
        [clear-output #f]
        [close-port
         (lambda (who p)
           (unless (port-closed? p)
             (mark-port-closed! p)
             (set-textual-port-input-size! p 0)))]
        [port-position
         (lambda (who p)
           (assert-not-closed who p)
           (textual-port-input-index p))]
        [set-port-position!
         (lambda (who p x)
           (assert-not-closed who p)
           (unless (and (fixnum? x) (not ($fxu< (textual-port-input-size p) x)))
             (if (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
                 (position-oops who p x "out of range")
                 ($oops who "~s is not a valid position" x)))
           (set-textual-port-input-index! p x))]
        [port-length
         (lambda (who p)
           (assert-not-closed who p)
           (string-length (textual-port-input-buffer p)))]
        [set-port-length! #f]
        [port-nonblocking?
         (lambda (who p)
           (assert-not-closed who p)
           ($port-info p))]
        [set-port-nonblocking!
         (lambda (who p x)
           (assert-not-closed who p)
           ($set-port-info! p x))]))

    (define (osip who str)
      (unless (string? str)
        ($oops who "~s is not a string" str))
      (let ([p ($make-textual-input-port "string" $string-input-handler str #f)])
        ($set-port-flags! p (constant port-flag-block-buffered))
        ($set-port-flags! p (constant port-flag-char-positions))
        p))

    (set-who! open-string-input-port
      (lambda (str)
        (osip who str)))

    (set-who! open-input-string
      (lambda (str)
        (osip who str)))
    )

  ;; standard-input-port in open-binary-file-input-port section
  ;; current-input-port in prims.ss

  (set-who! make-custom-binary-input-port
    (lambda (id read! get-position set-position! close)
      (unless (string? id) ($oops who "~s is not a string" id))
      (unless (procedure? read!) ($oops who "~s is not a procedure" read!))
      (unless (or (not get-position) (procedure? get-position))
        ($oops who "~s is not a procedure or #f" get-position))
      (unless (or (not set-position!) (procedure? set-position!))
        ($oops who "~s is not a procedure or #f" set-position!))
      (unless (or (not close) (procedure? close))
        ($oops who "~s is not a procedure or #f" close))
      (let ([handler
             (make-port-handler
               [ready?
                (lambda (who p)
                  (assert-not-closed who p)
                  (or (not (port-input-empty? p))
                      (port-flag-eof-set? p)
                      (read-oops who p "cannot determine ready status")))]
               [lookahead
                (lambda (who p)
                  (assert-not-closed who p)
                  (binary-custom-port-lookahead who p read!))]
               [unget
                (lambda (who p x)
                  (assert-not-closed who p)
                  (binary-custom-port-unget who p x))]
               [get
                (lambda (who p)
                  (assert-not-closed who p)
                  (binary-custom-port-get who p read!))]
               [get-some
                (lambda (who p bv start count)
                  (assert-not-closed who p)
                  (binary-custom-port-get-some who p read! bv start count))]
               [clear-input
                (lambda (who p)
                  (assert-not-closed who p)
                  (binary-custom-port-clear-input who p))]
               [put #f]
               [put-some #f]
               [flush #f]
               [clear-output #f]
               [close-port
                (lambda (who p)
                  (unless (port-closed? p)
                    (binary-custom-port-close-port who p close)))]
               [port-position
                (and get-position
                  (lambda (who p)
                    (assert-not-closed who p)
                    (binary-custom-port-port-position in who p get-position)))]
               [set-port-position!
                (and set-position!
                  (lambda (who p x)
                    (unless (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
                      ($oops who "~s is not a valid position" x))
                    (assert-not-closed who p)
                    (set-binary-port-input-size! p 0) ;; junk the buffer data
                    (set-port-eof! p #f)
                    (set-position! x)))]
               [port-length #f]
               [set-port-length! #f]
               [port-nonblocking? #f]
               [set-port-nonblocking! #f])])
        (let ([p ($make-binary-input-port id handler
                   (make-bytevector (custom-port-buffer-size))
                   #f)])
          ($set-port-flags! p (constant port-flag-block-buffered))
          (set-binary-port-input-size! p 0)
          p))))

  (set-who! make-custom-textual-input-port
    (lambda (id read! get-position set-position! close)
      (unless (string? id) ($oops who "~s is not a string" id))
      (unless (procedure? read!) ($oops who "~s is not a procedure" read!))
      (unless (or (not get-position) (procedure? get-position))
        ($oops who "~s is not a procedure or #f" get-position))
      (unless (or (not set-position!) (procedure? set-position!))
        ($oops who "~s is not a procedure or #f" set-position!))
      (unless (or (not close) (procedure? close))
        ($oops who "~s is not a procedure or #f" close))
      (let ([handler
             (make-port-handler
               [ready?
                (lambda (who p)
                  (assert-not-closed who p)
                  (or (not (port-input-empty? p))
                      (port-flag-eof-set? p)
                      (read-oops who p "cannot determine ready status")))]
               [lookahead
                (lambda (who p)
                  (assert-not-closed who p)
                  (textual-custom-port-lookahead who p read!))]
               [unget
                (lambda (who p x)
                  (assert-not-closed who p)
                  (textual-custom-port-unget who p x))]
               [get
                (lambda (who p)
                  (assert-not-closed who p)
                  (textual-custom-port-get who p read!))]
               [get-some
                (lambda (who p str start count)
                  (assert-not-closed who p)
                  (textual-custom-port-get-some who p read! str start count))]
               [clear-input
                (lambda (who p)
                  (assert-not-closed who p)
                  (textual-custom-port-clear-input who p))]
               [put #f]
               [put-some #f]
               [flush #f]
               [clear-output #f]
               [close-port
                (lambda (who p)
                  (unless (port-closed? p)
                    (textual-custom-port-close-port who p close)))]
               [port-position
                (and get-position
                  (lambda (who p)
                    (assert-not-closed who p)
                    (unless (port-input-empty? p)
                      (position-warning who
                        "cannot determine accurate position after read on ~s"
                        p))
                    (get-position)))]
               [set-port-position!
                (and set-position!
                  (lambda (who p x)
                    (assert-not-closed who p)
                    (set-textual-port-input-size! p 0) ;; junk the buffer data
                    (set-port-eof! p #f)
                    (set-position! x)))]
               [port-length #f]
               [set-port-length! #f]
               [port-nonblocking? #f]
               [set-port-nonblocking! #f])])
        (let ([p ($make-textual-input-port id handler
                   (make-string (custom-port-buffer-size))
                   #f)])
          ($set-port-flags! p (constant port-flag-block-buffered))
          (set-textual-port-input-size! p 0)
          p))))


;;;; 8.2.8 Binary input
  ;; get-u8 in prims.ss
  ;; lookahead-u8 in prims.ss
  ;; unget-u8 in prims.ss

  ;; get-bytevector! ::  port * bv * start * max -> count TODO(not R6RS)

  (let ()
    ;; This helper handles all the looping for the following functions
    (define (get-bytevector-min-max who p bv start min max)
      (if (eq? 0 max)
          0
          (let ([get-some (port-handler-get-some ($port-handler p))])
            ;; Loop invariant:
            ;;   next = next spot to fill in the bytevector
            ;;   min = minimum left to read
            ;;   max = maximum left to read
            (let loop ([next start]
                       [min min]
                       [max max])
              (let ([n (get-some who p bv next max)])
                (if (eof-object? n)
                    (if (eq? start next)
                        (eof-object) ;; We couldn't even read one byte
                        (begin ;; Got some but got #!eof before full
                          (call-port-handler unget who p (eof-object)) ;; Put the #!eof back
                          (fx- next start))) ;; Return our count
                    (let ([min (fx- min n)]
                          [next (fx+ next n)])
                      (if (fx<= min 0)
                          (fx- next start) ;; We got enough to stop
                          (loop next min (fx- max n))))))))))

    (define (append-blocks size block-size block blocks)
      (let ([buffer (#2%make-bytevector size)])
        (let loop ([block-size block-size] [block block] [blocks blocks] [end size])
          (let ([end (fx- end block-size)])
            (bytevector-copy! block 0 buffer end block-size)
            (if (null? blocks)
                buffer
                (loop (caar blocks) (cdar blocks) (cdr blocks) end))))))

    (set-who! get-bytevector-n
      (lambda (binary-input-port count)
        (unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
          ($oops who "~s is not a binary input port" binary-input-port))
        (unless (and (fixnum? count) (fx>= count 0))
          ($oops who "~s is not a nonnegative fixnum" count))
        (let ([buffer-size (file-buffer-size)])
          (if (not ($fxu< buffer-size count))
              (let ([bv (make-bytevector count)])
                (let ([n (get-bytevector-min-max
                          who binary-input-port bv 0 count count)])
                  (if (eof-object? n) n (bytevector-truncate! bv n))))
              (let ([get-some (port-handler-get-some ($port-handler binary-input-port))])
                (let loop ([count count]
                           [size 0]
                           [next-block-index 0]
                           [next-block (make-bytevector buffer-size)]
                           [blocks '()])
                  (let ([next-size (get-some who binary-input-port
                                     next-block next-block-index
                                     (fxmin count (fx- buffer-size next-block-index)))])
                    (if (or (eof-object? next-size) (eq? next-size 0))
                        (if (eqv? size 0)
                            (if (eof-object? next-size) (eof-object) #vu8())
                            (append-blocks size next-block-index next-block blocks))
                        (let ([count (fx- count next-size)]
                              [size (fx+ size next-size)]
                              [next-block-index (fx+ next-block-index next-size)])
                          (if (eqv? count 0)
                              (append-blocks size next-block-index next-block blocks)
                              (if (fx>= next-block-index (fxquotient buffer-size 2))
                                  (loop count size 0
                                    (make-bytevector buffer-size)
                                    (cons (cons next-block-index next-block) blocks))
                                  (loop count size next-block-index next-block blocks))))))))))))

    (set-who! get-bytevector-n!
      (lambda (binary-input-port bv start count)
        (unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
          ($oops who "~s is not a binary input port" binary-input-port))
        (unless (bytevector? bv)
          ($oops who "~s is not a bytevector" bv))
        (unless (and (fixnum? start) (fx>= start 0))
          ($oops who "invalid start value ~s" start))
        (unless (and (fixnum? count) (fx>= count 0))
          ($oops who "invalid count ~s" count))
        (unless (fx<= count (fx- (bytevector-length bv) start)) ; avoid overflow
          ($oops who "index ~s + count ~s is beyond the end of ~s" start count bv))
        (get-bytevector-min-max who binary-input-port bv start count count)))

    (set-who! get-bytevector-some
      (lambda (binary-input-port)
        (let ([buffer-size (file-buffer-size)])
          (unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
            ($oops who "~s is not a binary input port" binary-input-port))
          (let ([bv (make-bytevector buffer-size)])
            (let ([n (get-bytevector-min-max who binary-input-port bv 0 0 buffer-size)])
              (if (eof-object? n)
                  (eof-object)
                  (bytevector-truncate! bv n)))))))

    (set-who! get-bytevector-some!
      (lambda (binary-input-port bv start count)
        (unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
          ($oops who "~s is not a binary input port" binary-input-port))
        (unless (bytevector? bv)
          ($oops who "~s is not a bytevector" bv))
        (unless (and (fixnum? start) (fx>= start 0))
          ($oops who "invalid start value ~s" start))
        (unless (and (fixnum? count) (fx>= count 0))
          ($oops who "invalid count ~s" count))
        (unless (fx<= count (fx- (bytevector-length bv) start)) ; avoid overflow
          ($oops who "index ~s + count ~s is beyond the end of ~s" start count bv))
        (get-bytevector-min-max who binary-input-port bv start 0 count)))

    (set-who! get-bytevector-all
      (lambda (binary-input-port)
        (unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
          ($oops who "~s is not a binary input port" binary-input-port))
        (let ([buffer-size (file-buffer-size)])
          (let ([get-some (port-handler-get-some ($port-handler binary-input-port))])
            (let loop ([size 0]
                       [next-block-index 0]
                       [next-block (make-bytevector buffer-size)]
                       [blocks '()])
              (let ([next-size (get-some who binary-input-port
                                 next-block next-block-index
                                 (fx- buffer-size next-block-index))])
                (if (eof-object? next-size)
                    (if (eq? size 0)
                        (eof-object)
                        (append-blocks size next-block-index next-block blocks))
                    (let ([size (fx+ size next-size)]
                          [next-block-index (fx+ next-block-index next-size)])
                      (if (fx>= next-block-index (fxquotient buffer-size 2))
                          (loop size 0
                            (make-bytevector buffer-size)
                            (cons (cons next-block-index next-block) blocks))
                          (loop size next-block-index next-block blocks))))))))))
    )


;;;; 8.2.9 Textual input
  ;; get-char in prims.ss
  ;; lookahead-char in prims.ss

  (let ()
    ;; TODO: this code is identical to get-bytevector-min-max
    ;; This helper handles all the looping for the following functions
    (define (get-string-min-max who p bv start min max)
      (if (eq? 0 max)
          0
          (let ([get-some (port-handler-get-some ($port-handler p))])
            ;; Loop invariant:
            ;;   next = next spot to fill in the bytevector
            ;;   min = minimum left to read
            ;;   max = maximum left to read
            (let loop ([next start]
                       [min min]
                       [max max])
              (let ([n (get-some who p bv next max)])
                (if (eof-object? n)
                    (if (eq? start next)
                        (eof-object) ;; We couldn't even read one byte
                        (begin ;; Got some but got #!eof before full
                          (call-port-handler unget who p (eof-object)) ;; Put the #!eof back
                          (fx- next start))) ;; Return our count
                    (let ([min (fx- min n)]
                          [next (fx+ next n)])
                      (if (fx<= min 0)
                          (fx- next start) ;; We got enough to stop
                          (loop next min (fx- max n))))))))))

    (define (append-blocks size block-size block blocks)
      (let ([buffer (#2%make-string size)])
        (let loop ([block-size block-size] [block block] [blocks blocks] [end size])
          (let ([end (fx- end block-size)])
            (string-copy! block 0 buffer end block-size)
            (if (null? blocks)
                buffer
                (loop (caar blocks) (cdar blocks) (cdr blocks) end))))))

    (define $get-string-all
      (lambda (who textual-input-port)
        (let ([buffer-size (file-buffer-size)])
          (let ([get-some (port-handler-get-some ($port-handler textual-input-port))])
            (let loop ([size 0]
                       [next-block-index 0]
                       [next-block (make-string buffer-size)]
                       [blocks '()])
              (let ([next-size (get-some who textual-input-port
                                 next-block next-block-index
                                 (fx- buffer-size next-block-index))])
                (if (eof-object? next-size)
                    (if (eq? size 0)
                        (eof-object)
                        (append-blocks size next-block-index next-block blocks))
                    (let ([size (fx+ size next-size)]
                          [next-block-index (fx+ next-block-index next-size)])
                      (if (fx>= next-block-index (fxquotient buffer-size 2))
                          (loop size 0
                            (make-string buffer-size)
                            (cons (cons next-block-index next-block) blocks))
                          (loop size next-block-index next-block blocks))))))))))

    (set-who! get-string-n
      (lambda (textual-input-port count)
        (unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
          ($oops who "~s is not a textual input port" textual-input-port))
        (unless (and (fixnum? count) (fx>= count 0))
          ($oops who "~s is not a nonnegative fixnum" count))
        (let ([buffer-size (file-buffer-size)])
          (if (not ($fxu< buffer-size count))
              (let ([st (make-string count)])
                (let ([n (get-string-min-max
                          who textual-input-port st 0 count count)])
                  (if (eof-object? n) n (string-truncate! st n))))
              (let ([get-some (port-handler-get-some ($port-handler textual-input-port))])
                (let loop ([count count]
                           [size 0]
                           [next-block-index 0]
                           [next-block (make-string buffer-size)]
                           [blocks '()])
                  (let ([next-size (get-some who textual-input-port
                                     next-block next-block-index
                                     (fxmin count (fx- buffer-size next-block-index)))])
                    (if (or (eof-object? next-size) (eq? next-size 0))
                        (if (eqv? size 0)
                            (if (eof-object? next-size) (eof-object) "")
                            (append-blocks size next-block-index next-block blocks))
                        (let ([count (fx- count next-size)]
                              [size (fx+ size next-size)]
                              [next-block-index (fx+ next-block-index next-size)])
                          (if (eqv? count 0)
                              (append-blocks size next-block-index next-block blocks)
                              (if (fx>= next-block-index (fxquotient buffer-size 2))
                                  (loop count size 0
                                    (make-string buffer-size)
                                    (cons (cons next-block-index next-block) blocks))
                                  (loop count size next-block-index next-block blocks))))))))))))

    (set-who! get-string-n!
      (lambda (textual-input-port st start count)
        (unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
          ($oops who "~s is not a textual input port" textual-input-port))
        (unless (string? st)
          ($oops who "~s is not a string" st))
        (unless (and (fixnum? start) (fx>= start 0))
          ($oops who "invalid start value ~s" start))
        (unless (and (fixnum? count) (fx>= count 0))
          ($oops who "invalid count ~s" count))
        (unless (fx<= count (fx- (string-length st) start)) ; avoid overflow
          ($oops who "index ~s + count ~s is beyond the end of ~s" start count st))
        (get-string-min-max who textual-input-port st start count count)))

    (set-who! get-string-some
      (lambda (textual-input-port)
        (unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
          ($oops who "~s is not a textual input port" textual-input-port))
        (let ([buffer-size (file-buffer-size)])
          (let ([st (make-string buffer-size)])
            (let ([n (get-string-min-max who textual-input-port st 0 0 buffer-size)])
              (if (eof-object? n)
                  (eof-object)
                  (string-truncate! st n)))))))

    (set-who! get-string-some!
      (lambda (textual-input-port st start count)
        (unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
          ($oops who "~s is not a textual input port" textual-input-port))
        (unless (string? st)
          ($oops who "~s is not a string" st))
        (unless (and (fixnum? start) (fx>= start 0))
          ($oops who "invalid start value ~s" start))
        (unless (and (fixnum? count) (fx>= count 0))
          ($oops who "invalid count ~s" count))
        (unless (fx<= count (fx- (string-length st) start)) ; avoid overflow
          ($oops who "index ~s + count ~s is beyond the end of ~s" start count st))
        (get-string-min-max who textual-input-port st start 0 count)))

    (set-who! get-string-all
      (lambda (textual-input-port)
        (unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
          ($oops who "~s is not a textual input port" textual-input-port))
        ($get-string-all who textual-input-port)))

    (set-who! bytevector->string
      (lambda (bv tx)
        (unless (bytevector? bv)
          ($oops who "~s is not a bytevector" bv))
        (unless ($transcoder? tx)
          ($oops who "~s is not a transcoder" tx))
        (let ([str ($get-string-all who (open-bytevector-input-port bv tx))])
          (if (eof-object? str) "" str))))
    )

  (set-who! get-line
    (lambda (tp)
      (unless (and (input-port? tp) (textual-port? tp))
        ($oops who "~s is not a textual input port" tp))
      (let f ([n 0])
        (let ([c (get-char tp)])
          (cond
            [(eof-object? c) (if (fx= n 0) c (begin (unget-char tp c) (make-string n)))]
            [(char=? c #\newline) (make-string n)]
            [else (let ([s (f (fx+ n 1))]) (string-set! s n c) s)])))))

  ;; get-datum in read.ss

;;;; 8.2.10 Output ports
  ;; output-port? in prims.ss
  (let ()
    (define who 'flush-output-port)
    (define flush-help
      (lambda (output-port)
        (call-port-handler flush who output-port)))
    (define flush-check-help
      (lambda (output-port)
        (unless (output-port? output-port)
          ($oops who "~s is not an output port" output-port))
        (flush-help output-port)))
    (set! flush-output-port
      (case-lambda
        [() (flush-help (current-output-port))]
        [(output-port) (flush-check-help output-port)]))
    (set! r6rs:flush-output-port
      (rec flush-output-port
        (lambda (output-port)
          (flush-check-help output-port)))))

 ; input-port-buffer-mode isn't required by r6rs but would be essentially
 ; the same code.  if anything, it would be even more useless.
  (set-who! output-port-buffer-mode
    (lambda (output-port)
      (unless (output-port? output-port)
        ($oops who "~s is not an output port" output-port))
      (cond
        [($port-flags-set? output-port (constant port-flag-block-buffered))
         (buffer-mode block)]
        [($port-flags-set? output-port (constant port-flag-line-buffered))
         (buffer-mode line)]
        [else (buffer-mode none)])))

  ;; open-file-output-port
  (let ()
    (define open-binary-file-output-port
      (lambda (who filename options perms b-mode)
        (let ([no-create (enum-set-subset? (file-options no-create) options)]
              [no-fail (enum-set-subset? (file-options no-fail) options)]
              [no-truncate (enum-set-subset? (file-options no-truncate) options)]
              [append (enum-set-subset? (file-options append) options)]
              [lock (enum-set-subset? (file-options exclusive) options)]
              [replace (enum-set-subset? (file-options replace) options)]
              [compressed (enum-set-subset? (file-options compressed) options)])
          (when (and compressed lock)
            ($oops who "exclusive option is not supported with compress option"))
          (when-feature windows
            (unless-feature pthreads
             ; try to work around windows file open semantics by trying
             ; to close any open ports to the file if we cannot delete it
             ; without doing so.
              (when replace
                (delete-file filename #f)
                (when (file-exists? filename)
                  (collect (collect-maximum-generation))))))
          (let ([fd (critical-section
                      ($open-output-fd filename perms
                        no-create no-fail no-truncate
                        append lock replace compressed))])
            (when (pair? fd) (open-oops who filename options fd))
            (open-binary-fd-output-port who filename fd #t b-mode lock compressed)))))

    (define help-open-file-output-port
      (lambda (who filename options perms b-mode maybe-transcoder)
        (let ([bp (open-binary-file-output-port who filename options perms b-mode)])
          (if maybe-transcoder
              (transcoded-port bp maybe-transcoder)
              bp))))

    (define open-binary-standard-output-port
      (lambda (who fd name b-mode)
        (unless (buffer-mode? b-mode)
          ($oops who "~s is not a valid buffer mode" b-mode))
        (open-binary-fd-output-port who name (make-fd fd) ($fd-regular? fd) b-mode #f #f)))

    (set-who! open-file-output-port
      (rec open-file-output-port
        (case-lambda
          [(filename) (open-file-output-port filename (file-options))]
          [(filename options) (open-file-output-port filename options (buffer-mode block))]
          [(filename options b-mode) (open-file-output-port filename options b-mode #f)]
          [(filename options b-mode maybe-transcoder)
           (unless (string? filename) ($oops who "~s is not a string" filename))
           (unless (and (enum-set? options) (enum-set-subset? options $file-options))
             ($oops who "~s is not a file-options object" options))
           (unless (buffer-mode? b-mode)
             ($oops who "~s is not a valid buffer mode" b-mode))
           (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
             ($oops who "~s is not #f or a transcoder" maybe-transcoder))
           (help-open-file-output-port who filename options
             (extract-permission-mask options) b-mode maybe-transcoder)])))

    (set! $open-file-output-port
      (rec $open-file-output-port
        (case-lambda
          [(who filename) ($open-file-output-port who filename (file-options))]
          [(who filename options) ($open-file-output-port who filename options (buffer-mode block))]
          [(who filename options b-mode) ($open-file-output-port who filename options b-mode #f)]
          [(who filename options b-mode maybe-transcoder)
           (unless (string? filename) ($oops who "~s is not a string" filename))
           (unless (and (enum-set? options) (enum-set-subset? options $file-options))
             ($oops who "~s is not a file-options object" options))
           (unless (buffer-mode? b-mode)
             ($oops who "~s is not a valid buffer mode" b-mode))
           (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
             ($oops who "~s is not #f or a transcoder" maybe-transcoder))
           (help-open-file-output-port who filename options
             (extract-permission-mask options) b-mode maybe-transcoder)])))

    (set-who! open-fd-output-port
      (case-lambda
        [(fd)
         (unless (and (fixnum? fd) (fx>= fd 0))
           ($oops who "~s is not a file descriptor" fd))
         (open-binary-fd-output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) (buffer-mode block) #f #f)]
        [(fd buffer-mode)
         (unless (and (fixnum? fd) (fx>= fd 0))
           ($oops who "~s is not a file descriptor" fd))
         (unless (buffer-mode? buffer-mode)
           ($oops who "~s is not a buffer mode" buffer-mode))
         (open-binary-fd-output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f #f)]
        [(fd buffer-mode maybe-transcoder)
         (unless (and (fixnum? fd) (fx>= fd 0))
           ($oops who "~s is not a file descriptor" fd))
         (unless (buffer-mode? buffer-mode)
           ($oops who "~s is not a buffer mode" buffer-mode))
         (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
           ($oops who "~s is not #f or a transcoder" maybe-transcoder))
         (let ([bp (open-binary-fd-output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f #f)])
           (if maybe-transcoder
               (transcoded-port bp maybe-transcoder)
               bp))]))

    (set-who! standard-output-port
      (case-lambda
        [() (open-binary-standard-output-port who 1 "stdout" (buffer-mode line))]
        [(b-mode) (open-binary-standard-output-port who 1 "stdout" b-mode)]
        [(b-mode maybe-transcoder)
         (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
           ($oops who "~s is not #f or a transcoder" maybe-transcoder))
         (let ([binary-port (open-binary-standard-output-port who 1 "stdout" b-mode)])
           (if maybe-transcoder
               (transcoded-port binary-port maybe-transcoder)
               binary-port))]))

    (set-who! r6rs:standard-output-port
      (rec standard-output-port
        (lambda ()
          (open-binary-standard-output-port who 1 "stdout" (buffer-mode line)))))

    (set-who! standard-error-port
      (case-lambda
        [() (open-binary-standard-output-port who 2 "stderr" (buffer-mode none))]
        [(b-mode) (open-binary-standard-output-port who 2 "stderr" b-mode)]
        [(b-mode maybe-transcoder)
         (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
           ($oops who "~s is not #f or a transcoder" maybe-transcoder))
         (let ([binary-port (open-binary-standard-output-port who 2 "stderr" b-mode)])
           (if maybe-transcoder
               (transcoded-port binary-port maybe-transcoder)
               binary-port))]))

    (set-who! r6rs:standard-error-port
      (rec standard-error-port
        (lambda ()
          (open-binary-standard-output-port who 2 "stderr" (buffer-mode none)))))

   ; simple i/o routines here to share helpers
    (let ()
      (define (oof who s o)
        (unless (string? s) ($oops who "~s is not a string" s))
        (let ([o (if (list? o) o (list o))])
          (let loop ([o o] [ifexists #f] [mode #o666] [zmode #f] [xmode #f] [bmode #f])
            (if (null? o)
                (help-open-file-output-port who s
                  (enum-set-union
                    (enum-set-union
                      (case ifexists
                        [(error) (file-options)]
                        [(truncate) (file-options no-fail)]
                        [(replace) (file-options no-fail no-truncate replace)]
                        [(append) (file-options append no-fail no-truncate)]
                        [else (file-options)])
                      (if (eq? zmode 'compressed) (file-options compressed) (file-options)))
                    (if (eq? xmode 'exclusive) (file-options exclusive) (file-options)))
                  mode
                  (if (eq? bmode 'unbuffered) (buffer-mode none) (buffer-mode block))
                  (current-transcoder))
                (case (car o)
                  [(error truncate replace append)
                   (check-option who ifexists (car o))
                   (loop (cdr o) (car o) mode zmode xmode bmode)]
                  [(compressed uncompressed)
                   (check-option who zmode (car o))
                   (loop (cdr o) ifexists mode (car o) xmode bmode)]
                  [(buffered unbuffered)
                   (check-option who bmode (car o))
                   (loop (cdr o) ifexists mode zmode xmode (car o))]
                  [(exclusive nonexclusive)
                   (check-option who xmode (car o))
                   (loop (cdr o) ifexists mode zmode (car o) bmode)]
                  [(mode)
                   (if (null? (cdr o))
                       ($oops who "mode option requires an argument")
                       (let ([mode (cadr o)])
                         (if (and (fixnum? mode) (fx>= mode 0))
                             (loop (cddr o) ifexists mode zmode xmode bmode)
                             ($oops who "mode argument must be a nonnegative fixnum"))))]
                  [else ($oops who "invalid option ~s" (car o))])))))

      (set-who! #(r6rs: open-output-file)
        (lambda (s) (oof who s '())))

      (set-who! open-output-file
        (case-lambda
          [(s) (oof who s '())]
          [(s o) (oof who s o)]))

      (let ()
        (define (cwof who s f o)
          (unless (procedure? f)
            ($oops who "~s is not a procedure" f))
          (let ([p (oof who s o)])
            (call-with-values
              (lambda () (f p))
              (lambda args
                (close-output-port p)
                (apply values args)))))
        (set-who! #(r6rs: call-with-output-file)
          (lambda (s f) (cwof who s f '())))
        (set-who! call-with-output-file
          (case-lambda
            [(s f) (cwof who s f '())]
            [(s f o) (cwof who s f o)])))

      (let ()
        (define (wotf who s f o)
          (unless (procedure? f)
            ($oops who "~s is not a procedure" f))
          (let ([p (oof who s o)])
            (call-with-values
              (lambda () (parameterize ([current-output-port p]) (f)))
              (lambda v
                (close-output-port p)
                (apply values v)))))
        (set-who! #(r6rs: with-output-to-file)
          (lambda (s f) (wotf who s f '())))
        (set-who! with-output-to-file
          (case-lambda
            [(s f) (wotf who s f '())]
            [(s f o) (wotf who s f o)]))))

    )

  ;; open-bytevector-output-port
  (let ()
    ;; if info-index != index, there was put/put-some after last set-pos
    ;;   and (max info-length index) is true length
    ;; if info-index == index, there was set-pos after last put/put-some
    ;;   and info-length is true length

    ;; Invariant: info-index <= index
    ;; Invariant: size = (max length index)
    ;; Invariant: if no put/put-some after last set-pos/set-length,
    ;;       then info-index = index and true length = info-length
    ;; Invariant: if put/put-some after last set-pos/set-length,
    ;;       then info-index < index and true length = max info-length index

    ;; It is always safe to increment index when count != 0
    ;; It is always safe to write at index when count != 0
    ;; Index always contains the current position
    ;; The only operation that needs to decrement index is set-position
    ;;   which needs to set info-index anyway

    (define-record-type bytevector-output-port-info
      (nongenerative)
      (opaque #t)
      (sealed #t)
      (fields
        (mutable index)
        (mutable length)
        (mutable nonblocking)))

    ;; NOTE: leaves index at 0, callers must reset index if needed
    (define (extend-buffer p count)
      (let ([old-size (binary-port-output-size p)]
            [old-buffer (binary-port-output-buffer p)]
            [old-index (binary-port-output-index p)])
      (let* ([new-length (fxmax bytevector-buffer-length
                                (fx* 2 (fx+ old-size count)))]
             [new-buffer (make-bytevector new-length)])
          (bytevector-copy! old-buffer 0 new-buffer 0
                            (fxmin (bytevector-length old-buffer) old-size))
          (set-binary-port-output-buffer! p new-buffer))))

    (define port-length
      (lambda (who p)
        (let ([info ($port-info p)]
              [index (binary-port-output-index p)])
          (let ([info-index (bytevector-output-port-info-index info)]
                [info-length (bytevector-output-port-info-length info)])
            (if (eq? index info-index)
                info-length ;; last op was set-pos
                (max index info-length)))))) ;; last op was put

    (define $bytevector-output-handler
      (make-port-handler
        [ready? #f]
        [lookahead #f]
        [unget #f]
        [get #f]
        [get-some #f]
        [clear-input #f]
        [put
         (lambda (who p x)
           (assert-not-closed who p)
           (let ([index (binary-port-output-index p)])
             (when (port-output-full? p) (extend-buffer p 0))
             (bytevector-u8-set! (binary-port-output-buffer p) index x)
             (set-binary-port-output-index! p (fx1+ index))))]
        [put-some
         (lambda (who p bv start count)
           (assert-not-closed who p)
           (let ([index (binary-port-output-index p)])
             (when ($fxu< (binary-port-output-count p) count) (extend-buffer p count))
             (bytevector-copy! bv start
               (binary-port-output-buffer p) index count)
             (set-binary-port-output-index! p (fx+ index count)))
           count)]
        [flush ; no-op on bytevector output ports
         (lambda (who p)
           (assert-not-closed who p))]
        [clear-output ; no-op on bytevector output ports
         (lambda (who p)
           (assert-not-closed who p))]
        [close-port
         (lambda (who p)
           (unless (port-closed? p)
            ; sync info-index for possible post-close extraction
             (let ([info ($port-info p)] [index (binary-port-output-index p)])
               (unless (eq? index (bytevector-output-port-info-index info))
                 (bytevector-output-port-info-length-set! info
                   (fxmax index (bytevector-output-port-info-length info)))))
             (mark-port-closed! p)
             (set-binary-port-output-size! p 0)))]
        [port-position
         (lambda (who p)
           (assert-not-closed who p)
           (binary-port-output-index p))]
        [set-port-position!
         (lambda (who p pos)
           (assert-not-closed who p)
           (unless (and (fixnum? pos) (fx>= pos 0))
             (if (and (bignum? pos) (>= pos 0))
                 (position-oops who p pos "out of range")
                 ($oops who "~s is not a valid position" pos)))
           (let ([info ($port-info p)]
                 [index (binary-port-output-index p)])
            ; unless last op was set-pos, save the true length
             (unless (eq? index (bytevector-output-port-info-index info))
               (bytevector-output-port-info-length-set! info
                 (fxmax index (bytevector-output-port-info-length info))))
             (set-binary-port-output-size! p
               (fxmax pos (fx1- (bytevector-length (binary-port-output-buffer p)))))
             (set-binary-port-output-index! p pos)
             (bytevector-output-port-info-index-set! info pos)))]
        [port-length
         (lambda (who p)
           (assert-not-closed who p)
           (port-length who p))]
        [set-port-length!
         (lambda (who p pos)
           (unless (and (fixnum? pos) (fx>= pos 0))
             (if (and (bignum? pos) (>= pos 0))
                 (position-oops who p pos "out of range")
                 ($oops who "~s is not a valid length" pos)))
           (assert-not-closed who p)
           (let ([info ($port-info p)]
                 [index (binary-port-output-index p)]
                 [size (binary-port-output-size p)])
             ;; ensure the bytevector is long enough
             (let ([buflen-1 (fx1- (bytevector-length (binary-port-output-buffer p)))])
               (when ($fxu< buflen-1 pos)
                 (extend-buffer p (fx- pos buflen-1))
                 (set-binary-port-output-index! p index)))
             ;; make it look like a set-pos was done last
             ;; (i.e. index might be beyond true length)
             (bytevector-output-port-info-index-set! info index)
             ;; set the true length
             (bytevector-output-port-info-length-set! info pos)))]
        [port-nonblocking?
         (lambda (who p)
           (assert-not-closed who p)
           (bytevector-output-port-info-nonblocking ($port-info p)))]
        [set-port-nonblocking!
         (lambda (who p x)
           (assert-not-closed who p)
           (bytevector-output-port-info-nonblocking-set! ($port-info p) x))]))

    (define extractor
      (lambda (p)
        (let ([old-buffer
               (bytevector-truncate!
                 (binary-port-output-buffer p)
                 (port-length #f p))])
          (set-binary-port-output-buffer! p #vu8())
          (let ([info ($port-info p)])
            (bytevector-output-port-info-index-set! info 0)
            (bytevector-output-port-info-length-set! info 0))
          old-buffer)))

    (define open-binary-bytevector-output-port
      (lambda ()
        (let ([p ($make-binary-output-port "bytevector"
                   $bytevector-output-handler
                   #vu8()
                   (make-bytevector-output-port-info 0 0 #f))])
          ($set-port-flags! p (constant port-flag-block-buffered))
          (values
           p
           (lambda ()
             (let ([info ($port-info p)])
               (if (bytevector-output-port-info? info)
                   (extractor p)
                  ; the port must have been transcoded
                   (begin
                     (flush-output-port info)
                     (extractor (codec-info-bp ($port-info info)))))))))))

    (set-who! open-bytevector-output-port
      (case-lambda
       [() (open-binary-bytevector-output-port)]
       [(maybe-transcoder)
        (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
          ($oops who "~s is not #f or a transcoder" maybe-transcoder))
        (let-values ([(binary-port extractor)
                      (open-binary-bytevector-output-port)])
          (values
           (if maybe-transcoder
               (transcoded-port binary-port maybe-transcoder)
               binary-port)
           extractor))]))
    )

  ;; open-bytevector-list-output-port
  (let ()
    (define-record-type bv-list-op-info
      (nongenerative)
      (sealed #t)
      (fields
        (mutable nonblocking)
        (mutable bv*)))

    ; allocate in chunk-size chunks
    (define chunk-size 4096)

    (define (extend-buffer p)
      (let ([bv (binary-port-output-buffer p)])
        (unless (eqv? bv #vu8())
          (let ([info ($port-info p)])
            (bv-list-op-info-bv*-set! info
              (cons bv (bv-list-op-info-bv* info))))))
      (set-binary-port-output-buffer! p (make-bytevector chunk-size)))

    (define $bytevector-list-output-handler
      (make-port-handler
        [ready? #f]
        [lookahead #f]
        [unget #f]
        [get #f]
        [get-some #f]
        [clear-input #f]
        [put
          (lambda (who p x)
            (assert-not-closed who p)
            (when (port-output-full? p) (extend-buffer p))
            (let ([index (binary-port-output-index p)])
              (bytevector-u8-set! (binary-port-output-buffer p) index x)
              (set-binary-port-output-index! p (fx1+ index))))]
        [put-some
          (lambda (who p bv start count)
            (assert-not-closed who p)
            (when (port-output-full? p) (extend-buffer p))
            (let ([count (fxmin count (binary-port-output-count p))]
                  [index (binary-port-output-index p)])
              (bytevector-copy! bv start (binary-port-output-buffer p) index count)
              (set-binary-port-output-index! p (fx+ index count))
              count))]
        [flush ; no-op on bytevector output ports
          (lambda (who p)
            (assert-not-closed who p))]
        [clear-output ; no-op on bytevector output ports
          (lambda (who p)
            (assert-not-closed who p))]
        [close-port
          (lambda (who p)
            (unless (port-closed? p)
              ; sync info-index for possible post-close extraction
              #;(let ([old-buffer (bytevector-truncate!
                                    (binary-port-output-buffer p)
                                    (binary-port-output-index p))]
                      [bv* (bv-list-op-info-bv* info)])
                  (bv-list-op-info-size-set! info
                    (fx+ (bytevector-length old-buffer)
                      (fx* (length bv*) chunk-size)))
                  (bv-list-op-info-bv*-set! info
                    (reverse (if (eq? old-buffer #vu8())
                                 bv*
                                 (cons old-buffer bv*)))))
              (mark-port-closed! p)
              (set-binary-port-output-size! p 0)))]
        [port-position
          (lambda (who p)
            (assert-not-closed who p)
            (fx+ (binary-port-output-index p)
              (fx* (length (bv-list-op-info-bv* ($port-info p))) chunk-size)))]
        [set-port-position! #f]
        [port-length
          (lambda (who p)
            (assert-not-closed who p)
            (fx+ (binary-port-output-index p)
              (fx* (length (bv-list-op-info-bv* ($port-info p))) chunk-size)))]
        [set-port-length! #f]
        [port-nonblocking?
          (lambda (who p)
            (assert-not-closed who p)
            (bv-list-op-info-nonblocking ($port-info p)))]
        [set-port-nonblocking!
          (lambda (who p x)
            (assert-not-closed who p)
            (bv-list-op-info-nonblocking-set! ($port-info p) x))]))

    (define extractor
      (lambda (p)
        (let ([info ($port-info p)])
          (let ([bv (bytevector-truncate!
                      (binary-port-output-buffer p)
                      (binary-port-output-index p))]
                [bv* (bv-list-op-info-bv* info)])
            (let ([size (fx+ (bytevector-length bv) (fx* (length bv*) chunk-size))])
              (set-binary-port-output-buffer! p #vu8())
              (bv-list-op-info-bv*-set! info '())
              (values (reverse (if (eqv? bv #vu8()) bv* (cons bv bv*))) size))))))

    (set-who! $open-bytevector-list-output-port
      (lambda ()
        (let ([p ($make-binary-output-port "bytevector-list"
                   $bytevector-list-output-handler
                   #vu8()
                   (make-bv-list-op-info #f '()))])
          ($set-port-flags! p (constant port-flag-block-buffered))
          (values p (lambda () (extractor p)))))))

  (let ()
    (define ($call-with-bytevector-output-port who proc maybe-transcoder)
      (let-values ([(port extractor) (open-bytevector-output-port maybe-transcoder)])
        (proc port)
        (let ([bv (extractor)])
          (call-port-handler close-port who port)
          bv)))

    (set-who! call-with-bytevector-output-port
      (case-lambda
        [(proc)
         (unless (procedure? proc) ($oops who "~s is not a procedure" proc))
         ($call-with-bytevector-output-port who proc #f)]
        [(proc maybe-transcoder)
         (unless (procedure? proc)
           ($oops who "~s is not a procedure" proc))
         (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
           ($oops who "~s is not a transcoder" maybe-transcoder))
         ($call-with-bytevector-output-port who proc maybe-transcoder)]))

    (set-who! string->bytevector
      (lambda (str tx)
        (unless (string? str)
          ($oops who "~s is not a string" str))
        (unless ($transcoder? tx)
          ($oops who "~s is not a transcoder" tx))
        ($call-with-bytevector-output-port who
          (lambda (op) (put-string op str))
          tx))))

  ;; open-string-output-port
  (let ()
    ;; see open-bytevector-output-port for explanation of algorithm

    (define-record-type string-output-port-info
      (nongenerative)
      (opaque #t)
      (sealed #t)
      (fields
        (mutable index)
        (mutable length)
        (mutable nonblocking)))

    ;; NOTE: leaves index at 0, callers must reset index if needed
    (define (extend-buffer p count)
      (let ([old-size (textual-port-output-size p)]
            [old-buffer (textual-port-output-buffer p)]
            [old-index (textual-port-output-index p)])
      (let* ([new-length (fxmax string-buffer-length
                                (fx* 2 (fx+ old-size count)))]
             [new-buffer (make-string new-length)])
          (string-copy! old-buffer 0 new-buffer 0
                        (fxmin (string-length old-buffer) old-size))
          (set-textual-port-output-buffer! p new-buffer))))

    (define port-length
       (lambda (who p)
         (let ([info ($port-info p)]
               [index (textual-port-output-index p)])
           (let ([info-index (string-output-port-info-index info)]
                 [info-length (string-output-port-info-length info)])
             (if (eq? index info-index)
                 info-length ;; last op was set-pos
                 (max index info-length)))))) ;; last op was put

    (define $string-output-handler
      (make-port-handler
        [ready? #f]
        [lookahead #f]
        [unget #f]
        [get #f]
        [get-some #f]
        [clear-input #f]
        [put
         (lambda (who p x)
           (assert-not-closed who p)
           (let ([index (textual-port-output-index p)])
             (when (port-output-full? p) (extend-buffer p 0))
             (string-set! (textual-port-output-buffer p) index x)
             (set-textual-port-output-index! p (fx1+ index))))]
        [put-some
         (lambda (who p st start count)
           (assert-not-closed who p)
           (let ([index (textual-port-output-index p)])
             (when ($fxu< (textual-port-output-count p) count) (extend-buffer p count))
             (string-copy! st start
               (textual-port-output-buffer p) index count)
             (set-textual-port-output-index! p (fx+ index count)))
           count)]
        [flush ; no-op on string output ports
         (lambda (who p)
           (assert-not-closed who p))]
        [clear-output ; no-op on string output ports
         (lambda (who p)
           (assert-not-closed who p))]
        [close-port
         (lambda (who p)
           (unless (port-closed? p)
            ; sync info-index for possible post-close extraction
             (let ([info ($port-info p)] [index (textual-port-output-index p)])
               (unless (eq? index (string-output-port-info-index info))
                 (string-output-port-info-length-set! info
                   (fxmax index (string-output-port-info-length info)))))
             (mark-port-closed! p)
             (set-textual-port-output-size! p 0)))]
        [port-position
         (lambda (who p)
           (assert-not-closed who p)
           (textual-port-output-index p))]
        [set-port-position!
         (lambda (who p pos)
           (assert-not-closed who p)
           (unless (and (fixnum? pos) (fx>= pos 0))
             (if (and (bignum? pos) (>= pos 0))
                 (position-oops who p pos "out of range")
                 ($oops who "~s is not a valid position" pos)))
           (let ([info ($port-info p)]
                 [index (textual-port-output-index p)])
            ; unless last op was set-pos, save the true length
             (unless (eq? index (string-output-port-info-index info))
               (string-output-port-info-length-set! info
                 (fxmax index (string-output-port-info-length info))))
             (set-textual-port-output-size! p
               (fxmax pos (fx1- (string-length (textual-port-output-buffer p)))))
             (set-textual-port-output-index! p pos)
             (string-output-port-info-index-set! info pos)))]
        [port-length
         (lambda (who p)
           (assert-not-closed who p)
           (port-length who p))]
        [set-port-length!
         (lambda (who p pos)
           (unless (and (fixnum? pos) (fx>= pos 0))
             (if (and (bignum? pos) (>= pos 0))
                 (position-oops who p pos "out of range")
                 ($oops who "~s is not a valid length" pos)))
           (assert-not-closed who p)
           (let ([info ($port-info p)]
                 [index (textual-port-output-index p)]
                 [size (textual-port-output-size p)])
             ;; ensure the bytevector is long enough
             (let ([buflen-1 (fx1- (string-length (textual-port-output-buffer p)))])
               (when ($fxu< buflen-1 pos)
                 (extend-buffer p (fx- pos buflen-1))
                 (set-textual-port-output-index! p index)))
             ;; make it look like a set-pos was done last
             ;; (i.e. index might be beyond true length)
             (string-output-port-info-index-set! info index)
             ;; set the true length
             (string-output-port-info-length-set! info pos)))]
        [port-nonblocking?
         (lambda (who p)
           (assert-not-closed who p)
           (string-output-port-info-nonblocking ($port-info p)))]
        [set-port-nonblocking!
         (lambda (who p x)
           (assert-not-closed who p)
           (string-output-port-info-nonblocking-set! ($port-info p) x))]))

    (define ($open-string-output-port)
      (let ([p ($make-textual-output-port "string"
                 $string-output-handler
                 ""
                 (make-string-output-port-info 0 0 #f))])
        ($set-port-flags! p (constant port-flag-block-buffered))
        ($set-port-flags! p (constant port-flag-char-positions))
        ($set-port-flags! p (constant port-flag-bol))
        p))

    (define ($get-output-string p)
      (let ([old-buffer
             (string-truncate!
               (textual-port-output-buffer p)
               (port-length #f p))])
        (set-textual-port-output-buffer! p "")
        (let ([info ($port-info p)])
          (string-output-port-info-index-set! info 0)
          (string-output-port-info-length-set! info 0))
        old-buffer))

    (set-who! open-string-output-port
      (lambda ()
        (let ([p ($open-string-output-port)])
          (values p (lambda () ($get-output-string p))))))

    (set-who! open-output-string
      (lambda ()
        ($open-string-output-port)))

    (set-who! get-output-string
      (lambda (p)
        (unless (and (port? p) (eq? ($port-handler p) $string-output-handler))
          ($oops who "~s is not a string output port" p))
        ($get-output-string p)))
    )


  (set-who! call-with-string-output-port
    (lambda (proc)
      (unless (procedure? proc)
        ($oops who "~s is not a procedure" proc))
      (let-values ([(port extractor) (open-string-output-port)])
        (proc port)
        (let ([st (extractor)])
          (call-port-handler close-port who port)
          st))))

  ;; current-output-port and current-error-port are in prims.ss

  (set-who! make-custom-binary-output-port
    (lambda (id write! get-position set-position! close)
      (unless (string? id) ($oops who "~s is not a string" id))
      (unless (procedure? write!) ($oops who "~s is not a procedure" write!))
      (unless (or (not get-position) (procedure? get-position))
        ($oops who "~s is not a procedure or #f" get-position))
      (unless (or (not set-position!) (procedure? set-position!))
        ($oops who "~s is not a procedure or #f" set-position!))
      (unless (or (not close) (procedure? close))
        ($oops who "~s is not a procedure or #f" close))
      (let ([handler
             (make-port-handler
               [ready? #f]
               [lookahead #f]
               [unget #f]
               [get #f]
               [get-some #f]
               [clear-input #f]
               [put
                (lambda (who p x)
                  (assert-not-closed who p)
                  (binary-custom-port-put who p write! x))]
               [put-some
                (lambda (who p bv start count)
                  (assert-not-closed who p)
                  (binary-custom-port-put-some who p write! bv start count))]
               [flush
                (lambda (who p)
                  (assert-not-closed who p)
                  (binary-custom-port-flush who p write!))]
               [clear-output
                (lambda (who p)
                  (assert-not-closed who p)
                  (binary-custom-port-clear-output who p))]
               [close-port
                (lambda (who p)
                  (unless (port-closed? p)
                    (binary-custom-port-flush who p write!)
                    (binary-custom-port-close-port who p close)))]
               [port-position
                (and get-position
                     (lambda (who p)
                       (assert-not-closed who p)
                       (binary-custom-port-port-position out who p get-position)))]
               [set-port-position!
                (and set-position!
                     (lambda (who p x)
                       (unless (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
                         ($oops who "~s is not a valid position" x))
                       (assert-not-closed who p)
                       (binary-custom-port-flush who p write!)
                       (set-position! x)))]
               [port-length #f]
               [set-port-length! #f]
               [port-nonblocking? #f]
               [set-port-nonblocking! #f])])
        (let ([bufsiz (custom-port-buffer-size)])
          (let ([p ($make-binary-output-port id handler (make-bytevector bufsiz) #f)])
            ($set-port-flags! p (constant port-flag-block-buffered))
            (set-binary-port-output-size! p (fx1- bufsiz)) ;; leave room for put to work
            p)))))

  (set-who! make-custom-textual-output-port
    (lambda (id write! get-position set-position! close)
      (unless (string? id) ($oops who "~s is not a string" id))
      (unless (procedure? write!) ($oops who "~s is not a procedure" write!))
      (unless (or (not get-position) (procedure? get-position))
        ($oops who "~s is not a procedure or #f" get-position))
      (unless (or (not set-position!) (procedure? set-position!))
        ($oops who "~s is not a procedure or #f" set-position!))
      (unless (or (not close) (procedure? close))
        ($oops who "~s is not a procedure or #f" close))
      (let ([handler
             (make-port-handler
               [ready? #f]
               [lookahead #f]
               [unget #f]
               [get #f]
               [get-some #f]
               [clear-input #f]
               [put
                (lambda (who p x)
                  (assert-not-closed who p)
                  (textual-custom-port-put who p write! x))]
               [put-some
                (lambda (who p str start count)
                  (assert-not-closed who p)
                  (textual-custom-port-put-some who p write! str start count))]
               [flush
                (lambda (who p)
                  (assert-not-closed who p)
                  (textual-custom-port-flush who p write!))]
               [clear-output
                (lambda (who p)
                  (assert-not-closed who p)
                  (textual-custom-port-clear-output who p))]
               [close-port
                (lambda (who p)
                  (unless (port-closed? p)
                    (textual-custom-port-flush who p write!)
                    (textual-custom-port-close-port who p close)))]
               [port-position
                (and get-position
                     (lambda (who p)
                       (assert-not-closed who p)
                       (textual-custom-port-flush who p write!)
                       (get-position)))]
               [set-port-position!
                (and set-position!
                     (lambda (who p x)
                       (assert-not-closed who p)
                       (textual-custom-port-flush who p write!)
                       (set-position! x)))]
               [port-length #f]
               [set-port-length! #f]
               [port-nonblocking? #f]
               [set-port-nonblocking! #f])])
        (let ([bufsiz (custom-port-buffer-size)])
          (let ([p ($make-textual-output-port id handler (make-string bufsiz) #f)])
            ($set-port-flags! p (constant port-flag-block-buffered))
            ($set-port-flags! p (constant port-flag-bol))
            (set-textual-port-output-size! p (fx1- bufsiz)) ;; leave room for put to work
            p)))))


;;;; 8.2.11 Binary output
  ;; put-u8 in prims.ss

  (set-who! put-bytevector
    (case-lambda
      [(binary-output-port bv)
       (unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
         ($oops who "~s is not a binary output port" binary-output-port))
       (unless (bytevector? bv)
         ($oops who "~s is not a bytevector" bv))
       (#3%put-bytevector binary-output-port bv)]
      [(binary-output-port bv start)
       (unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
         ($oops who "~s is not a binary output port" binary-output-port))
       (unless (bytevector? bv)
         ($oops who "~s is not a bytevector" bv))
       (unless (and (fixnum? start) (not ($fxu< (bytevector-length bv) start)))
         ($oops who "invalid start value ~s" start))
       (#3%put-bytevector binary-output-port bv start)]
      [(binary-output-port bv start count)
       (unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
         ($oops who "~s is not a binary output port" binary-output-port))
       (unless (bytevector? bv)
         ($oops who "~s is not a bytevector" bv))
       (unless (and (fixnum? start) (fx<= 0 start))
         ($oops who "invalid start value ~s" start))
       (unless (and (fixnum? count) (fx<= 0 count))
         ($oops who "invalid count ~s" count))
       (unless (fx<= count (fx- (bytevector-length bv) start)) ; avoid overflow
         ($oops who "index ~s + count ~s is beyond the end of ~s" start count bv))
       (#3%put-bytevector binary-output-port bv start count)]))

  ;; not in R6RS
  (set-who! put-bytevector-some
    (case-lambda
      [(binary-output-port bv)
       (unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
         ($oops who "~s is not a binary output port" binary-output-port))
       (unless (bytevector? bv)
         ($oops who "~s is not a bytevector" bv))
       (#3%put-bytevector-some binary-output-port bv)]
      [(binary-output-port bv start)
       (unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
         ($oops who "~s is not a binary output port" binary-output-port))
       (unless (bytevector? bv)
         ($oops who "~s is not a bytevector" bv))
       (unless (and (fixnum? start) (not ($fxu< (bytevector-length bv) start)))
         ($oops who "invalid start value ~s" start))
       (#3%put-bytevector-some binary-output-port bv start)]
      [(binary-output-port bv start count)
       (unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
         ($oops who "~s is not a binary output port" binary-output-port))
       (unless (bytevector? bv)
         ($oops who "~s is not a bytevector" bv))
       (unless (and (fixnum? start) (fx<= 0 start))
         ($oops who "invalid start value ~s" start))
       (unless (and (fixnum? count) (fx<= 0 count))
         ($oops who "invalid count ~s" count))
       (unless (fx<= count (fx- (bytevector-length bv) start)) ; avoid overflow
         ($oops who "index ~s + count ~s is beyond the end of ~s" start count bv))
       (#3%put-bytevector-some binary-output-port bv start count)]))

;;;; 8.2.12 Textual output
  ;; put-char in prims.ss

  (set-who! put-string
    (case-lambda
     [(textual-output-port str)
      (unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
        ($oops who "~s is not a textual output port" textual-output-port))
      (unless (string? str)
        ($oops who "~s is not a string" str))
      (#3%put-string textual-output-port str)]
     [(textual-output-port str start)
      (unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
        ($oops who "~s is not a textual output port" textual-output-port))
      (unless (string? str)
        ($oops who "~s is not a string" str))
      (unless (and (fixnum? start) (not ($fxu< (string-length str) start)))
        ($oops who "invalid start value ~s" start))
      (#3%put-string textual-output-port str start)]
     [(textual-output-port str start count)
      (unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
        ($oops who "~s is not a textual output port" textual-output-port))
      (unless (string? str)
        ($oops who "~s is not a string" str))
      (unless (and (fixnum? start) (fx<= 0 start))
        ($oops who "invalid start value ~s" start))
      (unless (and (fixnum? count) (fx<= 0 count))
        ($oops who "invalid count value ~s" count))
      (unless (fx<= count (fx- (string-length str) start)) ; avoid overflow
        ($oops who "index ~s + count ~s is beyond the end of ~s" start count str))
      (#3%put-string textual-output-port str start count)]))

  ;; not in R6RS
  (set-who! put-string-some
    (case-lambda
     [(textual-output-port str)
      (unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
        ($oops who "~s is not a textual output port" textual-output-port))
      (unless (string? str)
        ($oops who "~s is not a string" str))
      (#3%put-string-some textual-output-port str)]
     [(textual-output-port str start)
      (unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
        ($oops who "~s is not a textual output port" textual-output-port))
      (unless (string? str)
        ($oops who "~s is not a string" str))
      (unless (and (fixnum? start) (not ($fxu< (string-length str) start)))
        ($oops who "invalid start value ~s" start))
      (#3%put-string-some textual-output-port str start)]
     [(textual-output-port str start count)
      (unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
        ($oops who "~s is not a textual output port" textual-output-port))
      (unless (string? str)
        ($oops who "~s is not a string" str))
      (unless (and (fixnum? start) (fx<= 0 start))
        ($oops who "invalid start value ~s" start))
      (unless (and (fixnum? count) (fx<= 0 count))
        ($oops who "invalid count value ~s" count))
      (unless (fx<= count (fx- (string-length str) start)) ; avoid overflow
        ($oops who "index ~s + count ~s is beyond the end of ~s" start count str))
      (#3%put-string-some textual-output-port str start count)]))

  ;; put-datum in print.ss

;;;; 8.2.13 Input/output ports
  ;; open-file-input/output-port
  (let ()
    (define open-binary-file-input/output-port
      (lambda (who filename options perms b-mode)
        (let ([no-create (enum-set-subset? (file-options no-create) options)]
              [no-fail (enum-set-subset? (file-options no-fail) options)]
              [no-truncate (enum-set-subset? (file-options no-truncate) options)]
              [append (enum-set-subset? (file-options append) options)]
              [lock (enum-set-subset? (file-options exclusive) options)]
              [replace (enum-set-subset? (file-options replace) options)]
              [compressed (enum-set-subset? (file-options compressed) options)])
          (when (and compressed lock)
            ($oops who "exclusive option is not supported with compress option"))
          (when-feature windows
            (unless-feature pthreads
             ; try to work around windows file open semantics by trying
             ; to close any open ports to the file if we cannot delete it
             ; without doing so.
              (when replace
                (delete-file filename #f)
                (when (file-exists? filename)
                  (collect (collect-maximum-generation))))))
          (let ([fd (critical-section
                      ($open-input/output-fd filename perms
                        no-create no-fail no-truncate
                        append lock replace compressed))])
            (when (pair? fd) (open-oops who filename options fd))
            (open-binary-fd-input/output-port who filename fd #t b-mode lock compressed)))))

    (define help-open-file-input/output-port
      (lambda (who filename options perms b-mode maybe-transcoder)
        (let ([bp (open-binary-file-input/output-port who filename options perms b-mode)])
          (if maybe-transcoder
              (transcoded-port bp maybe-transcoder)
              bp))))

    (set-who! open-file-input/output-port
      (rec open-file-input/output-port
        (case-lambda
          [(filename) (open-file-input/output-port filename (file-options))]
          [(filename options) (open-file-input/output-port filename options (buffer-mode block))]
          [(filename options b-mode) (open-file-input/output-port filename options b-mode #f)]
          [(filename options b-mode maybe-transcoder)
           (unless (string? filename) ($oops who "~s is not a string" filename))
           (unless (and (enum-set? options) (enum-set-subset? options $file-options))
             ($oops who "~s is not a file-options object" options))
           (unless (buffer-mode? b-mode) ($oops who "~s is not a valid buffer mode" b-mode))
           (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
             ($oops who "~s is not #f or a transcoder" maybe-transcoder))
           (help-open-file-input/output-port who filename options
             (extract-permission-mask options) b-mode maybe-transcoder)])))

    (set! $open-file-input/output-port
      (rec $open-file-input/output-port
        (case-lambda
          [(who filename) ($open-file-input/output-port who filename (file-options))]
          [(who filename options) ($open-file-input/output-port who filename options (buffer-mode block))]
          [(who filename options b-mode) ($open-file-input/output-port who filename options b-mode #f)]
          [(who filename options b-mode maybe-transcoder)
           (unless (string? filename) ($oops who "~s is not a string" filename))
           (unless (and (enum-set? options) (enum-set-subset? options $file-options))
             ($oops who "~s is not a file-options object" options))
           (unless (buffer-mode? b-mode) ($oops who "~s is not a valid buffer mode" b-mode))
           (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
             ($oops who "~s is not #f or a transcoder" maybe-transcoder))
           (help-open-file-input/output-port who filename options
             (extract-permission-mask options) b-mode maybe-transcoder)])))

    (set-who! open-fd-input/output-port
      (case-lambda
        [(fd)
         (unless (and (fixnum? fd) (fx>= fd 0))
           ($oops who "~s is not a file descriptor" fd))
         (open-binary-fd-input/output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) (buffer-mode block) #f #f)]
        [(fd buffer-mode)
         (unless (and (fixnum? fd) (fx>= fd 0))
           ($oops who "~s is not a file descriptor" fd))
         (unless (buffer-mode? buffer-mode)
           ($oops who "~s is not a buffer mode" buffer-mode))
         (open-binary-fd-input/output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f #f)]
        [(fd buffer-mode maybe-transcoder)
         (unless (and (fixnum? fd) (fx>= fd 0))
           ($oops who "~s is not a file descriptor" fd))
         (unless (buffer-mode? buffer-mode)
           ($oops who "~s is not a buffer mode" buffer-mode))
         (unless (or (not maybe-transcoder) ($transcoder? maybe-transcoder))
           ($oops who "~s is not #f or a transcoder" maybe-transcoder))
         (let ([binary-port
                (open-binary-fd-input/output-port who (format "fd ~s" fd) (make-fd fd) ($fd-regular? fd) buffer-mode #f #f)])
           (if maybe-transcoder
               (transcoded-port binary-port maybe-transcoder)
               binary-port))]))

    ; TODO: standard-input/output-port.  requires paired fds

   ; simple i/o routines here to share helpers
    (let ()
      (define (oiof who s o)
        (unless (string? s) ($oops who "~s is not a string" s))
        (let ([o (if (list? o) o (list o))])
          (let loop ([o o] [ifexists #f] [mode #o666] [xmode #f] [bmode #f])
            (if (null? o)
                (help-open-file-input/output-port who s
                  (enum-set-union
                    (case ifexists
                      [(error) (file-options)]
                      [(truncate) (file-options no-fail)]
                      [(replace) (file-options no-fail no-truncate replace)]
                      [(append) (file-options append no-fail no-truncate)]
                      [else (file-options no-fail no-truncate)])
                    (if (eq? xmode 'exclusive) (file-options exclusive) (file-options)))
                  mode
                  (if (eq? bmode 'unbuffered) (buffer-mode none) (buffer-mode block))
                  (current-transcoder))
                (case (car o)
                  [(error truncate replace append)
                   (check-option who ifexists (car o))
                   (loop (cdr o) (car o) mode xmode bmode)]
                  [(buffered unbuffered)
                   (check-option who bmode (car o))
                   (loop (cdr o) ifexists mode xmode (car o))]
                  [(exclusive nonexclusive)
                   (check-option who xmode (car o))
                   (loop (cdr o) ifexists mode (car o) bmode)]
                  [(mode)
                   (if (null? (cdr o))
                       ($oops who "mode option requires an argument")
                       (let ([mode (cadr o)])
                         (if (and (fixnum? mode) (fx>= mode 0))
                             (loop (cddr o) ifexists mode xmode bmode)
                             ($oops who "mode argument must be a nonnegative fixnum"))))]
                  [else ($oops who "invalid option ~s" (car o))])))))
      (set-who! open-input-output-file
        (case-lambda
          [(s) (oiof who s '())]
          [(s o) (oiof who s o)])))
    )

  ;; make-custom-binary-input/output-port
  (let ()
    (define-syntax make-ready-for-input
      (syntax-rules ()
        [(_ who p_ write!)
         (let ([p p_])
           (unless (eq? 0 (binary-port-output-size p))
             (binary-custom-port-flush who p write!)
             ;; don't set input-size; it is set only after a read
             (set-binary-port-output-size! p 0)))]))

    (module ((make-ready-for-output $make-ready-for-output))
      (define $make-ready-for-output
        (lambda (who p get-position set-position!)
          (unless (eq? (binary-port-input-size p) 0)
            (unless (port-input-empty? p)
              (if (not (and get-position set-position!))
                  (position-warning who
                    (if get-position
                        "cannot set position for write after read on ~s"
                        "cannot determine position for write after read on ~s")
                    p)
                  (set-position! (- (get-position) (binary-port-input-count p)))))
            (set-binary-port-input-size! p 0))
          (set-port-eof! p #f)
          (set-binary-port-output-size! p
            (fx1- (bytevector-length (binary-port-output-buffer p))))))

      (define-syntax make-ready-for-output
        (syntax-rules ()
          [(_ ?who ?p ?get-position ?set-position!)
           (let ([p ?p])
             (when (eq? (binary-port-output-size p) 0)
               ($make-ready-for-output ?who p ?get-position ?set-position!)))])))

    ;; Ports start with a non-ill-defined position.
    ;; Unless get-position and set-position! are provided,
    ;; doing a buffered read operation makes the position ill-defined.
    ;;
    ;; A put, put-some or (textual)port-position operation may give
    ;; unexpected results when the position is ill-defined.
    ;;
    ;; A set-port-position is sufficient to make
    ;; the position no longer ill-defined.
    ;;
    ;; Buffered read operations include lookahead, port-eof?, and unget.
    ;; Buffered read operations also include get and get-some if buffer-mode is not none.

    (set-who! make-custom-binary-input/output-port
      (lambda (id read! write! get-position set-position! close)
        (unless (string? id) ($oops who "~s is not a string" id))
        (unless (procedure? read!) ($oops who "~s is not a procedure" read!))
        (unless (procedure? write!) ($oops who "~s is not a procedure" write!))
        (unless (or (not get-position) (procedure? get-position))
          ($oops who "~s is not a procedure or #f" get-position))
        (unless (or (not set-position!) (procedure? set-position!))
          ($oops who "~s is not a procedure or #f" set-position!))
        (unless (or (not close) (procedure? close))
          ($oops who "~s is not a procedure or #f" close))
        (let ([handler
               (make-port-handler
                 [ready?
                  (lambda (who p)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (or (not (port-input-empty? p))
                        (port-flag-eof-set? p)
                        (read-oops who p "cannot determine ready status")))]
                 [lookahead
                  (lambda (who p)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (binary-custom-port-lookahead who p read!))]
                 [unget
                  (lambda (who p x)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (binary-custom-port-unget who p x))]
                 [get
                  (lambda (who p)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (binary-custom-port-get who p read!))]
                 [get-some
                  (lambda (who p bv start count)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (binary-custom-port-get-some who p read! bv start count))]
                 [clear-input
                  (lambda (who p)
                    (assert-not-closed who p)
                    (binary-custom-port-clear-input who p))]
                 [put
                  (lambda (who p x)
                    (assert-not-closed who p)
                    (make-ready-for-output who p get-position set-position!)
                    (binary-custom-port-put who p write! x))]
                 [put-some
                  (lambda (who p bv start count)
                    (assert-not-closed who p)
                    (make-ready-for-output who p get-position set-position!)
                    (binary-custom-port-put-some who p write! bv start count))]
                 [flush
                  (lambda (who p)
                    (assert-not-closed who p)
                   ; binary-custom-port-flush must be a no-op in input mode
                    (binary-custom-port-flush who p write!))]
                 [clear-output
                  (lambda (who p)
                    (assert-not-closed who p)
                    (binary-custom-port-clear-output who p))]
                 [close-port
                  (lambda (who p)
                    (unless (port-closed? p)
                     ; binary-custom-port-flush must be a no-op in input mode
                      (binary-custom-port-flush who p write!)
                      (binary-custom-port-close-port who p close)))]
                 [port-position
                  (and get-position
                    (lambda (who p)
                      (assert-not-closed who p)
                      (binary-custom-port-port-position in/out who p get-position)))]
                 [set-port-position!
                  (and set-position!
                    (lambda (who p x)
                      (unless (or (and (fixnum? x) (fx>= x 0)) (and (bignum? x) (>= x 0)))
                        ($oops who "~s is not a valid position" x))
                      (assert-not-closed who p)
                      (binary-custom-port-flush who p write!)
                      (set-binary-port-input-size! p 0) ;; junk the buffer data
                      (set-port-eof! p #f)
                      (set-position! x)))]
                 [port-length #f]
                 [set-port-length! #f]
                 [port-nonblocking? #f]
                 [set-port-nonblocking! #f])])
          (let ([bufsiz (custom-port-buffer-size)])
            (let ([p ($make-binary-input/output-port id handler
                       (make-bytevector bufsiz)
                       (make-bytevector bufsiz)
                       #f)])
              ($set-port-flags! p (constant port-flag-block-buffered))
              (set-binary-port-input-size! p 0)
              (set-binary-port-output-size! p (fx1- bufsiz)) ;; leave room for put to work
              p))))))

  ;; make-custom-textual-input/output-port
  (let ()
    (define-syntax make-ready-for-input
      (syntax-rules ()
        [(_ who p_ write!)
         (let ([p p_])
           (unless (eq? 0 (textual-port-output-size p))
             (textual-custom-port-flush who p write!)
             ;; don't set input-size; it is set only after a read
             (set-textual-port-output-size! p 0)))]))

    (module ((make-ready-for-output $make-ready-for-output))
      (define $make-ready-for-output
        (lambda (who p get-position set-position!)
          (unless (eq? (textual-port-input-size p) 0)
            (unless (port-input-empty? p)
              (position-warning who "cannot set position for write after read on ~s" p))
            (set-textual-port-input-size! p 0))
          (set-port-eof! p #f)
          (set-textual-port-output-size! p
            (fx1- (string-length (textual-port-output-buffer p))))))

      (define-syntax make-ready-for-output
        (syntax-rules ()
          [(_ ?who ?p ?get-position ?set-position!)
           (let ([p ?p])
             (when (eq? (textual-port-output-size p) 0)
               ($make-ready-for-output ?who p ?get-position ?set-position!)))])))

    ;; Ports start with a non-ill-defined position.
    ;; Unless get-position and set-position! are provided,
    ;; doing a buffered read operation makes the position ill-defined.
    ;;
    ;; A put, put-some or (textual)port-position operation may give
    ;; unexpected results when the position is ill-defined.
    ;;
    ;; A set-port-position is sufficient to make
    ;; the position no longer ill-defined.
    ;;
    ;; Buffered read operations include lookahead, port-eof?, and unget.
    ;; Buffered read operations also include get and get-some if buffer-mode is not none.

    (set-who! make-custom-textual-input/output-port
      (lambda (id read! write! get-position set-position! close)
        (unless (string? id) ($oops who "~s is not a string" id))
        (unless (procedure? read!) ($oops who "~s is not a procedure" read!))
        (unless (procedure? write!) ($oops who "~s is not a procedure" write!))
        (unless (or (not get-position) (procedure? get-position))
          ($oops who "~s is not a procedure or #f" get-position))
        (unless (or (not set-position!) (procedure? set-position!))
          ($oops who "~s is not a procedure or #f" set-position!))
        (unless (or (not close) (procedure? close))
          ($oops who "~s is not a procedure or #f" close))
        (let ([handler
               (make-port-handler
                 [ready?
                  (lambda (who p)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (or (not (port-input-empty? p))
                        (port-flag-eof-set? p)
                        (read-oops who p "cannot determine ready status")))]
                 [lookahead
                  (lambda (who p)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (textual-custom-port-lookahead who p write!))]
                 [unget
                  (lambda (who p x)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (textual-custom-port-unget who p x))]
                 [get
                  (lambda (who p)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (textual-custom-port-get who p read!))]
                 [get-some
                  (lambda (who p str start count)
                    (assert-not-closed who p)
                    (make-ready-for-input who p write!)
                    (textual-custom-port-get-some who p read! str start count))]
                 [clear-input
                  (lambda (who p)
                    (assert-not-closed who p)
                    (textual-custom-port-clear-input who p))]
                 [put
                  (lambda (who p x)
                    (assert-not-closed who p)
                    (make-ready-for-output who p get-position set-position!)
                    (textual-custom-port-put who p write! x))]
                 [put-some
                  (lambda (who p str start count)
                    (assert-not-closed who p)
                    (make-ready-for-output who p get-position set-position!)
                    (textual-custom-port-put-some who p write! str start count))]
                 [flush
                  (lambda (who p)
                    (assert-not-closed who p)
                   ; textual-custom-port-flush must be a no-op in input mode
                    (textual-custom-port-flush who p write!))]
                 [clear-output
                  (lambda (who p)
                    (assert-not-closed who p)
                    (textual-custom-port-clear-output who p))]
                 [close-port
                  (lambda (who p)
                    (unless (port-closed? p)
                     ; textual-custom-port-flush must be a no-op in input mode
                      (textual-custom-port-flush who p write!)
                      (textual-custom-port-close-port who p close)))]
                 [port-position
                  (and get-position
                    (lambda (who p)
                      (assert-not-closed who p)
                      (unless (port-input-empty? p)
                        (position-warning who
                          "cannot determine accurate position after read on ~s"
                          p))
                      (textual-custom-port-flush who p write!)
                      (get-position)))]
                 [set-port-position!
                  (and set-position!
                    (lambda (who p x)
                      (assert-not-closed who p)
                      (textual-custom-port-flush who p write!)
                      (set-textual-port-input-size! p 0) ;; junk the buffer data
                      (set-port-eof! p #f)
                      (set-position! x)))]
                 [port-length #f]
                 [set-port-length! #f]
                 [port-nonblocking? #f]
                 [set-port-nonblocking! #f])])
          (let ([bufsiz (custom-port-buffer-size)])
            (let ([p ($make-textual-input/output-port id handler
                       (make-string bufsiz)
                       (make-string bufsiz)
                       #f)])
              ($set-port-flags! p (constant port-flag-block-buffered))
              ($set-port-flags! p (constant port-flag-bol))
              (set-textual-port-input-size! p 0)
              (set-textual-port-output-size! p (fx1- bufsiz)) ;; leave room for put to work
              p))))))

;;;; 8.3 Simple I/O: (rnrs io simple (6))
  (let ()
    ;; eof-object in 8.2
    ;; eof-object? in 8.2

    ;; call-with-input-file in 8.2 (to share helpers)
    ;; call-with-output-file in 8.2 (to share helpers)

    ;; input-port? in 8.2
    ;; output-port? in 8.2
    ;; current-input-port in 8.2
    ;; current-output-port in 8.2
    ;; current-error-port in 8.2

    ;; with-input-from-file in 8.2 (to share helpers)
    ;; with-output-to-file in 8.2 (to share helpers)

    ;; open-input-file in 8.2 (to share helpers)
    ;; open-output-file in 8.2 (to share helpers)

    (set-who! close-input-port
      (lambda (input-port)
        (unless (input-port? input-port)
          ($oops who "~s is not an input port" input-port))
        (close-port input-port)))

    (set-who! close-output-port
      (lambda (output-port)
        (unless (output-port? output-port)
          ($oops who "~s is not an output port" output-port))
        (close-port output-port)))
    )

  (let ()
    (define ($block-read who p s count)
      (if (fx= count 0)
          (if (port-eof? p) (eof-object) 0)
          (call-port-handler get-some who p s 0 count)))
    (set-who! block-read
      (case-lambda
        [(p s)
         (unless (and (input-port? p) (textual-port? p))
           ($oops who "~s is not a textual input port" p))
         (unless (string? s)
           ($oops who "invalid buffer argument ~s" s))
         ($block-read who p s (string-length s))]
        [(p s n)
         (unless (and (input-port? p) (textual-port? p))
           ($oops who "~s is not a textual input port" p))
         (unless (string? s) ($oops who "invalid buffer argument ~s" s))
         (unless (and (fixnum? n) (fx<= 0 n (string-length s)))
           ($oops who "invalid count argument ~s" n))
         ($block-read who p s n)])))

  (let ()
    (define ($block-write who p s count)
      (let loop ([i 0] [count count])
        (unless (fx= count 0)
          (let ([n (call-port-handler put-some who p s i count)])
            (loop (fx+ i n) (fx- count n)))))
      (call-port-handler flush who p))
    (set-who! block-write
      (case-lambda
        [(p s)
         (unless (and (output-port? p) (textual-port? p))
           ($oops who "~s is not a textual output port" p))
         (unless (string? s) ($oops who "invalid buffer argument ~s" s))
         ($block-write who p s (string-length s))]
        [(p s n)
         (unless (and (output-port? p) (textual-port? p))
           ($oops who "~s is not a textual output port" p))
         (unless (string? s) ($oops who "invalid buffer argument ~s" s))
         (unless (and (fixnum? n) (fx<= 0 n (string-length s)))
           ($oops who "invalid count argument ~s" n))
         ($block-write who p s n)])))

  (let ()
    (define ($char-ready? input-port who)
      (or (not (port-input-empty? input-port))
          (port-flag-eof-set? input-port)
          (call-port-handler ready? who input-port)))
    (set-who! char-ready?
      (case-lambda
        [() ($char-ready? (current-input-port) who)]
        [(input-port)
         (unless (and (input-port? input-port) (textual-port? input-port))
           ($oops who "~s is not a textual input port" input-port))
         ($char-ready? input-port who)])))

  (set-who! clear-input-port
    (rec clear-input-port
      (case-lambda
        [() (let ([p (current-input-port)])
              (call-port-handler clear-input who p))]
        [(p)
         (unless (input-port? p)
           ($oops who "~s is not an input port" p))
         (call-port-handler clear-input who p)])))

  (set-who! clear-output-port
    (rec clear-output-port
      (case-lambda
        [() (let ([p (current-output-port)])
              (call-port-handler clear-output who p))]
        [(p)
         (unless (output-port? p)
           ($oops who "~s is not an output port" p))
         (call-port-handler clear-output who p)])))

  (set-who! fresh-line
    (rec fresh-line
      (case-lambda
        [() (fresh-line (current-output-port))]
        [(p)
         (unless (and (output-port? p) (textual-port? p))
           ($oops who "~s is not a textual output port" p))
         (assert-not-closed who p)
         (unless ($textual-port-bol? p)
           (call-port-handler put who p #\newline))])))

  (set-who! port-bol?
    (lambda (p)
      (unless (and (output-port? p) (textual-port? p))
        ($oops who "~s is not a textual output port" p))
      (assert-not-closed who p)
      ($textual-port-bol? p)))

  (let ()
    (define (binary-fd-port? bp)
      ($port-flags-set? bp (constant port-flag-file)))

    (set-who! file-port?
      (lambda (p)
        (unless (port? p) ($oops who "~s is not a port" p))
        (if (binary-port? p)
            (binary-fd-port? p)
            (let ([info ($port-info p)])
              (and (codec-info? info) (binary-fd-port? (codec-info-bp info)))))))

    (set-who! port-file-descriptor
      (let ()
        (define gzfile-fd (foreign-procedure "(cs)gzxfile_fd" (ptr) int))
        (define (binary-port-fd p bp)
          (unless (binary-fd-port? bp)
            ($oops who "~s is not a file port" p))
          (let ([x ($port-info bp)])
            (if (port-gz-mode bp)
                (gzfile-fd x)
                x)))
        (lambda (p)
          (unless (port? p) ($oops who "~s is not a port" p))
          (if (binary-port? p)
              (binary-port-fd p p)
              (let ([info ($port-info p)])
                (unless (codec-info? info)
                  ($oops who "~s is not a file port" p))
                (binary-port-fd p (codec-info-bp info))))))))

  (let ()
    (define $generic-port-handler
      (make-port-handler
        [ready?
         (lambda (who p)
           (assert-not-closed who p)
           (and (($port-info p) 'char-ready? p) #t))]
        [lookahead
         (lambda (who p)
           (assert-not-closed who p)
           (let ([c (($port-info p) 'peek-char p)])
             (unless (or (char? c) (eof-object? c))
               ($oops 'generic-port-handler "invalid peek-char return value ~s" c))
             c))]
        [unget
         (lambda (who p x)
           (assert-not-closed who p)
           (unless (eof-object? x) (($port-info p) 'unread-char x p))
           (void))]
        [get
         (lambda (who p)
           (assert-not-closed who p)
           (let ([c (($port-info p) 'read-char p)])
             (unless (or (char? c) (eof-object? c))
               ($oops 'generic-port-handler "invalid read-char return value ~s" c))
             c))]
        [get-some
         (lambda (who p st start count)
           (if (= start 0)
               (let ([n (($port-info p) 'block-read p st count)])
                 (unless (or (and (fixnum? n) (not ($fxu< count n)))
                             (eof-object? n))
                   ($oops 'generic-port-handler "invalid block-read return value ~s on ~s" n p))
                 n)
               (let ([tmp (make-string count)])
                 (let ([n (($port-info p) 'block-read p tmp count)])
                   (cond
                     [(and (fixnum? n) (not ($fxu< count n)))
                      (string-copy! tmp 0 st start n)
                      n]
                     [(eof-object? n) n]
                     [else ($oops 'generic-port-handler "invalid block-read return value ~s on ~s" n p)])))))]
        [clear-input
         (lambda (who p)
           (assert-not-closed who p)
           (($port-info p) 'clear-input-port p)
           (void))]
        [put
         (lambda (who p x)
           (assert-not-closed who p)
           (($port-info p) 'write-char x p)
           (void))]
        [put-some
         (lambda (who p st start count)
           (assert-not-closed who p)
           (if (= start 0)
               (($port-info p) 'block-write p st count)
               (let ([tmp (make-string count)])
                 (string-copy! st start tmp 0 count)
                 (($port-info p) 'block-write p tmp count)))
           count)]
        [flush
         (lambda (who p)
           (assert-not-closed who p)
           (($port-info p) 'flush-output-port p)
           (void))]
        [clear-output
         (lambda (who p)
           (assert-not-closed who p)
           (($port-info p) 'clear-output-port p)
           (void))]
        [close-port
         (lambda (who p)
           (unless (port-closed? p)
             (($port-info p) 'close-port p))
           (void))]
        [port-position
         (lambda (who p)
           (assert-not-closed who p)
           (($port-info p) 'file-position p))]
        [set-port-position!
         (lambda (who p x)
           (assert-not-closed who p)
           (($port-info p) 'file-position p x))]
        [port-length
         (lambda (who p)
           (assert-not-closed who p)
           (($port-info p) 'file-length p))]
        [set-port-length!
         (lambda (who p pos)
           (assert-not-closed who p)
           (($port-info p) 'truncate-file p pos))]
        [port-nonblocking? #f]
        [set-port-nonblocking! #f]))

    (define (set-name p)
      (guard (c [#t (void)])
        (let ([name (($port-info p) 'port-name p)])
          (when (string? name) (set-port-name! p name))))
      p)

    (set-who! make-input-port
      (lambda (handler buffer)
        (unless (procedure? handler)
          (if (and (fixnum? handler) (fx>= handler 0))
              ($oops who "fixnum handler no longer supported; use open-fd-input-port")
              ($oops who "~s is not a procedure" handler)))
        (unless (string? buffer) ($oops who "~s is not a string" buffer))
        (set-name
          ($make-textual-input-port "generic"
            $generic-port-handler
            buffer handler))))

    (set-who! make-output-port
      (lambda (handler buffer)
        (unless (procedure? handler)
          (if (and (fixnum? handler) (fx>= handler 0))
              ($oops who "fixnum handler no longer supported; use open-fd-input-port")
              ($oops who "~s is not a procedure" handler)))
        (unless (string? buffer) ($oops who "~s is not a string" buffer))
        (set-name
          ($make-textual-output-port "generic"
            $generic-port-handler
            buffer handler))))

    (set-who! make-input/output-port
      (lambda (handler ibuffer obuffer)
        (unless (procedure? handler)
          (if (and (fixnum? handler) (fx>= handler 0))
              ($oops who "fixnum handler no longer supported; use open-fd-input-port")
              ($oops who "~s is not a procedure" handler)))
        (unless (string? ibuffer) ($oops who "~s is not a string" ibuffer))
        (unless (string? obuffer) ($oops who "~s is not a string" obuffer))
        (set-name
          ($make-textual-input/output-port "generic"
            $generic-port-handler
            ibuffer obuffer handler))))

    (set-who! port-handler
      (let ()
        (define check
          (lambda (msg n)
            (unless (cond
                      [(assq n
                         '((1 char-ready? clear-input-port clear-output-port close-port
                              file-length file-position flush-output-port peek-char
                              port-name read-char)
                            (2 file-position unread-char write-char)
                            (3 block-read block-write))) =>
                       (lambda (ls) (memq msg (cdr ls)))]
                      [else #f])
              ($oops 'non-generic-port-handler
                "cannot handle message ~s with argument count ~s"
                msg n))))
        (define non-generic-port-handler
          (lambda (msg . args)
            (check msg (length args))
            (apply ($top-level-value msg) args)))
        (lambda (p)
          (unless (port? p) ($oops who "~s is not a port" p))
          (if (eq? ($port-handler p) $generic-port-handler)
              ($port-info p)
              non-generic-port-handler))))
  )

  (record-writer (type-descriptor codec)
    (lambda (x p wr)
      (fprintf p "#<codec ~a>" (codec-name x))))

  (record-writer (type-descriptor transcoder)
    (lambda (x p wr)
      (fprintf p "#<transcoder ~a ~s ~s>"
        (codec-name ($transcoder-codec x))
        ($transcoder-eol-style x)
        ($transcoder-error-handling-mode x))))

  (set-who! #(r6rs: current-input-port)
    (lambda ()
      (#2%current-input-port)))

  (set-who! #(r6rs: current-output-port)
    (lambda ()
      (#2%current-output-port)))

  (set-who! #(r6rs: current-error-port)
    (lambda ()
      (#2%current-error-port)))

 ; thread-safe transcript-on, transcript-off, transcript-cafe
  (let ()
    (define-record-type xscript-info
      (nongenerative)
      (opaque #t)
      (sealed #t)
      (fields ip op xp (mutable ungot))
      (protocol
        (lambda (new)
          (lambda (ip op xp)
            (new ip op xp '())))))

    (module (make-xscript-port xscript-port? constituent-ports)
      (define-syntax with-xscript-info
        (syntax-rules ()
          [(_ (p ip op xp ungot) e1 e2 ...)
           (andmap identifier? #'(ip op xp ungot))
           (let ([x ($port-info p)])
             (let ([ip (xscript-info-ip x)]
                   [op (xscript-info-op x)]
                   [xp (xscript-info-xp x)])
               (define-syntax ungot
                 (identifier-syntax
                   [id (xscript-info-ungot x)]
                   [(set! id e) (xscript-info-ungot-set! x e)]))
               e1 e2 ...))]))

      (define-syntax thread-safe
        (syntax-rules ()
          [(_ (p ip op xp ungot) e1 e2 ...)
           (with-xscript-info (p ip op xp ungot)
             (with-tc-mutex e1 e2 ...))]))

      (define-syntax call-xp-handler
        (syntax-rules ()
          [(_ msg who xp arg ...)
           (identifier? #'xp)
           (and (not (port-closed? xp))
                (call-port-handler msg who xp arg ...))]))

      (define slurp-input
        (lambda (who p)
          (with-xscript-info (p ip op xp ungot)
            (let ([tognu (reverse ungot)])
              (guard (c [#t (void)]) ; guard ready? calls
                (let loop ()
                  (when (call-port-handler ready? who ip)
                    (let ([c (call-port-handler get who ip)])
                      (unless (eof-object? c)
                        (call-xp-handler put who xp c)
                        (set! tognu (cons c tognu))
                        (loop))))))
              (set! ungot (reverse tognu))))))

     ; similar in structure to thread-safe console-port handler
      (define xscript-handler
        (make-port-handler
          [ready?
           (lambda (who p)
             (thread-safe (p ip op xp ungot)
               (or (not (null? ungot))
                   (begin
                     (call-port-handler flush who op)
                     (call-port-handler ready? who ip)))))]
          [lookahead
           (lambda (who p)
             (thread-safe (p ip op xp ungot)
               (if (not (null? ungot))
                   (car ungot)
                   (begin
                     (call-port-handler flush who op)
                     (let ([c (call-port-handler get who ip)])
                       (set! ungot (list c))
                       (unless (eof-object? c) (call-xp-handler put who xp c))
                       c)))))]
          [unget
           (lambda (who p x)
             (thread-safe (p ip op xp ungot)
               (set! ungot (cons x ungot))))]
          [get
           (lambda (who p)
             (thread-safe (p ip op xp ungot)
               (if (not (null? ungot))
                   (let ([c (car ungot)])
                     (set! ungot (cdr ungot))
                     c)
                   (begin
                     (call-port-handler flush who op)
                     (let ([c (call-port-handler get who ip)])
                       (unless (eof-object? c) (call-xp-handler put who xp c))
                       c)))))]
          [get-some
           (lambda (who p str start count)
             (thread-safe (p ip op xp ungot)
               (if (and (fx> count 0) (not (null? ungot)))
                   (let ([c (car ungot)])
                     (set! ungot (cdr ungot))
                     (if (eof-object? c)
                         c
                         (begin (string-set! str start c) 1)))
                   (begin
                     (call-port-handler flush who op)
                     (let ([count (call-port-handler get-some who ip str start count)])
                       (unless (or (eof-object? count) (fx= count 0))
                         (call-xp-handler put-some who xp str start count))
                       count)))))]
          [clear-input
           (lambda (who p)
             (thread-safe (p ip op xp ungot)
               (set! ungot '())
               (call-port-handler clear-input who ip)))]
          [put
           (lambda (who p x)
             (thread-safe (p ip op xp ungot)
               (slurp-input who p)
               (call-port-handler put who op x)
               (call-xp-handler put who xp x)
               (if ($textual-port-bol? op)
                   ($set-port-flags! p (constant port-flag-bol))
                   ($reset-port-flags! p (constant port-flag-bol)))))]
          [put-some
           (lambda (who p str start count)
             (thread-safe (p ip op xp ungot)
               (slurp-input who p)
               (let ([count (call-port-handler put-some who op str start count)])
                 (let f ([start start] [count count])
                   (unless (fx= count 0)
                     (let ([n (call-xp-handler put-some who xp str start count)])
                       (and n (f (fx+ start n) (fx- count n))))))
                 (if ($textual-port-bol? op)
                     ($set-port-flags! p (constant port-flag-bol))
                     ($reset-port-flags! p (constant port-flag-bol)))
                 count)))]
          [flush
           (lambda (who p)
             (thread-safe (p ip op xp ungot)
               (call-port-handler flush who op)
               (call-xp-handler flush who xp)))]
          [clear-output
           (lambda (who p)
            ; clearing may put op and xp out of sync, so just flush instead
             (thread-safe (p ip op xp ungot)
               (call-port-handler flush who op)
               (call-xp-handler flush who xp)))]
          [close-port
           (lambda (who p)
            ; refuse to close transcript ports, like console ports---just flush instead
             (thread-safe (p ip op xp ungot)
               (call-port-handler flush who op)
               (call-xp-handler flush who xp)))]
          [port-position #f]
          [set-port-position! #f]
          [port-length #f]
          [set-port-length! #f]
          [port-nonblocking? #f]
          [set-port-nonblocking! #f]))

      (define (make-xscript-port ip op xp)
        (let ([p ($make-textual-input/output-port
                   "transcript" xscript-handler "" ""
                   (make-xscript-info ip op xp))])
          (when ($port-flags-set? ip (constant port-flag-r6rs))
            ($set-port-flags! p (constant port-flag-r6rs)))
          (when ($port-flags-set? ip (constant port-flag-fold-case))
            ($set-port-flags! p (constant port-flag-fold-case)))
          (when ($port-flags-set? ip (constant port-flag-no-fold-case))
            ($set-port-flags! p (constant port-flag-no-fold-case)))
          (when ($textual-port-bol? op)
            ($set-port-flags! p (constant port-flag-bol)))
          p))

      (define xscript-port?
        (lambda (p)
          (eq? ($port-handler p) xscript-handler)))

      (define constituent-ports
        (lambda (p)
          (with-xscript-info (p ip op xp ungot)
            (values ip op xp)))))

    (set-who! $xscript-port? (lambda (p) (xscript-port? p)))

    (set-who! $constituent-ports (lambda (p) (constituent-ports p)))

    (set-who! transcript-on
      (lambda (pathname)
        (unless (string? pathname) ($oops who "~s is not a string" pathname))
        (let ([ip (console-input-port)] [op (console-output-port)])
          (when (and (guard (c [#t #f]) (char-ready? ip))
                     (eqv? (peek-char ip) #\newline))
            (read-char ip))
          (let ([xp ($open-file-output-port who pathname (file-options replace)
                      (buffer-mode block)
                      (current-transcoder))])
            (let ([p (make-xscript-port ip op xp)])
              (when (eq? (console-error-port) op) (console-error-port p))
              (when (eq? (current-input-port) ip) (current-input-port p))
              (when (eq? (current-output-port) op) (current-output-port p))
              (when (eq? (current-error-port) op) (current-error-port p))
              (when (eq? (trace-output-port) op) (trace-output-port p))
              (console-input-port p)
              (console-output-port p)))
          (printf "Chez Scheme Transcript [~a]\n" (date-and-time)))))

    (set-who! transcript-off
      (lambda ()
        (cond
          [(ormap (lambda (p) (and (xscript-port? p) p))
             (list (console-input-port)
                   (console-output-port)
                   (console-error-port)
                   (current-input-port)
                   (current-output-port)
                   (current-error-port)
                   (trace-output-port))) =>
           (lambda (p)
             (let-values ([(ip op xp) (constituent-ports p)])
               (when (eq? (console-input-port) p) (console-input-port ip))
               (when (eq? (console-output-port) p) (console-output-port op))
               (when (eq? (console-error-port) p) (console-error-port op))
               (when (eq? (current-input-port) p) (current-input-port ip))
               (when (eq? (current-output-port) p) (current-output-port op))
               (when (eq? (current-error-port) p) (current-error-port op))
               (when (eq? (trace-output-port) p) (trace-output-port op))
               (flush-output-port p)
               (close-port xp)))])))

    (set-who! transcript-cafe
      (lambda (pathname)
        (unless (string? pathname) ($oops who "~s is not a string" pathname))
        (let ([ip (console-input-port)] [op (console-output-port)])
          (when (and (guard (c [#t #f]) (char-ready? (console-input-port)))
                     (eqv? (peek-char (console-input-port)) #\newline))
            (read-char (console-input-port)))
          (let ([xp ($open-file-output-port who pathname (file-options replace)
                      (buffer-mode block)
                      (current-transcoder))])
            (let ([p (make-xscript-port ip op xp)])
              (with-values
                (dynamic-wind
                  (lambda ()
                    (when (eq? (console-input-port) ip) (console-input-port p))
                    (when (eq? (console-output-port) op) (console-output-port p))
                    (when (eq? (console-error-port) op) (console-error-port p))
                    (when (eq? (current-input-port) ip) (current-input-port p))
                    (when (eq? (current-output-port) op) (current-output-port p))
                    (when (eq? (current-error-port) op) (current-error-port p))
                    (when (eq? (trace-output-port) op) (trace-output-port p)))
                  (lambda ()
                    (printf "Chez Scheme Transcript [~a]\n" (date-and-time))
                    (new-cafe))
                  (lambda ()
                    (when (eq? (console-input-port) p) (console-input-port ip))
                    (when (eq? (console-output-port) p) (console-output-port op))
                    (when (eq? (console-error-port) p) (console-error-port op))
                    (when (eq? (current-input-port) p) (current-input-port ip))
                    (when (eq? (current-output-port) p) (current-output-port op))
                    (when (eq? (current-error-port) p) (current-error-port op))
                    (when (eq? (trace-output-port) p) (trace-output-port op))
                    (flush-output-port p)))
                (lambda vals
                  (close-port xp)
                  (apply values vals)))))))))

  #;(let ()
    (define debug-port-handler
      (make-port-handler
        [ready? (lambda (who p) (input-port-ready? ($port-info p)))]
        [lookahead
         (lambda (who p)
           (let ([b (lookahead-u8 ($port-info p))])
             (if (eof-object? b) b (integer->char b))))]
        [unget
         (lambda (who p x)
           (unget-u8 ($port-info p) (if (eof-object? x) x (char->integer x))))]
        [get
         (lambda (who p)
           (let ([b (get-u8 ($port-info p))])
             (if (eof-object? b) b (integer->char b))))]
        [get-some
         (lambda (who p str start count)
           (if (fx= count 0)
               0
               (let ([b (get-u8 ($port-info p))])
                 (if (eof-object? b)
                     b
                     (begin
                       (string-set! str start (integer->char b))
                       1)))))]
        [clear-input
         (lambda (who p)
           (clear-input-port ($port-info p)))]
        [put
         (lambda (who p x)
           (put-u8 ($port-info p) (char->integer x)))]
        [put-some
         (lambda (who p str start count)
           (if (fx= count 0)
               0
               (begin
                 (put-u8 ($port-info p) (char->integer (string-ref str start)))
                 1)))]
        [flush
         (lambda (who p)
           (flush-output-port ($port-info p)))]
        [clear-output
         (lambda (who p)
           (clear-output-port ($port-info p)))]
        [close-port (lambda (who p) (flush-output-port ($port-info p)) (void))]
        [port-position
         (lambda (who p)
           (port-position ($port-info p)))]
        [set-port-position!
         (lambda (who p x)
           (set-port-position! ($port-info p) x))]
        [port-length
         (lambda (who p)
           (port-length ($port-info p)))]
        [set-port-length!
         (lambda (who p x)
           (set-port-length! ($port-info p) x))]
        [port-nonblocking? #f]
        [set-port-nonblocking! #f]))
    (set! $console-input-port ($make-textual-input-port "debug-stdin" debug-port-handler "" (standard-input-port (buffer-mode block))))
    (set! $console-output-port ($make-textual-output-port "debug-stdout" debug-port-handler "" (standard-output-port (buffer-mode none))))
    (set! $console-output-port ($make-textual-output-port "debug-stderr" debug-port-handler "" (standard-error-port (buffer-mode none)))))

  (let ([ip (standard-input-port (buffer-mode block) (current-transcoder))]
        [op (standard-output-port (buffer-mode line) (current-transcoder))])
    (define same-device? (foreign-procedure "(cs)same_devicep" (int int) boolean))
    (if-feature pthreads
      (let ()
       ; it would be nice to make port->thread-safe-port available generally,
       ; but since it grabs the tc mutex, making it public would be
       ; inappropriate.  tried using a fresh mutex, but the thread mat
       ; that runs compile-file freezes, possibly due to a deadlock where one
       ; thread has the tc mutex and another has the port's mutex.  should
       ; revisit...
        (define (make-thread-safe-handler ip op)
          (make-port-handler
            [ready?
             (and ip
               (lambda (who p)
                 (with-tc-mutex
                   (call-port-handler flush who op)
                   (call-port-handler ready? who ip))))]
            [lookahead
             (and ip
               (lambda (who p)
                 (with-tc-mutex
                   (call-port-handler flush who op)
                   (call-port-handler lookahead who ip))))]
            [unget
             (and ip
               (lambda (who p x)
                 (with-tc-mutex
                   (call-port-handler unget who ip x))))]
            [get
             (and ip
               (lambda (who p)
                 (with-tc-mutex
                   (call-port-handler flush who op)
                   (call-port-handler get who ip))))]
            [get-some
             (and ip
               (lambda (who p str start count)
                 (with-tc-mutex
                   (call-port-handler flush who op)
                   (call-port-handler get-some who ip str start count))))]
            [clear-input
             (and ip
               (lambda (who p)
                 (with-tc-mutex
                   (call-port-handler clear-input who ip))))]
            [put
             (and op
               (lambda (who p x)
                 (with-tc-mutex
                   (call-port-handler put who op x)
                   (if ($textual-port-bol? op)
                       ($set-port-flags! p (constant port-flag-bol))
                       ($reset-port-flags! p (constant port-flag-bol))))))]
            [put-some
             (and op
               (lambda (who p str start count)
                 (with-tc-mutex
                   (let ([count (call-port-handler put-some who op str start count)])
                     (if ($textual-port-bol? op)
                         ($set-port-flags! p (constant port-flag-bol))
                         ($reset-port-flags! p (constant port-flag-bol)))
                     count))))]
            [flush
             (and op
               (lambda (who p)
                 (with-tc-mutex
                   (call-port-handler flush who op))))]
            [clear-output
             (and op
               (lambda (who p)
                 (with-tc-mutex
                   (call-port-handler clear-output who op))))]
            [close-port ; refuse to close console ports---just flush instead
             (if op
                 (lambda (who p)
                   (with-tc-mutex
                     (call-port-handler flush who op)))
                 (lambda (who p)
                   (void)))]
            [port-position #f]
            [set-port-position! #f]
            [port-length #f]
            [set-port-length! #f]
            [port-nonblocking? #f]
            [set-port-nonblocking! #f]))
        (define thread-safe-console-input/output-port
          (lambda (name ip op)
            (let ([p ($make-textual-input/output-port name (make-thread-safe-handler ip op) "" "" #f)])
              (when ($port-flags-set? ip (constant port-flag-r6rs))
                ($set-port-flags! p (constant port-flag-r6rs)))
              (when ($port-flags-set? ip (constant port-flag-fold-case))
                ($set-port-flags! p (constant port-flag-fold-case)))
              (when ($port-flags-set? ip (constant port-flag-no-fold-case))
                ($set-port-flags! p (constant port-flag-no-fold-case)))
              (when ($textual-port-bol? op)
                ($set-port-flags! p (constant port-flag-bol)))
              p)))
        (define thread-safe-console-output-port
          (lambda (name op)
            (let ([p ($make-textual-output-port name (make-thread-safe-handler #f op) "" #f)])
              (when ($textual-port-bol? op)
                ($set-port-flags! p (constant port-flag-bol)))
              p)))
        (let ([p (thread-safe-console-input/output-port "stdin/out" ip op)])
          (set! $console-input-port p)
          (set! $console-output-port p)
          (set! $console-error-port
            (if (same-device? 1 2)
                p
                (thread-safe-console-output-port "stderr" (standard-error-port (buffer-mode line) (current-transcoder)))))))
      (begin
        (set! $console-input-port ip)
        (set! $console-output-port op)
        (set! $console-error-port
          (if (same-device? 1 2)
              op
              (standard-error-port (buffer-mode line) (current-transcoder)))))))

  (current-input-port $console-input-port)
  (current-output-port $console-output-port)
  (current-error-port $console-error-port)
  (set-who! console-input-port
    (make-parameter
      $console-input-port
      (lambda (ip)
        (unless (and (input-port? ip) (textual-port? ip))
           ($oops who "~s is not a textual input port" ip))
        ip)))
  (set-who! console-output-port
    (make-parameter
      $console-output-port
      (lambda (op)
        (unless (and (output-port? op) (textual-port? op))
           ($oops who "~s is not a textual output port" op))
        op)))
  (set-who! console-error-port
    (make-parameter
      $console-error-port
      (lambda (op)
        (unless (and (output-port? op) (textual-port? op))
           ($oops who "~s is not a textual output port" op))
        op)))
  (set! $io-init
    (lambda ()
      (clear-open-files)
     ; reregister the console ports
      (register-open-file $console-input-port)
      (register-open-file $console-output-port)
      (unless (eq? $console-error-port $console-output-port)
        (register-open-file $console-error-port))))

  ; utf8->string, etc., are in prims.ss, since they are used by
  ; foreign procedures argument and return values
)
)