;;; io.ms
;;; 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.

(define (native-string->bytevector s)
  (string->bytevector s (native-transcoder)))

; convert uses of custom-port-warning? to warning? if custom-port warnings
; are enabled in io.ss
(define (custom-port-warning? x) #t)

(define prettytest.ss (format "~a/prettytest.ss" *mats-dir*))

(mat port-operations
  (error? (close-port cons))
  ; the following several clauses test various open-file-output-port options
  (let ([p (open-file-output-port "testfile.ss" (file-options no-fail))])
    (and (port? p) (output-port? p) (begin (close-port p) #t)))
  (error? ; file already exists
    (open-file-output-port "testfile.ss"))
  (error? ; file already exists
    (open-file-output-port "testfile.ss" (file-options compressed)))
  (let ([p (open-file-output-port "testfile.ss" (file-options replace))])
    (and (port? p) (output-port? p) (begin (close-port p) #t)))
  (let ([p (open-file-output-port "testfile.ss" (file-options no-fail))])
    (and (port? p) (output-port? p) (begin (close-port p) #t)))
  (let ([p (open-file-output-port "testfile.ss" (file-options no-fail))])
    (put-bytevector p (native-string->bytevector "\"hello"))
    (close-port p)
    (let ([p (open-file-output-port "testfile.ss" (file-options no-fail no-truncate append))])
      (put-bytevector p (native-string->bytevector " there\""))
      (close-port p)
      (let ([p (open-file-input-port "testfile.ss")])
        (and (equal? (get-bytevector-all p) (native-string->bytevector "\"hello there\""))
             (eof-object? (get-u8 p))
             (begin (close-port p)
                    #t)))))
  (let ([p (let loop () (if (file-exists? "testfile.ss")
                            (begin (delete-file "testfile.ss" #f) (loop))
                            (open-file-output-port "testfile.ss")))])
    (for-each (lambda (x)
                (put-bytevector p (native-string->bytevector x))
                (put-bytevector p (native-string->bytevector " ")))
              '("a" "b" "c" "d" "e"))
    (put-bytevector p (native-string->bytevector "\n"))
    (close-port p)
    #t)
  (equal? (let ([p (open-file-input-port "testfile.ss")])
            (let f ([x (get-u8 p)])
              (if (eof-object? x)
                  (begin (close-port p) '())
                  (cons (integer->char x) (f (get-u8 p))))))
          (if (eq? (native-eol-style) 'crlf)
              '(#\a #\space #\b #\space #\c #\space
                #\d #\space #\e #\space #\return #\newline)
              '(#\a #\space #\b #\space #\c #\space
                #\d #\space #\e #\space #\newline)))
  (error? (call-with-port 3 values))
  (error? (call-with-port (current-input-port) 'a))
  (equal? (call-with-values
              (lambda ()
                (call-with-port
                 (open-file-output-port "testfile.ss" (file-options replace))
                 (lambda (p)
                   (for-each (lambda (c) (put-u8 p (char->integer c)))
                             (string->list "a b c d e"))
                   (values 1 2 3))))
            list)
          '(1 2 3))
  (equal? (call-with-port
           (open-file-input-port "testfile.ss")
           (lambda (p)
             (list->string
              (let f ()
                (let ([c (get-u8 p)])
                  (if (eof-object? c)
                      '()
                      (begin (unget-u8 p c)
                             (let ([c (get-u8 p)])
                               (cons (integer->char c) (f))))))))))
          "a b c d e")
  (equal? (call-with-port
           (open-file-input-port "testfile.ss")
           (lambda (p)
             (list->string
              (let f ()
                (let ([c (get-u8 p)])
                  (unget-u8 p c)
                  (if (eof-object? c)
                      (begin
                        (unless (and (eof-object? (lookahead-u8 p))
                                     (port-eof? p)
                                     (eof-object? (get-u8 p)))
                          (errorf #f "unget of eof apparently failed"))
                        '())
                      (let ([c (get-u8 p)])
                        (cons (integer->char c) (f)))))))))
          "a b c d e")
  (andmap (lambda (p)
            (equal? (call-with-port
                     p
                     (lambda (p)
                       (list->string
                        (let f ()
                          (let ([c (lookahead-u8 p)])
                            (if (eof-object? c)
                                '()
                                (let ([c (get-u8 p)])
                                  (cons (integer->char c) (f)))))))))
                    "a b c d e"))
          (list (open-file-input-port "testfile.ss")
                (open-bytevector-input-port '#vu8(97 32 98 32 99 32 100 32 101))
                (open-bytevector-input-port (bytevector->immutable-bytevector '#vu8(97 32 98 32 99 32 100 32 101)))))
  ; test various errors related to input ports
  (begin (set! ip (open-file-input-port "testfile.ss"))
         (and (port? ip) (input-port? ip)))
  (error? ; unget can only follow get
    (unget-u8 ip 40))
  (eqv? (get-u8 ip) (char->integer #\a))
  (begin (unget-u8 ip (char->integer #\a)) (eqv? (get-u8 ip) (char->integer #\a)))
  (error? (put-u8 ip (char->integer #\a)))
  (error? (put-bytevector ip #vu8()))
  (error? (flush-output-port ip))
  (begin (close-port ip) #t)
  (begin (close-port ip) #t)
  (error? (port-eof? ip))
  (error? (input-port-ready? ip))
  (error? (get-u8? ip))
  (error? (lookahead-u8? ip))
  (error? (unget-u8? ip))
  (error? (get-bytevector-n ip 1))
  (error? (get-bytevector-n! ip (make-bytevector 10) 0 10))
  (error? (get-bytevector-some ip))
  (error? (get-bytevector-all ip))
  ; test various errors related to output ports
  (begin (set! op (open-file-output-port "testfile.ss" (file-options replace)))
         (and (port? op) (output-port? op)))
  (error? (input-port-ready? op))
  (error? (lookahead-u8 op))
  (error? (get-u8 op))
  (error? (unget-u8 op 40))
  (error? (get-bytevector-n op 1))
  (error? (get-bytevector-n! op (make-bytevector 10) 0 10))
  (error? (get-bytevector-some op))
  (error? (get-bytevector-all op))
  (begin (close-port op) #t)
  (begin (close-port op) #t)
  (error? (put-u8 op (char->integer #\a)))
  (error? (put-bytevector op #vu8(1)))
  (error? (flush-output-port op))

  (let ([s (native-string->bytevector "hi there, mom!")])
    (let ([ip (open-bytevector-input-port s)])
      (let-values ([(op op-ex) (open-bytevector-output-port)])
        (do ([c (get-u8 ip) (get-u8 ip)])
            ((eof-object? c)
             (equal? (op-ex) s))
             (unget-u8 ip c)
             (put-u8 op (get-u8 ip))))))

  (error? (eof-object #!eof))
  (eq? (call-with-port (open-bytevector-input-port #vu8()) get-u8) #!eof)
  (eq? (call-with-port (open-bytevector-input-port #vu8()) get-u8) (eof-object))
  (eq? (eof-object) #!eof)
  (let ([s (native-string->bytevector "hi there, mom!")])
    (equal?
      (call-with-port (open-bytevector-input-port s)
        (lambda (i)
          (call-with-bytevector-output-port
            (lambda (o)
              (do ([c (get-u8 i) (get-u8 i)])
                  ((eof-object? c))
                (unget-u8 i c)
                (put-u8 o (get-u8 i)))))))
      s))

  ; the following makes sure that call-with-port closes the at least on
  ; systems which restrict the number of open ports to less than 2048
  (let ([filename "testfile.ss"])
    (let loop ((i 2048))
      (or (zero? i)
          (begin
            (call-with-port
             (open-file-output-port filename (file-options replace))
             (lambda (p) (put-u8 p (quotient i 256)) (put-u8 p (modulo i 256))))
            (and (eq? (call-with-port
                       (open-file-input-port filename)
                       (lambda (p)
                         (let* ([hi (get-u8 p)]
                                [lo (get-u8 p)])
                           (+ (* 256 hi) lo))))
                      i)
                 (loop (- i 1)))))))
  (begin
    (close-input-port #%$console-input-port)
    (not (port-closed? #%$console-input-port)))
  (begin
    (close-output-port #%$console-output-port)
    (not (port-closed? #%$console-output-port)))
 )

(mat port-operations1
  (error? ; incorrect number of arguments
    (open-file-input-port))
  (error? ; furball is not a string
    (open-file-input-port 'furball))
  (error? ; not a file-options object
    (open-file-input-port "testfile.ss" '()))
  (error? ; not a valid buffer mode
    (open-file-input-port "testfile.ss" (file-options) 17))
  (error? ; not a transcoder
    (open-file-input-port "testfile.ss" (file-options) (buffer-mode block) 'wow))
  (error? ; incorrect number of arguments
    (open-file-input-port "testfile.ss" (file-options) (buffer-mode block) #f 'now?))
  (error? ; cannot open
    (open-file-input-port "/probably/not/a/good/path"))
  (error? ; cannot open
    (open-file-input-port "/probably/not/a/good/path" (file-options compressed)))
  (error? ; invalid options
    (open-file-input-port "testfile.ss" (file-options uncompressed)))
  (error? ; invalid options
    (open-file-input-port "testfile.ss" (file-options truncate)))
  (error? ; incorrect number of arguments
    (open-file-output-port))
  (error? ; furball is not a string
    (open-file-output-port 'furball))
  (error? ; not a file-options object
    (open-file-output-port "testfile.ss" '(no-create)))
  (error? ; not a valid buffer mode
    (open-file-output-port "testfile.ss" (file-options) 17))
  (error? ; not a transcoder
    (open-file-output-port "testfile.ss" (file-options) (buffer-mode block) 'wow))
  (error? ; incorrect number of arguments
    (open-file-output-port "testfile.ss" (file-options) (buffer-mode block) #f 'now?))
  (error? ; cannot open
    (open-file-output-port "/probably/not/a/good/path"))
  (error? ; invalid options
    (open-file-output-port "testfile.ss" (file-options uncompressed)))
  (error? ; invalid options
    (open-file-output-port "testfile.ss" (file-options truncate)))
  (error? ; incorrect number of arguments
    (open-file-input/output-port))
  (error? ; furball is not a string
    (open-file-input/output-port 'furball))
  (error? ; not a file-options object
    (open-file-input/output-port "testfile.ss" '(no-create)))
  (error? ; not a valid buffer mode
    (open-file-input/output-port "testfile.ss" (file-options) 17))
  (error? ; not a transcoder
    (open-file-input/output-port "testfile.ss" (file-options) (buffer-mode block) 'wow))
  (error? ; incorrect number of arguments
    (open-file-input/output-port "testfile.ss" (file-options) (buffer-mode block) #f 'now?))
  (error? ; cannot open
    (open-file-input/output-port "/probably/not/a/good/path"))
  (error? ; invalid options
    (open-file-input/output-port "testfile.ss" (file-options uncompressed)))
  (error? ; invalid options
    (open-file-input/output-port "testfile.ss" (file-options truncate)))
  (begin (delete-file "testfile.ss") #t)
  (error? ; no such file
    (open-file-input-port "testfile.ss"))
  (error? ; no such file
    (open-file-output-port "testfile.ss" (file-options no-create)))
  (error? ; no such file
    (open-file-input/output-port "testfile.ss" (file-options no-create)))
  (begin (mkdir "testfile.ss") #t)
  (guard (c [(and (i/o-filename-error? c)
                  (equal? (i/o-error-filename c) "testfile.ss"))])
    (open-file-output-port "testfile.ss" (file-options no-create)))
  (guard (c [(and (i/o-filename-error? c)
                  (equal? (i/o-error-filename c) "testfile.ss"))])
    (open-file-input/output-port "testfile.ss" (file-options no-create)))
  (begin (delete-directory "testfile.ss") #t)
  (begin
    (define $ppp (open-file-input/output-port "testfile.ss" (file-options replace)))
    (and (input-port? $ppp) (output-port? $ppp) (port? $ppp)))
  (error? (set-port-length! $ppp -3))
  (error? (set-port-length! $ppp 'all-the-way))
  (eof-object?
   (begin
     (set-port-length! $ppp 0)
     (set-port-position! $ppp 0)
     (put-bytevector $ppp (native-string->bytevector "hello"))
     (flush-output-port $ppp)
     (get-u8 $ppp)))
  (equal? (begin (set-port-position! $ppp 0) (get-bytevector-all $ppp))
          (native-string->bytevector "hello"))
  (eqv? (begin
          (put-bytevector $ppp (native-string->bytevector "goodbye\n"))
          (truncate-port $ppp 9)
          (port-position $ppp))
        9)
  (eof-object? (get-u8 $ppp))
  (eqv? (begin (set-port-position! $ppp 0) (port-position $ppp)) 0)
  (equal? (get-bytevector-all $ppp) (native-string->bytevector "hellogood"))
  (eqv? (begin
          (put-bytevector $ppp (native-string->bytevector "byebye\n"))
          (truncate-port $ppp 0)
          (port-position $ppp))
        0)
  (eof-object? (get-u8 $ppp))
  (eof-object?
   (begin
     (close-port $ppp)
     (let ([ip (open-file-input-port "testfile.ss")])
       (let ([c (get-u8 ip)])
         (close-port $ppp)
         (close-port ip)
         c))))
  (error?
   (let ([ip (open-file-input-port "testfile.ss")])
     (dynamic-wind
         void
         (lambda () (truncate-port ip))
         (lambda () (close-port ip)))))
  (error? (truncate-port 'animal-crackers))
  (error? (truncate-port))
  (error? (truncate-port $ppp))
  (let-values ([(op get) (open-bytevector-output-port)])
    (and (= (port-position op) 0)
         (= (port-length op) 0)
         (do ([i 4000 (fx- i 1)])
             ((fx= i 0) #t)
           (put-bytevector op (string->utf8 "hello")))
         (= (port-length op) 20000)
         (= (port-position op) 20000)
         (begin (set-port-position! op 5000) #t)
         (= (port-position op) 5000)
         (= (port-length op) 20000)
         (begin (truncate-port op) #t)
         (= (port-position op) 0)
         (= (port-length op) 0)
         (begin (truncate-port op 17) #t)
         (= (port-position op) 17)
         (= (port-length op) 17)
         (begin (put-bytevector op (string->utf8 "okay")) #t)
         (= (port-position op) 21)
         (= (port-length op) 21)
         (let ([bv (get)])
           (and (= (char->integer #\o) (bytevector-u8-ref bv 17))
                (= (char->integer #\k) (bytevector-u8-ref bv 18))
                (= (char->integer #\a) (bytevector-u8-ref bv 19))
                (= (char->integer #\y) (bytevector-u8-ref bv 20))))
         (= (port-position op) 0)
         (= (port-length op) 0)
         (begin (put-u8 op (char->integer #\a))
                (put-u8 op (char->integer #\newline))
                #t)
         (= (port-position op) 2)
         (equal? (get) (string->utf8 "a\n"))))
  (let ([ip (open-bytevector-input-port (native-string->bytevector "beam me up, scotty!"))]
        [bv (make-bytevector 10)])
    (and (= (port-position ip) 0)
         (= (port-length ip) 19)
         (not (eof-object? (lookahead-u8 ip)))
         (equal? (get-bytevector-n ip 4) (native-string->bytevector "beam"))
         (= (port-position ip) 4)
         (not (eof-object? (lookahead-u8 ip)))
         (equal? (get-bytevector-n! ip bv 0 10) 10)
         (equal? bv (native-string->bytevector " me up, sc"))
         (= (port-position ip) 14)
         (equal? (get-bytevector-n! ip bv 0 10) 5)
         (equal? bv (native-string->bytevector "otty!p, sc"))
         (= (port-position ip) 19)
         (eof-object? (lookahead-u8 ip))
         (eof-object? (get-u8 ip))
         (eof-object? (get-bytevector-n! ip bv 0 10))
         (= (get-bytevector-n! ip bv 0 0) 0) ;; TODO: check w/ Kent about this
         (begin
           (set-port-position! ip 10)
           (= (port-position ip) 10))
         (equal? (get-bytevector-n! ip bv 0 10) 9)
         (equal? bv (native-string->bytevector ", scotty!c"))))
)

(mat port-operations2
  (equal?
    (let* ([op (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode none))]
           [ip (open-file-input-port "testfile.ss")])
      (put-u8 op 97)
      (let* ([b1 (get-u8 ip)] [b2 (get-u8 ip)])
        (put-u8 op 98)
        (let* ([b3 (get-u8 ip)] [b4 (get-u8 ip)])
          (put-u8 op 99)
          (let ([b5 (get-u8 ip)])
            (close-port op)
              (let ([b6 (get-u8 ip)])
                (close-port ip)
                (list b1 b2 b3 b4 b5 b6))))))
    '(97 #!eof 98 #!eof 99 #!eof))
  (equal?
    (let* ([op (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode none))]
           [ip (open-file-input-port "testfile.ss")])
      (let ([eof1? (port-eof? ip)])
        (put-u8 op 97)
       ; the port-eof? call above buffers the eof, so b1 should be #!eof
        (let* ([b1 (get-u8 ip)] [b2 (get-u8 ip)])
          (put-u8 op 98)
          (let* ([eof2? (port-eof? ip)] [b3 (get-u8 ip)])
            (let ([b4 (get-u8 ip)])
              (put-u8 op 99)
              (let* ([b5 (get-u8 ip)])
                (close-port op)
                (let* ([b6 (get-u8 ip)] [eof3? (port-eof? ip)])
                  (close-port ip)
                  (list eof1? b1 b2 eof2? b3 b4 b5 b6 eof3?))))))))
    '(#t #!eof 97 #f 98 #!eof 99 #!eof #t))
  (equal?
   ; following assumes block buffering really doesn't cause any writes until
   ; at least after a few bytes have been written
    (let* ([op (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode block))]
           [ip (open-file-input-port "testfile.ss")])
      (put-u8 op 97)
      (let ([b1 (get-u8 ip)])
        (put-u8 op 98)
        (let ([b2 (get-u8 ip)])
          (close-port op)
          (let* ([b3 (get-u8 ip)] [b4 (get-u8 ip)] [b5 (get-u8 ip)])
            (close-port ip)
            (list b1 b2 b3 b4 b5)))))
    '(#!eof #!eof 97 98 #!eof))
 ; test switching between input and output modes
 ; should be adapted for textual ports
  (equal?
    (begin
      (call-with-port
        (open-file-output-port "testfile.ss" (file-options replace))
        (lambda (p) (put-bytevector p #vu8(1 2 3 4 5))))
      (let ([iop (open-file-input/output-port "testfile.ss"
                   (file-options no-fail no-truncate))])
        (let ([b1 (get-u8 iop)])
          (put-u8 iop 17)
          (let ([b2 (get-u8 iop)])
            (close-port iop)
            (list b1 b2
              (call-with-port
                (open-file-input-port "testfile.ss")
                get-bytevector-all))))))
    '(1 3 #vu8(1 17 3 4 5)))
 ; test switching between input and output modes
 ; old implementation is broken---uncomment for new implementation
 ; and move to set of mats testing convenience i/o
  #;(equal?
    (begin
      (with-output-to-file "testfile.ss"
        (lambda () (display "hi there"))
        'replace)
      (let ([iop (open-input-output-file "testfile.ss")])
        (let ([c1 (read-char iop)])
          (write-char #\! iop)
          (let ([c2 (read-char iop)])
            (close-port iop)
            (list c1 c2
              (with-input-from-file "testfile.ss"
                (lambda ()
                  (list->string
                    (let f ()
                      (let ([c (read-char)])
                        (if (eof-object? c)
                            '()
                            (cons c (f)))))))))))))
    '(#\h #\space "h! there"))
  (equal?
    (let-values ([(p g) (open-string-output-port)])
      (fresh-line p)
      (fresh-line p)
      (display "hello" p)
      (fresh-line p)
      (fresh-line p)
      (newline p)
      (fresh-line p)
      (display "goodbye" p)
      (newline p)
      (fresh-line p)
      (g))
    "hello\n\ngoodbye\n")
 ; check for bug fix in transcoded-port-put-some
  (let f ([n 1000])
    (or (fx= n 0)
        (begin
          (let ([op (open-file-output-port "testfile.ss" (file-options replace)
                      (buffer-mode line) (native-transcoder))])
            (do ([i 1000 (- i 1)])
                ((fx= i 0))
              (display #!eof op))
            (close-port op))
          (and (equal? (call-with-port
                         (open-file-input-port "testfile.ss" (file-options)
                           (buffer-mode block) (native-transcoder))
                         get-string-all)
                       (apply string-append (make-list 1000 "#!eof")))
               (f (- n 1))))))
)

(mat port-operations3
  (error? (file-port? "not a port"))
  (error? (port-file-descriptor 'oops))
  (error? (port-file-descriptor (open-input-string "hello")))
  (or (threaded?) (file-port? (console-input-port)))
  (or (threaded?) (file-port? (console-output-port)))
  (not (file-port? (open-input-string "hello")))
  (or (threaded?) (= (port-file-descriptor (console-input-port)) 0))
  (or (threaded?) (= (port-file-descriptor (console-output-port)) 1))
  (> (let ([ip (open-input-file prettytest.ss)])
       (let ([n (and (file-port? ip) (port-file-descriptor ip))])
         (close-port ip)
         n))
     1)
  (> (let ([ip (open-input-file prettytest.ss 'compressed)])
       (let ([n (and (file-port? ip) (port-file-descriptor ip))])
         (close-port ip)
         n))
     1)
  (> (let ([op (open-output-file "testfile.ss" '(replace))])
       (let ([n (and (file-port? op) (port-file-descriptor op))])
         (close-port op)
         n))
     1)
  (> (let ([op (open-output-file "testfile.ss" '(replace compressed))])
       (let ([n (and (file-port? op) (port-file-descriptor op))])
         (close-port op)
         n))
     1)
 )

(if (embedded?)
    (mat iconv-codec
      (error? (errorf 'iconv-codec "-73 is not a string"))
      (error? (errorf 'transcoded-port "unsupported encoding almost certainly bogus"))
      (error? (errorf 'close-port "iconv CP1252 codec cannot encode #\\x3BB"))
      (error? (errorf 'close-port "iconv CP1252 codec cannot encode #\\newline with eol-style ls"))
      (error? (errorf 'close-port "latin-1 codec cannot encode #\\newline with eol-style ls")))
    (mat iconv-codec
      (error? ; invalid codec
        (iconv-codec -73))
      (error? ; unsupported encoding
        (let ()
          (define codec (iconv-codec "almost certainly bogus"))
          (define transcoder
            (make-transcoder codec
              (eol-style none)
              (error-handling-mode ignore)))
          (define-values (bp get) (open-bytevector-output-port))
          (define op (transcoded-port bp transcoder))
          (newline op)
          (close-port op)))
      (let ()
        (define codec (iconv-codec "UTF-8"))
        (define transcoder
          (make-transcoder codec
            (eol-style none)
            (error-handling-mode ignore)))
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace)
            (buffer-mode line)
            transcoder))
        (define p1)
        (define p2)
        (define p3)
        (define p4)
        (newline op)
        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              (make-transcoder (utf-8-codec) (eol-style none)
                                (error-handling-mode raise)))
              (lambda (ip)
                (set! p1 (port-position ip))
                (let ([s (get-string-all ip)])
                  (set! p2 (port-position ip))
                  s)))
            "\nhello l\x0;ambda:\n\x3bb;!\n")
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              transcoder)
              (lambda (ip)
                (set! p3 (port-position ip))
                (let ([s (get-string-all ip)])
                  (set! p4 (port-position ip))
                  s)))
            "\nhello l\x0;ambda:\n\x3bb;!\n")
          (eq? p1 0)
          (eq? p2 20)
          (eq? p3 0)
          (eq? p4 20)))
      (let () ; same but eol-style lf
        (define codec (iconv-codec "UTF-8"))
        (define transcoder
          (make-transcoder codec
            (eol-style lf)
            (error-handling-mode ignore)))
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace)
            (buffer-mode line)
            transcoder))
        (define p1)
        (define p2)
        (define p3)
        (define p4)
        (newline op)
        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              (make-transcoder (utf-8-codec) (eol-style lf)
                                (error-handling-mode raise)))
              (lambda (ip)
                (set! p1 (port-position ip))
                (let ([s (get-string-all ip)])
                  (set! p2 (port-position ip))
                  s)))
            "\nhello l\x0;ambda:\n\x3bb;!\n")
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              transcoder)
              (lambda (ip)
                (set! p3 (port-position ip))
                (let ([s (get-string-all ip)])
                  (set! p4 (port-position ip))
                  s)))
            "\nhello l\x0;ambda:\n\x3bb;!\n")
          (eq? p1 0)
          (eq? p2 20)
          (eq? p3 0)
          (eq? p4 20)))
      (let () ; same but eol-style crlf
        (define codec (iconv-codec "UTF-8"))
        (define transcoder
          (make-transcoder codec
            (eol-style crlf)
            (error-handling-mode ignore)))
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace)
            (buffer-mode line)
            transcoder))
        (define p1)
        (define p2)
        (define p3)
        (define p4)
        (newline op)
        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              (make-transcoder (utf-8-codec) (eol-style crlf)
                                (error-handling-mode raise)))
              (lambda (ip)
                (set! p1 (port-position ip))
                (let ([s (get-string-all ip)])
                  (set! p2 (port-position ip))
                  s)))
            "\nhello l\x0;ambda:\n\x3bb;!\n")
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              transcoder)
              (lambda (ip)
                (set! p3 (port-position ip))
                (let ([s (get-string-all ip)])
                  (set! p4 (port-position ip))
                  s)))
            "\nhello l\x0;ambda:\n\x3bb;!\n")
          (eq? p1 0)
          (eq? p2 23)
          (eq? p3 0)
          (eq? p4 23)))
      (let ()
        (define codec (iconv-codec "GB18030"))
        (define transcoder
          (make-transcoder codec
            (eol-style none)
            (error-handling-mode raise)))
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace)
            (buffer-mode line)
            transcoder))
        (newline op)
        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss")
              get-bytevector-all)
            #vu8(#x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0a #xa6 #xcb #x21 #x0a))
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              transcoder)
              get-string-all)
            "\nhello l\x0;ambda:\n\x3bb;!\n")))
      (let ()
        (define codec (iconv-codec "CP1252"))
        (define transcoder
          (make-transcoder codec
            (eol-style none)
            (error-handling-mode replace)))
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace)
            (buffer-mode line)
            transcoder))
        (newline op)
        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss")
              get-bytevector-all)
            #vu8(#x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0a #x3f #x21 #x0a))
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              transcoder)
              get-string-all)
            "\nhello l\x0;ambda:\n?!\n")))
      (let () ; same but eol-style lf
        (define codec (iconv-codec "CP1252"))
        (define transcoder
          (make-transcoder codec
            (eol-style lf)
            (error-handling-mode replace)))
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace)
            (buffer-mode line)
            transcoder))
        (newline op)
        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss")
              get-bytevector-all)
            #vu8(#x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0a #x3f #x21 #x0a))
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              transcoder)
              get-string-all)
            "\nhello l\x0;ambda:\n?!\n")))
      (let () ; same but eol-style crlf
        (define codec (iconv-codec "CP1252"))
        (define transcoder
          (make-transcoder codec
            (eol-style crlf)
            (error-handling-mode replace)))
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace)
            (buffer-mode line)
            transcoder))
        (newline op)
        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss")
              get-bytevector-all)
            #vu8(#x0d #x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0d #x0a #x3f #x21 #x0d #x0a))
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              transcoder)
              get-string-all)
            "\nhello l\x0;ambda:\n?!\n")))
      (let ()
        (define codec (iconv-codec "CP1252"))
        (define transcoder
          (make-transcoder codec
            (eol-style none)
            (error-handling-mode ignore)))
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace)
            (buffer-mode line)
            transcoder))
        (newline op)
        (display "hello l\x0;ambda:\n\x3bb;!\n" op)
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss")
              get-bytevector-all)
            #vu8(#x0a #x68 #x65 #x6c #x6c #x6f #x20 #x6c #x00 #x61 #x6d #x62 #x64 #x61 #x3a #x0a #x21 #x0a))
          (equal?
            (call-with-port (open-file-input-port "testfile.ss" (file-options)
                              (buffer-mode block)
                              transcoder)
              get-string-all)
            "\nhello l\x0;ambda:\n!\n")))
      (error? ; encoding error
        (let-values ([(bp get) (open-bytevector-output-port)])
          (define codec (iconv-codec "CP1252"))
          (define transcoder
            (make-transcoder codec
              (eol-style none)
              (error-handling-mode raise)))
          (define op (transcoded-port bp transcoder))
          (newline op)
          (display "hello l\x0;ambda: \x3bb;!\n" op)
          (close-port op)))
      (error? ; encoding error
        (let-values ([(bp get) (open-bytevector-output-port)])
          (define codec (iconv-codec "CP1252"))
          (define transcoder
            (make-transcoder codec
              (eol-style ls)
              (error-handling-mode raise)))
          (define op (transcoded-port bp transcoder))
          (newline op)
          (close-port op)))
      ; some (older?) versions of iconv don't handle unassigned code-page 1252
      ; characters properly.  c'est la vie.
      #;(let ()
          (define bp (open-bytevector-input-port #vu8(#x80 #x81 #x82 #x8c #x8d #x8e #x8f #x90 #x91 #x9c #x9d #x9e)))
          (define codec (iconv-codec "CP1252"))
          (define transcoder
            (make-transcoder codec
              (eol-style none)
              (error-handling-mode replace)))
          (define ip (transcoded-port bp transcoder))
          (equal?
            (get-string-all ip)
            "\x20ac;\xfffd;\x201a;\x0152;\xfffd;\x017d;\xfffd;\xfffd;\x2018;\x0153;\xfffd;\x017e;"))
      #;(let ()
          (define bp (open-bytevector-input-port #vu8(#x80 #x81 #x82 #x8c #x8d #x8e #x8f #x90 #x91 #x9c #x9d #x9e)))
          (define codec (iconv-codec "CP1252"))
          (define transcoder
            (make-transcoder codec
              (eol-style none)
              (error-handling-mode ignore)))
          (define ip (transcoded-port bp transcoder))
          (equal?
            (get-string-all ip)
            "\x20ac;\x201a;\x0152;\x017d;\x2018;\x0153;\x017e;"))
      #;(error? ; decoding error
          (let ()
            (define bp (open-bytevector-input-port #vu8(#x80 #x81 #x82 #x8c #x8d #x8e #x8f #x90 #x91 #x9c #x9d #x9e)))
            (define codec (iconv-codec "CP1252"))
            (define transcoder
              (make-transcoder codec
                (eol-style none)
                (error-handling-mode raise)))
            (define ip (transcoded-port bp transcoder))
            (equal?
              (get-string-all ip)
              "\x20ac;\xfffd;\x201a;\x0152;\xfffd;\x017d;\xfffd;\xfffd;\x2018;\x0153;\xfffd;\x017e;")))
      (let () ; SBCS CP1252
        (define cp1252
          '((#x00 #x0000) (#x01 #x0001) (#x02 #x0002) (#x03 #x0003)
                          (#x04 #x0004) (#x05 #x0005) (#x06 #x0006) (#x07 #x0007)
                          (#x08 #x0008) (#x09 #x0009) (#x0A #x000A) (#x0B #x000B)
                          (#x0C #x000C) (#x0D #x000D) (#x0E #x000E) (#x0F #x000F)
                          (#x10 #x0010) (#x11 #x0011) (#x12 #x0012) (#x13 #x0013)
                          (#x14 #x0014) (#x15 #x0015) (#x16 #x0016) (#x17 #x0017)
                          (#x18 #x0018) (#x19 #x0019) (#x1A #x001A) (#x1B #x001B)
                          (#x1C #x001C) (#x1D #x001D) (#x1E #x001E) (#x1F #x001F)
                          (#x20 #x0020) (#x21 #x0021) (#x22 #x0022) (#x23 #x0023)
                          (#x24 #x0024) (#x25 #x0025) (#x26 #x0026) (#x27 #x0027)
                          (#x28 #x0028) (#x29 #x0029) (#x2A #x002A) (#x2B #x002B)
                          (#x2C #x002C) (#x2D #x002D) (#x2E #x002E) (#x2F #x002F)
                          (#x30 #x0030) (#x31 #x0031) (#x32 #x0032) (#x33 #x0033)
                          (#x34 #x0034) (#x35 #x0035) (#x36 #x0036) (#x37 #x0037)
                          (#x38 #x0038) (#x39 #x0039) (#x3A #x003A) (#x3B #x003B)
                          (#x3C #x003C) (#x3D #x003D) (#x3E #x003E) (#x3F #x003F)
                          (#x40 #x0040) (#x41 #x0041) (#x42 #x0042) (#x43 #x0043)
                          (#x44 #x0044) (#x45 #x0045) (#x46 #x0046) (#x47 #x0047)
                          (#x48 #x0048) (#x49 #x0049) (#x4A #x004A) (#x4B #x004B)
                          (#x4C #x004C) (#x4D #x004D) (#x4E #x004E) (#x4F #x004F)
                          (#x50 #x0050) (#x51 #x0051) (#x52 #x0052) (#x53 #x0053)
                          (#x54 #x0054) (#x55 #x0055) (#x56 #x0056) (#x57 #x0057)
                          (#x58 #x0058) (#x59 #x0059) (#x5A #x005A) (#x5B #x005B)
                          (#x5C #x005C) (#x5D #x005D) (#x5E #x005E) (#x5F #x005F)
                          (#x60 #x0060) (#x61 #x0061) (#x62 #x0062) (#x63 #x0063)
                          (#x64 #x0064) (#x65 #x0065) (#x66 #x0066) (#x67 #x0067)
                          (#x68 #x0068) (#x69 #x0069) (#x6A #x006A) (#x6B #x006B)
                          (#x6C #x006C) (#x6D #x006D) (#x6E #x006E) (#x6F #x006F)
                          (#x70 #x0070) (#x71 #x0071) (#x72 #x0072) (#x73 #x0073)
                          (#x74 #x0074) (#x75 #x0075) (#x76 #x0076) (#x77 #x0077)
                          (#x78 #x0078) (#x79 #x0079) (#x7A #x007A) (#x7B #x007B)
                          (#x7C #x007C) (#x7D #x007D) (#x7E #x007E) (#x7F #x007F)
                          (#x80 #x20AC) (#x82 #x201A) (#x83 #x0192) (#x84 #x201E)
                          (#x85 #x2026) (#x86 #x2020) (#x87 #x2021) (#x88 #x02C6)
                          (#x89 #x2030) (#x8A #x0160) (#x8B #x2039) (#x8C #x0152)
                          (#x8E #x017D) (#x91 #x2018) (#x92 #x2019) (#x93 #x201C)
                          (#x94 #x201D) (#x95 #x2022) (#x96 #x2013) (#x97 #x2014)
                          (#x98 #x02DC) (#x99 #x2122) (#x9A #x0161) (#x9B #x203A)
                          (#x9C #x0153) (#x9E #x017E) (#x9F #x0178) (#xA0 #x00A0)
                          (#xA1 #x00A1) (#xA2 #x00A2) (#xA3 #x00A3) (#xA4 #x00A4)
                          (#xA5 #x00A5) (#xA6 #x00A6) (#xA7 #x00A7) (#xA8 #x00A8)
                          (#xA9 #x00A9) (#xAA #x00AA) (#xAB #x00AB) (#xAC #x00AC)
                          (#xAD #x00AD) (#xAE #x00AE) (#xAF #x00AF) (#xB0 #x00B0)
                          (#xB1 #x00B1) (#xB2 #x00B2) (#xB3 #x00B3) (#xB4 #x00B4)
                          (#xB5 #x00B5) (#xB6 #x00B6) (#xB7 #x00B7) (#xB8 #x00B8)
                          (#xB9 #x00B9) (#xBA #x00BA) (#xBB #x00BB) (#xBC #x00BC)
                          (#xBD #x00BD) (#xBE #x00BE) (#xBF #x00BF) (#xC0 #x00C0)
                          (#xC1 #x00C1) (#xC2 #x00C2) (#xC3 #x00C3) (#xC4 #x00C4)
                          (#xC5 #x00C5) (#xC6 #x00C6) (#xC7 #x00C7) (#xC8 #x00C8)
                          (#xC9 #x00C9) (#xCA #x00CA) (#xCB #x00CB) (#xCC #x00CC)
                          (#xCD #x00CD) (#xCE #x00CE) (#xCF #x00CF) (#xD0 #x00D0)
                          (#xD1 #x00D1) (#xD2 #x00D2) (#xD3 #x00D3) (#xD4 #x00D4)
                          (#xD5 #x00D5) (#xD6 #x00D6) (#xD7 #x00D7) (#xD8 #x00D8)
                          (#xD9 #x00D9) (#xDA #x00DA) (#xDB #x00DB) (#xDC #x00DC)
                          (#xDD #x00DD) (#xDE #x00DE) (#xDF #x00DF) (#xE0 #x00E0)
                          (#xE1 #x00E1) (#xE2 #x00E2) (#xE3 #x00E3) (#xE4 #x00E4)
                          (#xE5 #x00E5) (#xE6 #x00E6) (#xE7 #x00E7) (#xE8 #x00E8)
                          (#xE9 #x00E9) (#xEA #x00EA) (#xEB #x00EB) (#xEC #x00EC)
                          (#xED #x00ED) (#xEE #x00EE) (#xEF #x00EF) (#xF0 #x00F0)
                          (#xF1 #x00F1) (#xF2 #x00F2) (#xF3 #x00F3) (#xF4 #x00F4)
                          (#xF5 #x00F5) (#xF6 #x00F6) (#xF7 #x00F7) (#xF8 #x00F8)
                          (#xF9 #x00F9) (#xFA #x00FA) (#xFB #x00FB) (#xFC #x00FC)
                          (#xFD #x00FD) (#xFE #x00FE) (#xFF #x00FF)))
        (define transcoder
          (make-transcoder (iconv-codec "CP1252")
            (eol-style none)
            (error-handling-mode raise)))
        (define ls
          (append cp1252
            (let ([v (list->vector cp1252)])
              (let f ([n 100000])
                (if (fx= n 0)
                    '()
                    (cons
                      (vector-ref v (random (vector-length v)))
                      (f (fx- n 1))))))))
        (define s (apply string (map integer->char (map cadr ls))))
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace) (buffer-mode block)
            transcoder))
        #;(put-string op s)
        (let loop ([i 0] [n (string-length s)])
          (unless (fx= n 0)
            (let ([k (fx+ (random n) 1)])
              (put-string op s i k)
              (loop (fx+ i k) (fx- n k)))))
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss")
              get-bytevector-all)
            (apply bytevector (map car ls)))
          (equal?
            (call-with-port (open-file-input-port "testfile.ss"
                              (file-options) (buffer-mode block)
                              transcoder)
              #;get-string-all
              (lambda (ip)
                (let ([t (make-string (string-length s))])
                  (let loop ([i 0] [n (string-length s)])
                    (unless (fx= n 0)
                      (let ([k (fx+ (random n) 1)])
                        (get-string-n! ip t i k)
                        (loop (fx+ i k) (fx- n k)))))
                  t)))
            s)))
      (let () ; MBCS UTF-8
        (define transcoder
          (make-transcoder (iconv-codec "UTF-8")
            (eol-style none)
            (error-handling-mode raise)))
        (define ls1
          (let f ([i 0])
            (if (fx= i #x11000)
                '()
                (if (fx= i #xD800)
                    (f #xE000)
                    (cons i (f (fx+ i 1)))))))
        (define ls2
          (let f ([n 1000000])
            (if (fx= n 0)
                '()
                (cons
                  (let ([n (random (- #x110000 (- #xE000 #xD800)))])
                    (if (<= #xD800 n #xDFFF)
                        (+ n (- #xE000 #xD800))
                        n))
                  (f (fx- n 1))))))
        (define s (apply string (map integer->char (append ls1 ls2))))
        #;(define s (apply string (map integer->char ls1)))
        #;(define s "hello\x1447A;")
        (define op
          (open-file-output-port "testfile.ss"
            (file-options replace) (buffer-mode block)
            transcoder))
        #;(put-string op s)
        (let loop ([i 0] [n (string-length s)])
          (unless (fx= n 0)
            (let ([k (fx+ (random n) 1)])
              (put-string op s i k)
              (loop (fx+ i k) (fx- n k)))))
        (close-port op)
        (and
          (equal?
            (call-with-port (open-file-input-port "testfile.ss"
                              (file-options) (buffer-mode block)
                              (make-transcoder (utf-8-codec) (eol-style none)
                                (error-handling-mode raise)))
              get-string-all)
            s)
          (equal?
            (call-with-port (open-file-input-port "testfile.ss"
                              (file-options) (buffer-mode block)
                              transcoder)
              #;get-string-all
              (lambda (ip)
                (let ([t (make-string (string-length s))])
                  (let loop ([i 0] [n (string-length s)])
                    (unless (fx= n 0)
                      (let ([k (fx+ (random n) 1)])
                        (get-string-n! ip t i k)
                        (loop (fx+ i k) (fx- n k)))))
                  t)))
            s)))
      (error? ; encoding error
        (let ()
          (define transcoder
            (make-transcoder (latin-1-codec)
              (eol-style ls)
              (error-handling-mode raise)))
          (define-values (bp get) (open-bytevector-output-port))
          (define op (transcoded-port bp transcoder))
          (newline op)
          (close-port op)))
      ; NB: keep this last among the iconv-codec mats
      ; close any files left open by failing iconv tests.  this is particularly
      ; important on windows when the iconv dll isn't available and where keeping
      ; file open can prevent it from being reopened.
      (begin (collect (collect-maximum-generation)) #t)
      ))

(mat port-operations4
  (begin
    (define po4-tx (make-transcoder (latin-1-codec) (eol-style none) (error-handling-mode raise)))
    #t)
  (transcoder? po4-tx)
  (not (transcoder? (latin-1-codec)))
  (eq? (call-with-port 
         (open-file-output-port "testfile.ss" (file-options replace)
           (buffer-mode block) po4-tx)
         (lambda (op) (put-string op "hi there")))
       (void))
 ; binary input port
  (begin
    (define po4-p (open-file-input-port "testfile.ss"))
    #t)
  (and (input-port? po4-p) (binary-port? po4-p) (file-port? po4-p))
  (error? (put-string po4-p "hello"))
  (error? (put-bytevector po4-p #vu8(100)))
  (error? (get-string-all po4-p))
  (error? (get-char po4-p))
  (error? (lookahead-char po4-p))
  (fixnum? (port-file-descriptor po4-p))
  (port-has-port-position? po4-p)
  (eqv? (port-position po4-p) 0)
  (port-has-set-port-position!? po4-p)
  (eq? (set-port-position! po4-p 3) (void))
  (eqv? (port-position po4-p) 3)
  (equal? (get-bytevector-n po4-p 5) (string->bytevector "there" po4-tx))
  (eof-object? (get-bytevector-n po4-p 1))
  (port-has-port-length? po4-p)
  (eqv? (port-length po4-p) 8)
  (not (port-has-set-port-length!? po4-p))
  (error? (set-port-length! po4-p 7))
  (eq? (close-port po4-p) (void))
 ; textual input port
  (begin
    (define po4-p
      (open-file-input-port "testfile.ss" (file-options)
        (buffer-mode block) po4-tx))
    #t)
  (and (input-port? po4-p) (textual-port? po4-p) (file-port? po4-p))
  (error? (put-string po4-p "hello"))
  (error? (put-bytevector po4-p #vu8(100)))
  (error? (get-bytevector-all po4-p))
  (error? (get-u8 po4-p))
  (error? (lookahead-u8 po4-p))
  (fixnum? (port-file-descriptor po4-p))
  (port-has-port-position? po4-p)
  (eqv? (port-position po4-p) 0)
  (port-has-set-port-position!? po4-p)
  (eqv? (set-port-position! po4-p 3) (void))
  (eqv? (port-position po4-p) 3)
  (equal? (get-string-n po4-p 5) "there")
  (eof-object? (get-string-n po4-p 1))
  (port-has-port-length? po4-p)
  (eqv? (port-length po4-p) 8)
  (not (port-has-set-port-length!? po4-p))
  (error? (set-port-length! po4-p 7))
  (eq? (close-port po4-p) (void))
 ; binary output port
  (begin
    (define po4-p
      (open-file-output-port "testfile.ss" (file-options replace)))
    #t)
  (and (output-port? po4-p) (binary-port? po4-p) (file-port? po4-p))
  (error? (get-string-all po4-p))
  (error? (get-char po4-p))
  (error? (lookahead-char po4-p))
  (error? (get-bytevector-all po4-p))
  (error? (get-u8 po4-p))
  (error? (lookahead-u8 po4-p))
  (error? (put-string po4-p "hello"))
  (fixnum? (port-file-descriptor po4-p))
  (port-has-port-position? po4-p)
  (eqv? (port-position po4-p) 0)
  (port-has-set-port-position!? po4-p)
  (eq? (set-port-position! po4-p 3) (void))
  (eqv? (port-position po4-p) 3)
  (eq? (put-bytevector po4-p (string->bytevector "123456" po4-tx)) (void))
  (port-has-port-length? po4-p)
  (eqv? (port-length po4-p) 9)
  (port-has-set-port-length!? po4-p)
  (eq? (set-port-length! po4-p 7) (void))
  (eq? (set-port-position! po4-p 0) (void))
  (eq? (put-bytevector po4-p (string->bytevector "abcd" po4-tx)) (void))
  (eq? (close-port po4-p) (void))
  (equal?
    (call-with-port
      (open-file-input-port "testfile.ss" (file-options)
        (buffer-mode block) po4-tx)
      get-string-all)
    "abcd234")
 ; textual output port
  (begin
    (define po4-p
      (open-file-output-port "testfile.ss" (file-options replace)
        (buffer-mode block) po4-tx))
    #t)
  (and (output-port? po4-p) (textual-port? po4-p) (file-port? po4-p))
  (error? (get-string-all po4-p))
  (error? (get-char po4-p))
  (error? (lookahead-char po4-p))
  (error? (get-bytevector-all po4-p))
  (error? (get-u8 po4-p))
  (error? (lookahead-u8 po4-p))
  (error? (put-bytevector po4-p #vu8()))
  (fixnum? (port-file-descriptor po4-p))
  (port-has-port-position? po4-p)
  (eqv? (port-position po4-p) 0)
  (port-has-set-port-position!? po4-p)
  (eq? (set-port-position! po4-p 3) (void))
  (eqv? (port-position po4-p) 3)
  (eq? (put-string po4-p "abcdef") (void))
  (port-has-port-length? po4-p)
  (eqv? (port-length po4-p) 9)
  (port-has-set-port-length!? po4-p)
  (eq? (set-port-length! po4-p 7) (void))
  (eq? (set-port-position! po4-p 0) (void))
  (eq? (put-string po4-p "1234") (void))
  (eq? (close-port po4-p) (void))
  (equal?
    (call-with-port
      (open-file-input-port "testfile.ss" (file-options)
        (buffer-mode block) po4-tx)
      get-string-all)
    "1234bcd")
 ; binary input/output port
  (begin
    (define po4-p
      (open-file-input/output-port "testfile.ss" (file-options replace)))
    #t)
  (and (output-port? po4-p) (binary-port? po4-p) (file-port? po4-p))
  (and (input-port? po4-p) (binary-port? po4-p) (file-port? po4-p))
  (fixnum? (port-file-descriptor po4-p))
  (port-has-port-position? po4-p)
  (eqv? (port-position po4-p) 0)
  (port-has-set-port-position!? po4-p)
  (eq? (set-port-position! po4-p 3) (void))
  (eqv? (port-position po4-p) 3)
  (eq? (put-bytevector po4-p (string->bytevector "foobar" po4-tx)) (void))
  (port-has-port-length? po4-p)
  (eqv? (port-length po4-p) 9)
  (port-has-set-port-length!? po4-p)
  (eq? (set-port-length! po4-p 7) (void))
  (eq? (set-port-position! po4-p 0) (void))
  (eq? (put-bytevector po4-p (string->bytevector "4321" po4-tx)) (void))
  (equal? (get-bytevector-all po4-p) (string->bytevector "oob" po4-tx))
  (eq? (set-port-position! po4-p 0) (void))
  (equal? (get-bytevector-all po4-p) (string->bytevector "4321oob" po4-tx))
  (eq? (close-port po4-p) (void))
  (equal?
    (call-with-port
      (open-file-input-port "testfile.ss" (file-options)
        (buffer-mode block) po4-tx)
      get-string-all)
    "4321oob")
 ; textual input/output port
  (begin
    (define po4-p
      (open-file-input/output-port "testfile.ss" (file-options replace)
        (buffer-mode block) po4-tx))
    #t)
  (and (output-port? po4-p) (textual-port? po4-p) (file-port? po4-p))
  (and (input-port? po4-p) (textual-port? po4-p) (file-port? po4-p))
  (fixnum? (port-file-descriptor po4-p))
  (port-has-port-position? po4-p)
  (eqv? (port-position po4-p) 0)
  (port-has-set-port-position!? po4-p)
  (eq? (set-port-position! po4-p 3) (void))
  (eqv? (port-position po4-p) 3)
  (eq? (put-string po4-p "abcdef") (void))
  (port-has-port-length? po4-p)
  (eqv? (port-length po4-p) 9)
  (port-has-set-port-length!? po4-p)
  (eq? (set-port-length! po4-p 7) (void))
  (eq? (set-port-position! po4-p 0) (void))
  (eq? (put-string po4-p "1234") (void))
  (equal? (get-string-all po4-p) "bcd")
  (eq? (set-port-position! po4-p 0) (void))
  (equal? (get-string-all po4-p) "1234bcd")
  (eq? (close-port po4-p) (void))
  (equal?
    (call-with-port
      (open-file-input-port "testfile.ss" (file-options)
        (buffer-mode block) po4-tx)
      get-string-all)
    "1234bcd")
)

(mat get-line
  (error? ; not a port
    (get-line "current-input-port"))
  (error? ; not a port
    (get-line 3))
  (error? ; not a textual input port
    (get-line (open-bytevector-input-port #vu8(1 2 3 4 5))))
  (begin
    (with-output-to-file "testfile.ss"
      (lambda ()
        (display "hello from line 1!\n")
        (display (make-string 1017 #\a))
        (display " hello from line 2!\n")
        (display "goodbye from (incomplete) line 3!"))
      'replace)
    (define $tip (open-input-file "testfile.ss"))
    #t)
  (equal? (get-line $tip) "hello from line 1!")
  (equal? (get-line $tip) (format "~a hello from line 2!" (make-string 1017 #\a)))
  (equal? (get-line $tip) "goodbye from (incomplete) line 3!")
  (eof-object? (get-line $tip))
  (eqv? (close-port $tip) (void))
  (begin
    (with-output-to-file "testfile.ss"
      (lambda ()
        (display "hello from line 1!\n")
        (display "\n")
        (display "goodbye from (complete) line 3!\n"))
      'replace)
    (define $tip (open-input-file "testfile.ss"))
    #t)
  (equal? (get-line $tip) "hello from line 1!")
  (equal? (get-line $tip) "")
  (equal? (get-line $tip) "goodbye from (complete) line 3!")
  (eof-object? (get-line $tip))
  (eqv? (close-port $tip) (void))
)

(mat low-level-port-operations
  (<= (textual-port-input-index (console-input-port))
      (textual-port-input-size (console-input-port))
      (string-length (textual-port-input-buffer (console-input-port))))
  (<= (textual-port-input-count (console-input-port))
      (string-length (textual-port-input-buffer (console-input-port))))
  (<= (textual-port-output-index (console-output-port))
      (textual-port-output-size (console-output-port))
      (string-length (textual-port-output-buffer (console-output-port))))
  (<= (textual-port-output-count (console-output-port))
      (string-length (textual-port-output-buffer (console-output-port))))
  (begin
    (define $tip (open-string-input-port "hello"))
    (define $top (let-values ([(op get) (open-string-output-port)]) (set-textual-port-output-buffer! op "hello") op))
    (define $bip (open-bytevector-input-port #vu8(1 2 3 4 5)))
    (define $bop (let-values ([(op get) (open-bytevector-output-port)]) (set-binary-port-output-buffer! op #vu8(1 2 3 4 5)) op))
    #t)
  ; textual input
  (andmap (lambda (str)
            (equal?
             (let ([ip (open-string-input-port str)])
               (let ([buffer0 (textual-port-input-buffer ip)]
                     [index0 (textual-port-input-index ip)]
                     [size0 (textual-port-input-size ip)]
                     [count0 (textual-port-input-count ip)])
                 (read-char ip)
                 (list
                  (list buffer0 index0 size0 count0)
                  (list
                   (textual-port-input-buffer ip)
                   (textual-port-input-index ip)
                   (textual-port-input-size ip)
                   (textual-port-input-count ip)))))
             '(("hello" 0 5 5) ("hello" 1 5 4))))
          (list "hello"
                (string->immutable-string "hello")))
  (equal?
    (let ([ip (open-string-input-port "hello")])
      (let ([buffer0 (textual-port-input-buffer ip)]
            [index0 (textual-port-input-index ip)]
            [size0 (textual-port-input-size ip)]
            [count0 (textual-port-input-count ip)])
        (read-char ip)
        (set-textual-port-input-buffer! ip "goodbye")
        (read-char ip)
        (list
          (list buffer0 index0 size0 count0)
          (list
            (textual-port-input-buffer ip)
            (textual-port-input-index ip)
            (textual-port-input-size ip)
            (textual-port-input-count ip)))))
    '(("hello" 0 5 5) ("goodbye" 1 7 6)))
  (equal?
    (let ([ip (open-string-input-port "hello")])
      (let ([buffer0 (textual-port-input-buffer ip)]
            [index0 (textual-port-input-index ip)]
            [size0 (textual-port-input-size ip)]
            [count0 (textual-port-input-count ip)])
        (read-char ip)
        (set-textual-port-input-size! ip 4)
        (read-char ip)
        (list
          (list buffer0 index0 size0 count0)
          (list
            (textual-port-input-buffer ip)
            (textual-port-input-index ip)
            (textual-port-input-size ip)
            (textual-port-input-count ip)))))
    '(("hello" 0 5 5) ("hello" 1 4 3)))
  (equal?
    (let ([ip (open-string-input-port "hello")])
      (let ([buffer0 (textual-port-input-buffer ip)]
            [index0 (textual-port-input-index ip)]
            [size0 (textual-port-input-size ip)]
            [count0 (textual-port-input-count ip)])
        (read-char ip)
        (set-textual-port-input-index! ip 4)
        (read-char ip)
        (list
          (list buffer0 index0 size0 count0)
          (list
            (textual-port-input-buffer ip)
            (textual-port-input-index ip)
            (textual-port-input-size ip)
            (textual-port-input-count ip)))))
    '(("hello" 0 5 5) ("hello" 5 5 0)))
  (error? ; not a textual input port
    (textual-port-input-buffer $top))
  (error? ; not a textual input port
    (textual-port-input-buffer $bip))
  (error? ; not a textual input port
    (textual-port-input-buffer $bop))
  (error? ; not a textual input port
    (textual-port-input-buffer 75))
  (error? ; not a textual input port
    (textual-port-input-index $top))
  (error? ; not a textual input port
    (textual-port-input-index $bip))
  (error? ; not a textual input port
    (textual-port-input-index $bop))
  (error? ; not a textual input port
    (textual-port-input-index 75))
  (error? ; not a textual input port
    (textual-port-input-size $top))
  (error? ; not a textual input port
    (textual-port-input-size $bip))
  (error? ; not a textual input port
    (textual-port-input-size $bop))
  (error? ; not a textual input port
    (textual-port-input-size 75))
  (error? ; not a textual input port
    (textual-port-input-count $top))
  (error? ; not a textual input port
    (textual-port-input-count $bip))
  (error? ; not a textual input port
    (textual-port-input-count $bop))
  (error? ; not a textual input port
    (textual-port-input-count 75))
  (error? ; not a textual input port
    (set-textual-port-input-buffer! $top ""))
  (error? ; not a textual input port
    (set-textual-port-input-buffer! $bip ""))
  (error? ; not a textual input port
    (set-textual-port-input-buffer! $bop ""))
  (error? ; not a textual input port
    (set-textual-port-input-buffer! 75 ""))
  (error? ; not a textual input port
    (set-textual-port-input-index! $top 0))
  (error? ; not a textual input port
    (set-textual-port-input-index! $bip 0))
  (error? ; not a textual input port
    (set-textual-port-input-index! $bop 0))
  (error? ; not a textual input port
    (set-textual-port-input-index! 75 0))
  (error? ; not a textual input port
    (set-textual-port-input-size! $top 0))
  (error? ; not a textual input port
    (set-textual-port-input-size! $bip 0))
  (error? ; not a textual input port
    (set-textual-port-input-size! $bop 0))
  (error? ; not a textual input port
    (set-textual-port-input-size! 75 0))
  (error? ; not a string
    (set-textual-port-input-buffer! $tip #vu8(1 2 3)))
  (error? ; not a string
    (set-textual-port-input-buffer! $tip 0))
  (error? ; invalid index
    (set-textual-port-input-index! $tip "hello"))
  (error? ; invalid index
    (set-textual-port-input-index! $tip -1))
  (error? ; invalid index
    (set-textual-port-input-index! $tip 6))
  (error? ; invalid size
    (set-textual-port-input-size! $tip "hello"))
  (error? ; invalid size
    (set-textual-port-input-size! $tip -1))
  (error? ; invalid size
    (set-textual-port-input-size! $tip 6))
  ; textual output
  (equal?
    (let ([op (make-output-port (lambda args (error #f "oops")) (make-string 10 #\$))])
      (let ([buffer0 (string-copy (textual-port-output-buffer op))]
            [index0 (textual-port-output-index op)]
            [size0 (textual-port-output-size op)]
            [count0 (textual-port-output-count op)])
        (display "hey!" op)
        (list
          (list buffer0 index0 size0 count0)
          (list
            (textual-port-output-buffer op)
            (textual-port-output-index op)
            (textual-port-output-size op)
            (textual-port-output-count op)))))
    '(("$$$$$$$$$$" 0 10 10)
      ("hey!$$$$$$" 4 10 6)))
  (equal?
    (let-values ([(op get) (open-string-output-port)])
      (let ([buffer (make-string 8 #\$)])
        (set-textual-port-output-buffer! op buffer)
        (let ([buffer0 (string-copy (textual-port-output-buffer op))]
              [index0 (textual-port-output-index op)]
              [size0 (textual-port-output-size op)]
              [count0 (textual-port-output-count op)])
          (display "yo!" op)
          (list
            buffer
            (list buffer0 index0 size0 count0)
            (list
              (textual-port-output-buffer op)
              (textual-port-output-index op)
              (textual-port-output-size op)
              (textual-port-output-count op))))))
    '("yo!$$$$$"
      ("$$$$$$$$" 0 8 8)
      ("yo!$$$$$" 3 8 5)))
  (equal?
    (let-values ([(op get) (open-string-output-port)])
      (let ([buffer (make-string 8 #\$)])
        (set-textual-port-output-buffer! op buffer)
        (let ([buffer0 (string-copy (textual-port-output-buffer op))]
              [index0 (textual-port-output-index op)]
              [size0 (textual-port-output-size op)]
              [count0 (textual-port-output-count op)])
          (display "yo" op)
          (set-textual-port-output-buffer! op (string #\a #\b #\c))
          (display "!?" op)
          (list
            buffer
            (list buffer0 index0 size0 count0)
            (list
              (textual-port-output-buffer op)
              (textual-port-output-index op)
              (textual-port-output-size op)
              (textual-port-output-count op))))))
    '("yo$$$$$$"
      ("$$$$$$$$" 0 8 8)
      ("!?c" 2 3 1)))
  (equal?
    (let-values ([(op get) (open-string-output-port)])
      (let ([buffer (make-string 8 #\$)])
        (set-textual-port-output-buffer! op buffer)
        (let ([buffer0 (string-copy (textual-port-output-buffer op))]
              [index0 (textual-port-output-index op)]
              [size0 (textual-port-output-size op)]
              [count0 (textual-port-output-count op)])
          (display "yo" op)
          (set-textual-port-output-index! op 4)
          (display "!?" op)
          (list
            buffer
            (list buffer0 index0 size0 count0)
            (list
              (textual-port-output-buffer op)
              (textual-port-output-index op)
              (textual-port-output-size op)
              (textual-port-output-count op))))))
    '("yo$$!?$$"
      ("$$$$$$$$" 0 8 8)
      ("yo$$!?$$" 6 8 2)))
  (equal?
    (let-values ([(op get) (open-string-output-port)])
      (let ([buffer (make-string 8 #\$)])
        (set-textual-port-output-buffer! op buffer)
        (let ([buffer0 (string-copy (textual-port-output-buffer op))]
              [index0 (textual-port-output-index op)]
              [size0 (textual-port-output-size op)]
              [count0 (textual-port-output-count op)])
          (display "yo" op)
          (set-textual-port-output-size! op 4)
          (display "!?" op)
          (list
            buffer
            (list buffer0 index0 size0 count0)
            (list
              (textual-port-output-buffer op)
              (textual-port-output-index op)
              (textual-port-output-size op)
              (textual-port-output-count op))))))
    '("!?$$$$$$"
      ("$$$$$$$$" 0 8 8)
      ("!?$$$$$$" 2 4 2)))
  (error? ; not a textual output port
    (textual-port-output-buffer $tip))
  (error? ; not a textual output port
    (textual-port-output-buffer $bip))
  (error? ; not a textual output port
    (textual-port-output-buffer $bop))
  (error? ; not a textual output port
    (textual-port-output-buffer 75))
  (error? ; not a textual output port
    (textual-port-output-index $tip))
  (error? ; not a textual output port
    (textual-port-output-index $bip))
  (error? ; not a textual output port
    (textual-port-output-index $bop))
  (error? ; not a textual output port
    (textual-port-output-index 75))
  (error? ; not a textual output port
    (textual-port-output-size $tip))
  (error? ; not a textual output port
    (textual-port-output-size $bip))
  (error? ; not a textual output port
    (textual-port-output-size $bop))
  (error? ; not a textual output port
    (textual-port-output-size 75))
  (error? ; not a textual output port
    (textual-port-output-count $tip))
  (error? ; not a textual output port
    (textual-port-output-count $bip))
  (error? ; not a textual output port
    (textual-port-output-count $bop))
  (error? ; not a textual output port
    (textual-port-output-count 75))
  (error? ; not a textual output port
    (set-textual-port-output-buffer! $tip ""))
  (error? ; not a textual output port
    (set-textual-port-output-buffer! $bip ""))
  (error? ; not a textual output port
    (set-textual-port-output-buffer! $bop ""))
  (error? ; not a textual output port
    (set-textual-port-output-buffer! 75 ""))
  (error? ; not a textual output port
    (set-textual-port-output-index! $tip 0))
  (error? ; not a textual output port
    (set-textual-port-output-index! $bip 0))
  (error? ; not a textual output port
    (set-textual-port-output-index! $bop 0))
  (error? ; not a textual output port
    (set-textual-port-output-index! 75 0))
  (error? ; not a textual output port
    (set-textual-port-output-size! $tip 0))
  (error? ; not a textual output port
    (set-textual-port-output-size! $bip 0))
  (error? ; not a textual output port
    (set-textual-port-output-size! $bop 0))
  (error? ; not a textual output port
    (set-textual-port-output-size! 75 0))
  (error? ; not a string
    (set-textual-port-output-buffer! $top #vu8(1 2 3)))
  (error? ; not a string
    (set-textual-port-output-buffer! $top 0))
  (error? ; invalid index
    (set-textual-port-output-index! $top "hello"))
  (error? ; invalid index
    (set-textual-port-output-index! $top -1))
  (error? ; invalid index
    (set-textual-port-output-index! $top 6))
  (error? ; invalid size
    (set-textual-port-output-size! $top "hello"))
  (error? ; invalid size
    (set-textual-port-output-size! $top -1))
  (error? ; invalid size
    (set-textual-port-output-size! $top 6))
  ; binary input
  (equal?
    (let ([ip (open-bytevector-input-port (string->utf8 "hello"))])
      (let ([buffer0 (binary-port-input-buffer ip)]
            [index0 (binary-port-input-index ip)]
            [size0 (binary-port-input-size ip)]
            [count0 (binary-port-input-count ip)])
        (get-u8 ip)
        (list
          (list buffer0 index0 size0 count0)
          (list
            (binary-port-input-buffer ip)
            (binary-port-input-index ip)
            (binary-port-input-size ip)
            (binary-port-input-count ip)))))
    `((,(string->utf8 "hello") 0 5 5) (,(string->utf8 "hello") 1 5 4)))
  (equal?
    (let ([ip (open-bytevector-input-port (string->utf8 "hello"))])
      (let ([buffer0 (binary-port-input-buffer ip)]
            [index0 (binary-port-input-index ip)]
            [size0 (binary-port-input-size ip)]
            [count0 (binary-port-input-count ip)])
        (get-u8 ip)
        (set-binary-port-input-buffer! ip (string->utf8 "goodbye"))
        (get-u8 ip)
        (list
          (list buffer0 index0 size0 count0)
          (list
            (binary-port-input-buffer ip)
            (binary-port-input-index ip)
            (binary-port-input-size ip)
            (binary-port-input-count ip)))))
    `((,(string->utf8 "hello") 0 5 5) (,(string->utf8 "goodbye") 1 7 6)))
  (equal?
    (let ([ip (open-bytevector-input-port (string->utf8 "hello"))])
      (let ([buffer0 (binary-port-input-buffer ip)]
            [index0 (binary-port-input-index ip)]
            [size0 (binary-port-input-size ip)]
            [count0 (binary-port-input-count ip)])
        (get-u8 ip)
        (set-binary-port-input-size! ip 3)
        (get-u8 ip)
        (list
          (list buffer0 index0 size0 count0)
          (list
            (binary-port-input-buffer ip)
            (binary-port-input-index ip)
            (binary-port-input-size ip)
            (binary-port-input-count ip)))))
    `((,(string->utf8 "hello") 0 5 5) (,(string->utf8 "hello") 1 3 2)))
  (equal?
    (let ([ip (open-bytevector-input-port (string->utf8 "hello"))])
      (let ([buffer0 (binary-port-input-buffer ip)]
            [index0 (binary-port-input-index ip)]
            [size0 (binary-port-input-size ip)]
            [count0 (binary-port-input-count ip)])
        (get-u8 ip)
        (set-binary-port-input-index! ip 3)
        (get-u8 ip)
        (list
          (list buffer0 index0 size0 count0)
          (list
            (binary-port-input-buffer ip)
            (binary-port-input-index ip)
            (binary-port-input-size ip)
            (binary-port-input-count ip)))))
    `((,(string->utf8 "hello") 0 5 5) (,(string->utf8 "hello") 4 5 1)))
  (error? ; not a binary input port
    (binary-port-input-buffer $tip))
  (error? ; not a binary input port
    (binary-port-input-buffer $top))
  (error? ; not a binary input port
    (binary-port-input-buffer $bop))
  (error? ; not a binary input port
    (binary-port-input-buffer 75))
  (error? ; not a binary input port
    (binary-port-input-index $tip))
  (error? ; not a binary input port
    (binary-port-input-index $top))
  (error? ; not a binary input port
    (binary-port-input-index $bop))
  (error? ; not a binary input port
    (binary-port-input-index 75))
  (error? ; not a binary input port
    (binary-port-input-size $tip))
  (error? ; not a binary input port
    (binary-port-input-size $top))
  (error? ; not a binary input port
    (binary-port-input-size $bop))
  (error? ; not a binary input port
    (binary-port-input-size 75))
  (error? ; not a binary input port
    (binary-port-input-count $tip))
  (error? ; not a binary input port
    (binary-port-input-count $top))
  (error? ; not a binary input port
    (binary-port-input-count $bop))
  (error? ; not a binary input port
    (binary-port-input-count 75))
  (error? ; not a binary input port
    (set-binary-port-input-buffer! $tip ""))
  (error? ; not a binary input port
    (set-binary-port-input-buffer! $top ""))
  (error? ; not a binary input port
    (set-binary-port-input-buffer! $bop ""))
  (error? ; not a binary input port
    (set-binary-port-input-buffer! 75 ""))
  (error? ; not a binary input port
    (set-binary-port-input-index! $tip 0))
  (error? ; not a binary input port
    (set-binary-port-input-index! $top 0))
  (error? ; not a binary input port
    (set-binary-port-input-index! $bop 0))
  (error? ; not a binary input port
    (set-binary-port-input-index! 75 0))
  (error? ; not a binary input port
    (set-binary-port-input-size! $tip 0))
  (error? ; not a binary input port
    (set-binary-port-input-size! $top 0))
  (error? ; not a binary input port
    (set-binary-port-input-size! $bop 0))
  (error? ; not a binary input port
    (set-binary-port-input-size! 75 0))
  (error? ; not a bytevector
    (set-binary-port-input-buffer! $bip "hello"))
  (error? ; not a bytevector
    (set-binary-port-input-buffer! $bip 0))
  (error? ; invalid index
    (set-binary-port-input-index! $bip #vu8(1 2 3)))
  (error? ; invalid index
    (set-binary-port-input-index! $bip -1))
  (error? ; invalid index
    (set-binary-port-input-index! $bip 6))
  (error? ; invalid size
    (set-binary-port-input-size! $bip #vu8(1 2 3)))
  (error? ; invalid size
    (set-binary-port-input-size! $bip -1))
  (error? ; invalid size
    (set-binary-port-input-size! $bip 6))
  ; binary output
  (equal?
    (let-values ([(op get) (open-bytevector-output-port)])
      (let ([buffer (string->utf8 "hello")])
        (set-binary-port-output-buffer! op buffer)
        (let ([buffer0 (bytevector-copy (binary-port-output-buffer op))]
              [index0 (binary-port-output-index op)]
              [size0 (binary-port-output-size op)]
              [count0 (binary-port-output-count op)])
          (put-u8 op (char->integer #\j))
          (list
            buffer
            (list buffer0 index0 size0 count0)
            (list
              (binary-port-output-buffer op)
              (binary-port-output-index op)
              (binary-port-output-size op)
              (binary-port-output-count op))))))
    `(,(string->utf8 "jello")
      (,(string->utf8 "hello") 0 5 5)
      (,(string->utf8 "jello") 1 5 4)))
  (equal?
    (let-values ([(op get) (open-bytevector-output-port)])
      (let ([buffer (string->utf8 "hello")])
        (set-binary-port-output-buffer! op buffer)
        (let ([buffer0 (bytevector-copy (binary-port-output-buffer op))]
              [index0 (binary-port-output-index op)]
              [size0 (binary-port-output-size op)]
              [count0 (binary-port-output-count op)])
          (put-u8 op (char->integer #\j))
          (set-binary-port-output-buffer! op (bytevector 1 2 3 4 5 6))
          (put-u8 op 31)
          (list
            buffer
            (list buffer0 index0 size0 count0)
            (list
              (binary-port-output-buffer op)
              (binary-port-output-index op)
              (binary-port-output-size op)
              (binary-port-output-count op))))))
    `(,(string->utf8 "jello")
      (,(string->utf8 "hello") 0 5 5)
      (#vu8(31 2 3 4 5 6) 1 6 5)))
  (equal?
    (let-values ([(op get) (open-bytevector-output-port)])
      (let ([buffer (string->utf8 "hello")])
        (set-binary-port-output-buffer! op buffer)
        (let ([buffer0 (bytevector-copy (binary-port-output-buffer op))]
              [index0 (binary-port-output-index op)]
              [size0 (binary-port-output-size op)]
              [count0 (binary-port-output-count op)])
          (put-u8 op (char->integer #\j))
          (set-binary-port-output-index! op 4)
          (put-u8 op (char->integer #\y))
          (list
            buffer
            (list buffer0 index0 size0 count0)
            (list
              (binary-port-output-buffer op)
              (binary-port-output-index op)
              (binary-port-output-size op)
              (binary-port-output-count op))))))
    `(,(string->utf8 "jelly")
      (,(string->utf8 "hello") 0 5 5)
      (,(string->utf8 "jelly") 5 5 0)))
  (equal?
    (let-values ([(op get) (open-bytevector-output-port)])
      (let ([buffer (string->utf8 "hello")])
        (set-binary-port-output-buffer! op buffer)
        (let ([buffer0 (bytevector-copy (binary-port-output-buffer op))]
              [index0 (binary-port-output-index op)]
              [size0 (binary-port-output-size op)]
              [count0 (binary-port-output-count op)])
          (put-u8 op (char->integer #\j))
          (set-binary-port-output-size! op 4)
          (put-u8 op (char->integer #\b))
          (list
            buffer
            (list buffer0 index0 size0 count0)
            (list
              (binary-port-output-buffer op)
              (binary-port-output-index op)
              (binary-port-output-size op)
              (binary-port-output-count op))))))
    `(,(string->utf8 "bello")
      (,(string->utf8 "hello") 0 5 5)
      (,(string->utf8 "bello") 1 4 3)))
  (error? ; not a binary output port
    (binary-port-output-buffer $tip))
  (error? ; not a binary output port
    (binary-port-output-buffer $top))
  (error? ; not a binary output port
    (binary-port-output-buffer $bip))
  (error? ; not a binary output port
    (binary-port-output-buffer 75))
  (error? ; not a binary output port
    (binary-port-output-index $tip))
  (error? ; not a binary output port
    (binary-port-output-index $top))
  (error? ; not a binary output port
    (binary-port-output-index $bip))
  (error? ; not a binary output port
    (binary-port-output-index 75))
  (error? ; not a binary output port
    (binary-port-output-size $tip))
  (error? ; not a binary output port
    (binary-port-output-size $top))
  (error? ; not a binary output port
    (binary-port-output-size $bip))
  (error? ; not a binary output port
    (binary-port-output-size 75))
  (error? ; not a binary output port
    (binary-port-output-count $tip))
  (error? ; not a binary output port
    (binary-port-output-count $top))
  (error? ; not a binary output port
    (binary-port-output-count $bip))
  (error? ; not a binary output port
    (binary-port-output-count 75))
  (error? ; not a binary output port
    (set-binary-port-output-buffer! $tip ""))
  (error? ; not a binary output port
    (set-binary-port-output-buffer! $top ""))
  (error? ; not a binary output port
    (set-binary-port-output-buffer! $bip ""))
  (error? ; not a binary output port
    (set-binary-port-output-buffer! 75 ""))
  (error? ; not a binary output port
    (set-binary-port-output-index! $tip 0))
  (error? ; not a binary output port
    (set-binary-port-output-index! $top 0))
  (error? ; not a binary output port
    (set-binary-port-output-index! $bip 0))
  (error? ; not a binary output port
    (set-binary-port-output-index! 75 0))
  (error? ; not a binary output port
    (set-binary-port-output-size! $tip 0))
  (error? ; not a binary output port
    (set-binary-port-output-size! $top 0))
  (error? ; not a binary output port
    (set-binary-port-output-size! $bip 0))
  (error? ; not a binary output port
    (set-binary-port-output-size! 75 0))
  (error? ; not a string
    (set-binary-port-output-buffer! $bop "hello"))
  (error? ; not a string
    (set-binary-port-output-buffer! $bop 0))
  (error? ; invalid index
    (set-binary-port-output-index! $bop #vu8(1 2 3)))
  (error? ; invalid index
    (set-binary-port-output-index! $bop -1))
  (error? ; invalid index
    (set-binary-port-output-index! $bop 6))
  (error? ; invalid size
    (set-binary-port-output-size! $bop #vu8(1 2 3)))
  (error? ; invalid size
    (set-binary-port-output-size! $bop -1))
  (error? ; invalid size
    (set-binary-port-output-size! $bop 6))
  (begin
    (define $handler-standin (#%$port-handler (open-string-input-port "hi")))
    #t)
  (let ([name "foo"] [ib "hey!"])
    (let ([p (#%$make-textual-input-port name $handler-standin ib)])
      (and (port? p)
           (textual-port? p)
           (not (binary-port? p))
           (input-port? p)
           (not (output-port? p))
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) #f)
           (eq? (textual-port-input-buffer p) ib)
           (eqv? (textual-port-input-size p) (string-length ib))
           (eqv? (textual-port-input-index p) 0)
           (eqv? (textual-port-input-count p) (string-length ib)))))
  (let ([name "foo"] [info "info"] [ib "hey!"])
    (let ([p (#%$make-textual-input-port name $handler-standin ib info)])
      (and (port? p)
           (textual-port? p)
           (not (binary-port? p))
           (input-port? p)
           (not (output-port? p))
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) info)
           (eq? (textual-port-input-buffer p) ib)
           (eqv? (textual-port-input-size p) (string-length ib))
           (eqv? (textual-port-input-index p) 0)
           (eqv? (textual-port-input-count p) (string-length ib)))))
  (let ([name "foo"] [ob "hey!"])
    (let ([p (#%$make-textual-output-port name $handler-standin ob)])
      (and (port? p)
           (textual-port? p)
           (not (binary-port? p))
           (not (input-port? p))
           (output-port? p)
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) #f)
           (eq? (textual-port-output-buffer p) ob)
           (eqv? (textual-port-output-size p) (string-length ob))
           (eqv? (textual-port-output-index p) 0)
           (eqv? (textual-port-output-count p) (string-length ob)))))
  (let ([name "foo"] [info "info"] [ob "hey!"])
    (let ([p (#%$make-textual-output-port name $handler-standin ob info)])
      (and (port? p)
           (textual-port? p)
           (not (binary-port? p))
           (not (input-port? p))
           (output-port? p)
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) info)
           (eq? (textual-port-output-buffer p) ob)
           (eqv? (textual-port-output-size p) (string-length ob))
           (eqv? (textual-port-output-index p) 0)
           (eqv? (textual-port-output-count p) (string-length ob)))))
  (let ([name "foo"] [ib "hay!"] [ob "hey!"])
    (let ([p (#%$make-textual-input/output-port name $handler-standin ib ob)])
      (and (port? p)
           (textual-port? p)
           (not (binary-port? p))
           (input-port? p)
           (output-port? p)
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) #f)
           (eq? (textual-port-input-buffer p) ib)
           (eqv? (textual-port-input-size p) (string-length ib))
           (eqv? (textual-port-input-index p) 0)
           (eqv? (textual-port-input-count p) (string-length ib))
           (eq? (textual-port-output-buffer p) ob)
           (eqv? (textual-port-output-size p) (string-length ob))
           (eqv? (textual-port-output-index p) 0)
           (eqv? (textual-port-output-count p) (string-length ob)))))
  (let ([name "foo"] [info "info"] [ib "hay!"] [ob "hey!"])
    (let ([p (#%$make-textual-input/output-port name $handler-standin ib ob info)])
      (and (port? p)
           (textual-port? p)
           (not (binary-port? p))
           (input-port? p)
           (output-port? p)
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) info)
           (eq? (textual-port-input-buffer p) ib)
           (eqv? (textual-port-input-size p) (string-length ib))
           (eqv? (textual-port-input-index p) 0)
           (eqv? (textual-port-input-count p) (string-length ib))
           (eq? (textual-port-output-buffer p) ob)
           (eqv? (textual-port-output-size p) (string-length ob))
           (eqv? (textual-port-output-index p) 0)
           (eqv? (textual-port-output-count p) (string-length ob)))))
  (let ([name "foo"] [ib #vu8(1 2 3 4)])
    (let ([p (#%$make-binary-input-port name $handler-standin ib)])
      (and (port? p)
           (not (textual-port? p))
           (binary-port? p)
           (input-port? p)
           (not (output-port? p))
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) #f)
           (eq? (binary-port-input-buffer p) ib)
           (eqv? (binary-port-input-size p) (bytevector-length ib))
           (eqv? (binary-port-input-index p) 0)
           (eqv? (binary-port-input-count p) (bytevector-length ib)))))
  (let ([name "foo"] [info "info"] [ib #vu8(1 2 3 4)])
    (let ([p (#%$make-binary-input-port name $handler-standin ib info)])
      (and (port? p)
           (not (textual-port? p))
           (binary-port? p)
           (input-port? p)
           (not (output-port? p))
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) info)
           (eq? (binary-port-input-buffer p) ib)
           (eqv? (binary-port-input-size p) (bytevector-length ib))
           (eqv? (binary-port-input-index p) 0)
           (eqv? (binary-port-input-count p) (bytevector-length ib)))))
  (let ([name "foo"] [ob #vu8(1 2 3 4)])
    (let ([p (#%$make-binary-output-port name $handler-standin ob)])
      (and (port? p)
           (not (textual-port? p))
           (binary-port? p)
           (not (input-port? p))
           (output-port? p)
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) #f)
           (eq? (binary-port-output-buffer p) ob)
           (eqv? (binary-port-output-size p) (bytevector-length ob))
           (eqv? (binary-port-output-index p) 0)
           (eqv? (binary-port-output-count p) (bytevector-length ob)))))
  (let ([name "foo"] [info "info"] [ob #vu8(1 2 3 4)])
    (let ([p (#%$make-binary-output-port name $handler-standin ob info)])
      (and (port? p)
           (not (textual-port? p))
           (binary-port? p)
           (not (input-port? p))
           (output-port? p)
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) info)
           (eq? (binary-port-output-buffer p) ob)
           (eqv? (binary-port-output-size p) (bytevector-length ob))
           (eqv? (binary-port-output-index p) 0)
           (eqv? (binary-port-output-count p) (bytevector-length ob)))))
  (let ([name "foo"] [ib #vu8(4 3 2 1)] [ob #vu8(1 2 3 4)])
    (let ([p (#%$make-binary-input/output-port name $handler-standin ib ob)])
      (and (port? p)
           (not (textual-port? p))
           (binary-port? p)
           (input-port? p)
           (output-port? p)
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) #f)
           (eq? (binary-port-input-buffer p) ib)
           (eqv? (binary-port-input-size p) (bytevector-length ib))
           (eqv? (binary-port-input-index p) 0)
           (eqv? (binary-port-input-count p) (bytevector-length ib))
           (eq? (binary-port-output-buffer p) ob)
           (eqv? (binary-port-output-size p) (bytevector-length ob))
           (eqv? (binary-port-output-index p) 0)
           (eqv? (binary-port-output-count p) (bytevector-length ob)))))
  (let ([name "foo"] [info "info"] [ib #vu8(4 3 2 1)] [ob #vu8(1 2 3 4)])
    (let ([p (#%$make-binary-input/output-port name $handler-standin ib ob info)])
      (and (port? p)
           (not (textual-port? p))
           (binary-port? p)
           (input-port? p)
           (output-port? p)
           (eq? (port-name p) name)
           (eq? (#%$port-handler p) $handler-standin)
           (eq? (#%$port-info p) info)
           (eq? (binary-port-input-buffer p) ib)
           (eqv? (binary-port-input-size p) (bytevector-length ib))
           (eqv? (binary-port-input-index p) 0)
           (eqv? (binary-port-input-count p) (bytevector-length ib))
           (eq? (binary-port-output-buffer p) ob)
           (eqv? (binary-port-output-size p) (bytevector-length ob))
           (eqv? (binary-port-output-index p) 0)
           (eqv? (binary-port-output-count p) (bytevector-length ob)))))
 )

(mat file-buffer-size
  (let ([x (file-buffer-size)])
    (and (fixnum? x) (> x 0)))
  (error? (file-buffer-size 1024 15))
  (error? (file-buffer-size 'shoe))
  (error? (file-buffer-size 0))
  (error? (file-buffer-size -15))
  (error? (file-buffer-size (+ (most-positive-fixnum) 1)))
  (error? (file-buffer-size 1024.0))
  (parameterize ([file-buffer-size (* (file-buffer-size) 2)])
    (let ([ip (open-file-input-port prettytest.ss)])
      (let ([n (bytevector-length (binary-port-input-buffer ip))])
        (close-input-port ip)
        (eqv? n (file-buffer-size)))))
)

(mat custom-port-buffer-size
  (let ([x (custom-port-buffer-size)])
    (and (fixnum? x) (> x 0)))
  (error? (custom-port-buffer-size 1024 15))
  (error? (custom-port-buffer-size 'shoe))
  (error? (custom-port-buffer-size 0))
  (error? (custom-port-buffer-size -15))
  (error? (custom-port-buffer-size (+ (most-positive-fixnum) 1)))
  (error? (custom-port-buffer-size 1024.0))
  (parameterize ([custom-port-buffer-size (* (custom-port-buffer-size) 2)])
    (let ([q #f])
      (let ([ip (make-custom-textual-input-port "foo"
                  (lambda (str s c) (set! q c) 0)
                  #f #f #f)])
        (read-char ip)
        (= q (custom-port-buffer-size)))))
)

(mat compress-parameters
  (error? ; unsupported format
    (compress-format 'foo))
  (error? ; unsupported format
    (compress-format "gzip"))
  (eq? (compress-format) 'lz4)
  (eq? (parameterize ([compress-format 'gzip]) (compress-format)) 'gzip)
  (eq? (parameterize ([compress-format 'lz4]) (compress-format)) 'lz4)
  (error? ; unsupported level
    (compress-level 'foo))
  (error? ; unsupported level
    (compress-level 1))
  (eq? (compress-level) 'medium)
  (eq? (parameterize ([compress-level 'low]) (compress-level)) 'low)
  (eq? (parameterize ([compress-level 'medium]) (compress-level)) 'medium)
  (eq? (parameterize ([compress-level 'high]) (compress-level)) 'high)
  (eq? (parameterize ([compress-level 'maximum]) (compress-level)) 'maximum)
  (begin
    (define (fnlength ifn) (call-with-port (open-file-input-port ifn) port-length))
    (define (compress-file ifn ofn fmt lvl)
      (call-with-port (open-file-input-port ifn)
        (lambda (ip)
          (call-with-port (parameterize ([compress-format fmt] [compress-level lvl])
                            (open-file-output-port ofn (file-options compressed replace)))
            (lambda (op) (put-bytevector op (get-bytevector-all ip))))))
      (fnlength ofn))
    (define (compress-file-test fmt)
      (let ([orig (fnlength prettytest.ss)]
            [low (compress-file prettytest.ss "testfile.ss" fmt 'low)]
            [medium (compress-file prettytest.ss "testfile.ss" fmt 'medium)]
            [high (compress-file prettytest.ss "testfile.ss" fmt 'high)]
            [maximum (compress-file prettytest.ss "testfile.ss" fmt 'maximum)])
        (define-syntax test1
          (syntax-rules ()
            [(_ level)
             (unless (< level orig) (errorf #f "~s ~s did not compress" fmt 'level))]))
        (define-syntax test2
          (syntax-rules ()
            [(_ level1 level2)
             (unless (<= level2 level1) (errorf #f "~s ~s did worse than ~s" fmt 'level2 'level1))]))
        (test1 low)
        (test1 medium)
        (test1 high)
        (test1 maximum)
        (test2 low medium)
        (test2 medium high)
        (test2 high maximum)
        (unless (< maximum low) (errorf #f "~s maximum didn't do better than low" fmt))))
    (compress-file-test 'lz4)
    (compress-file-test 'gzip)
    #t)
)

(mat compression
  (parameters [compress-format 'gzip 'lz4] [compress-level 'low 'medium 'high 'maximum])
  (and (memq (compress-format) '(gzip lz4)) #t)
  (and (memq (compress-level) '(low medium high maximum)) #t)
  (let ()
    (define cp
      (lambda (src dst)
        (define buf-size 4096)
        (let ([buf (make-bytevector buf-size)])
          (call-with-port dst
            (lambda (op)
              (call-with-port src
                (lambda (ip)
                  (let loop ()
                    (let ([n (get-bytevector-n! ip buf 0 buf-size)])
                      (unless (eof-object? n)
                        (put-bytevector op buf 0 n)
                        (loop)))))))))))

    (define cmp
      (lambda (src1 src2)
        (define buf-size 4096)
        (let ([buf1 (make-bytevector buf-size)]
              [buf2 (make-bytevector buf-size)])
          (call-with-port src1
            (lambda (ip1)
              (call-with-port src2
                (lambda (ip2)
                  (let loop ()
                    (let ([n1 (get-bytevector-n! ip1 buf1 0 buf-size)]
                          [n2 (get-bytevector-n! ip2 buf2 0 buf-size)])
                      (if (eof-object? n1)
                          (eof-object? n2)
                          (and (= n1 n2)
                               (let test ([i 0])
                                 (or (= i n1)
                                     (and (= (bytevector-u8-ref buf1 i)
                                             (bytevector-u8-ref buf2 i))
                                          (test (+ 1 i)))))
                               (loop))))))))))))
    (and
     (cmp (open-file-input-port prettytest.ss)
          (open-file-input-port prettytest.ss))
     (cmp (open-file-input-port prettytest.ss (file-options compressed))
          (open-file-input-port prettytest.ss))
     (cmp (open-file-input-port prettytest.ss)
          (open-file-input-port prettytest.ss (file-options compressed)))
     (cmp (open-file-input-port prettytest.ss (file-options compressed))
          (open-file-input-port prettytest.ss (file-options compressed)))
     (begin
       (cp (open-file-input-port prettytest.ss)
           (open-file-output-port "testfile.ss" (file-options replace compressed)))
       #t)
     (cmp (open-file-input-port "testfile.ss" (file-options compressed))
          (open-file-input-port prettytest.ss))
     (not (cmp (open-file-input-port "testfile.ss")
               (open-file-input-port prettytest.ss)))
     (begin
       (cp (open-file-input-port prettytest.ss)
           (open-file-output-port "testfile.ss" (file-options no-fail no-truncate append compressed)))
       #t)
     (not (cmp (open-file-input-port "testfile.ss" (file-options compressed))
               (open-file-input-port prettytest.ss)))))
  ; test workaround for bogus gzclose error return for empty input files
  (and
   (eqv? (call-with-port
          (open-file-output-port "testfile.ss" (file-options replace))
          (lambda (x) (void)))
         (void))
   (eof-object? (call-with-port
                 (open-file-input-port "testfile.ss" (file-options compressed))
                 get-u8)))
  (begin
    (let ([op (open-file-output-port "testfile.ss" (file-options replace))])
      (put-bytevector op #vu8(#x23 #x88 #x09 #x72 #xf3 #x72))
      (port-file-compressed! op)
      (put-bytevector op #vu8(#x93 #x21 #x88 #xe7 #x67))
      (let ([op (transcoded-port op (native-transcoder))])
        (display "hello!\n" op)
        (close-port op)))
    #t)
  (equal?
    (let ([ip (open-file-input-port "testfile.ss")])
      (let ([bv1 (get-bytevector-n ip 6)])
        (port-file-compressed! ip)
        (let ([bv2 (get-bytevector-n ip 5)])
          (let ([ip (transcoded-port ip (native-transcoder))])
            (let ([s (get-string-all ip)])
              (close-port ip)
              (list bv1 bv2 s))))))
    '(#vu8(#x23 #x88 #x09 #x72 #xf3 #x72)
      #vu8(#x93 #x21 #x88 #xe7 #x67)
      "hello!\n"))
  (not
    (equal?
      (let ([ip (open-file-input-port "testfile.ss")])
        (let ([bv1 (get-bytevector-n ip 6)])
          (let ([bv2 (get-bytevector-n ip 5)])
            (close-port ip)
            (list bv1 bv2))))
      '(#vu8(#x23 #x88 #x09 #x72 #xf3 #x72)
        #vu8(#x93 #x21 #x88 #xe7 #x67))))
  (begin
    (let ([op (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode block) (native-transcoder))])
      (put-string op "uncompressed string")
      (port-file-compressed! op)
      (put-string op "compressed string")
      (close-port op))
    #t)
  (equal?
    (let ([ip (open-file-input-port "testfile.ss" (file-options) (buffer-mode block) (native-transcoder))])
      (let ([s1 (get-string-n ip (string-length "uncompressed string"))])
        (port-file-compressed! ip)
        (let ([s2 (get-string-all ip)])
          (close-port ip)
          (list s1 s2))))
    '("uncompressed string" "compressed string"))
  (error? ; not a file port
    (call-with-string-output-port port-file-compressed!))
  (error? ; input/output ports aren't supported
    (let ([iop (open-file-input/output-port "testfile.ss" (file-options replace))])
      (guard (c [else (close-port iop) (raise c)])
        (port-file-compressed! iop))))
  (begin
    (let ([op (open-file-output-port "testfile.ss" (file-options compressed replace) (buffer-mode block) (native-transcoder))])
      (port-file-compressed! op)
      (put-string op "compressed string")
      (close-port op))
    #t)
  (equal?
    (let ([ip (open-file-input-port "testfile.ss" (file-options compressed) (buffer-mode block) (native-transcoder))])
      (port-file-compressed! ip)
      (let ([s (get-string-all ip)])
        (close-port ip)
        s))
    '"compressed string")
)

(mat bytevector-input-port
  (error? ; incorrect number of arguments
    (open-bytevector-input-port))
  (error? ; not a bytevector
    (open-bytevector-input-port '#(1 2 3 4)))
  (error? ; none is not a transcoder
    (open-bytevector-input-port #vu8(1 2 3 4) 'none))
  (error? ; incorrect number of arguments
    (open-bytevector-input-port #vu8(1 2 3 4) #f 'none))
  (let ()
    (define x (open-bytevector-input-port #vu8(1 2 3 4)))
    (and (eq? (get-u8 x) 1)
         (eq? (get-u8 x) 2)
         (eq? (get-u8 x) 3)
         (eq? (get-u8 x) 4)
         (eq? (get-u8 x) (eof-object))))
  (let ()
    (define x (open-bytevector-input-port #vu8(1 2 3 4)))
    (and (port-has-port-position? x)
         (eq? (port-position x) 0)
         (eq? (get-u8 x) 1)
         (eq? (port-position x) 1)
         (eq? (get-u8 x) 2)
         (eq? (port-position x) 2)
         (eq? (get-u8 x) 3)
         (eq? (port-position x) 3)
         (eq? (get-u8 x) 4)
         (eq? (port-position x) 4)
         (eq? (get-u8 x) #!eof)
         (eq? (port-position x) 4)
         (eq? (get-u8 x) #!eof)
         (eq? (port-position x) 4)
         (eq? (get-u8 x) #!eof)
         (eq? (port-position x) 4)))
  (let ()
    (define x (open-bytevector-input-port #vu8(1 2 3 4)))
    (and (port-has-set-port-position!? x)
         (eq? (port-position x) 0)
         (eq? (get-u8 x) 1)
         (eq? (port-position x) 1)
         (eq? (get-u8 x) 2)
         (eq? (port-position x) 2)
         (begin (set-port-position! x 0) #t)
         (eq? (get-u8 x) 1)
         (begin (set-port-position! x 4) #t)
         (eq? (get-u8 x) #!eof)))
  (error? (set-port-position! (open-bytevector-input-port #vu8(1 2 3 4)) -1))
  (error? (set-port-position! (open-bytevector-input-port #vu8(1 2 3 4)) 5))

  (let ()
    (define x (open-bytevector-input-port #vu8(1 2 3 4)))
    (and (eq? (lookahead-u8 x) 1)
         (eq? (lookahead-u8 x) 1)
         (eq? (lookahead-u8 x) 1)
         (eq? (get-u8 x) 1)
         (eq? (lookahead-u8 x) 2)
         (eq? (get-u8 x) 2)
         (eq? (lookahead-u8 x) 3)
         (eq? (get-u8 x) 3)
         (eq? (lookahead-u8 x) 4)
         (eq? (get-u8 x) 4)
         (eq? (lookahead-u8 x) #!eof)
         (eq? (get-u8 x) #!eof)
         (eq? (lookahead-u8 x) #!eof)
         (eq? (get-u8 x) #!eof)))
  (eq? (buffer-mode none) 'none)
  (eq? (buffer-mode line) 'line)
  (eq? (buffer-mode block) 'block)
  (error? (buffer-mode bar))
  (error? (buffer-mode 'none))
  (eq? (buffer-mode? 'none) #t)
  (eq? (buffer-mode? 'line) #t)
  (eq? (buffer-mode? 'block) #t)
  (eq? (buffer-mode? 'foo) #f)
)

(mat bytevector-output-port
  (error? ; not a transcoder
    (open-bytevector-output-port 'oops))
  (error? ; incorrect number of arguments
    (open-bytevector-output-port #f 'none))
)

(mat custom-binary-ports
  (begin
    (define $cp-ip
      (let ([pos 0])
        (make-custom-binary-input-port "foo"
          (lambda (bv s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda () pos)
          (lambda (x) (set! pos x))
          #f)))
    #t)
  (eq? (port-position $cp-ip) 0)
  (error? ; cannot unget
    (unget-u8 $cp-ip 255))
  (begin (unget-u8 $cp-ip (eof-object)) #t)
  (port-eof? $cp-ip)
  (eof-object? (lookahead-u8 $cp-ip))
  (eof-object? (get-u8 $cp-ip))
  (equal?
    (get-bytevector-n $cp-ip 10)
    #vu8(0 1 2 3 4 5 6 7 8 9))
  (eqv? (port-position $cp-ip) 10)
  (eqv? (get-u8 $cp-ip) 10)
  (begin (set-port-position! $cp-ip 256000) #t)
  (eqv? (get-u8 $cp-ip) 0)
  (eqv? (port-position $cp-ip) 256001)
  (error? ; not a binary output port
    (put-u8 $cp-ip 255))
  (not (port-has-port-length? $cp-ip))
  (not (port-has-set-port-length!? $cp-ip))
  (not (port-has-port-nonblocking?? $cp-ip))
  (not (port-has-set-port-nonblocking!? $cp-ip))
  (error? ; not supported
    (port-length $cp-ip))
  (error? ; not supported
    (set-port-length! $cp-ip 50))
  (error? ; not supported
    (port-nonblocking? $cp-ip))
  (error? ; not supported
    (set-port-nonblocking! $cp-ip #t))
  (error? ; not supported
    (set-port-nonblocking! $cp-ip #f))
  (begin
    (define $cp-op
      (let ([pos 0])
        (make-custom-binary-output-port "foo"
          (lambda (bv s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          (lambda () pos)
          (lambda (x) (set! pos x))
          (lambda () (printf "closed\n")))))
    #t)
  (eq? (port-position $cp-op) 0)
  (error? ; not a binary input port
    (unget-u8 $cp-op 255))
  (not (port-has-port-length? $cp-op))
  (not (port-has-set-port-length!? $cp-op))
  (not (port-has-port-nonblocking?? $cp-op))
  (not (port-has-set-port-nonblocking!? $cp-op))
  (error? ; not supported
    (port-length $cp-op))
  (error? ; not supported
    (set-port-length! $cp-op 50))
  (error? ; not supported
    (port-nonblocking? $cp-op))
  (error? ; not supported
    (set-port-nonblocking! $cp-op #t))
  (error? ; not supported
    (set-port-nonblocking! $cp-op #f))
  (begin (put-u8 $cp-op 255) #t)
  (eqv? (port-position $cp-op) 1)
  (begin (set-port-position! $cp-op 17) #t)
  (equal?
    (with-output-to-string
      (lambda ()
        (put-bytevector $cp-op #vu8(17 18 19 20))
        (put-bytevector $cp-op #vu8(20 21 22 23 24 25) 1)
        (put-bytevector $cp-op #vu8(24 25 26 27 28 29) 1 4)))
    "")
  (equal? ; in our current implementation...
    (with-output-to-string
      (lambda ()
        (printf "pos = ~s\n" (port-position $cp-op))))
    "pos = 30\n")
  (equal? ; ... actual flush won't happen until here
    (with-output-to-string
      (lambda ()
        (r6rs:flush-output-port $cp-op)))
    "write 13\n")
  (equal?
    (with-output-to-string
      (lambda ()
        (printf "pos = ~s\n" (port-position $cp-op))))
    "pos = 30\n")
  (equal?
    (with-output-to-string
      (lambda ()
        (put-bytevector $cp-op #vu8(17 18 19 20))
        (put-bytevector $cp-op #vu8(20 21 22 23 24 25) 1)
        (put-bytevector $cp-op #vu8(24 25 26 27 28 29) 1 4)))
    "")
  (equal?
    (with-output-to-string
      (lambda ()
        (close-port $cp-op)))
    "write 13\nclosed\n")
  (error? ; closed
    (put-u8 $cp-op 0))
  (error? ; closed
    (put-bytevector $cp-op #vu8(3)))
  (error? ; closed
    (r6rs:flush-output-port $cp-op))
  (begin
    (define $cp-iop
      (let ([pos 0])
        (make-custom-binary-input/output-port "foo"
          (lambda (bv s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda (bv s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          (lambda () pos)
          (lambda (x) (set! pos x))
          (lambda () (printf "closed\n")))))
    #t)
  (eq? (port-position $cp-iop) 0)
  (error? ; cannot unget
    (unget-u8 $cp-iop 255))
  (begin (unget-u8 $cp-iop (eof-object)) #t)
  (port-eof? $cp-iop)
  (eof-object? (lookahead-u8 $cp-iop))
  (eof-object? (get-u8 $cp-iop))
  (equal?
    (get-bytevector-n $cp-iop 10)
    #vu8(0 1 2 3 4 5 6 7 8 9))
  (eqv? (port-position $cp-iop) 10)
  (eqv? (lookahead-u8 $cp-iop) 10)
  (eqv? (get-u8 $cp-iop) 10)
  (begin (set-port-position! $cp-iop 256000) #t)
  (eqv? (get-u8 $cp-iop) 0)
  (eqv? (port-position $cp-iop) 256001)
  (not (port-has-port-length? $cp-iop))
  (not (port-has-set-port-length!? $cp-iop))
  (not (port-has-port-nonblocking?? $cp-iop))
  (not (port-has-set-port-nonblocking!? $cp-iop))
  (error? ; not supported
    (port-length $cp-iop))
  (error? ; not supported
    (set-port-length! $cp-iop 50))
  (error? ; not supported
    (port-nonblocking? $cp-iop))
  (error? ; not supported
    (set-port-nonblocking! $cp-iop #t))
  (error? ; not supported
    (set-port-nonblocking! $cp-iop #f))
  (begin (put-u8 $cp-iop 255) #t)
  (eqv? (port-position $cp-iop) 256002)
  (begin (set-port-position! $cp-iop 17) #t)
  (equal?
    (with-output-to-string
      (lambda ()
        (put-bytevector $cp-iop #vu8(17 18 19 20))
        (put-bytevector $cp-iop #vu8(20 21 22 23 24 25) 1)
        (put-bytevector $cp-iop #vu8(24 25 26 27 28 29) 1 4)))
    "")
  (equal? ; in our current implementation...
    (with-output-to-string
      (lambda ()
        (printf "pos = ~s\n" (port-position $cp-iop))))
    "pos = 30\n")
  (equal? ; ... actual flush won't happen until here
    (with-output-to-string
      (lambda ()
        (r6rs:flush-output-port $cp-iop)))
    "write 13\n")
  (equal?
    (with-output-to-string
      (lambda ()
        (printf "pos = ~s\n" (port-position $cp-iop))))
    "pos = 30\n")
  (equal?
    (with-output-to-string
      (lambda ()
        (put-bytevector $cp-iop #vu8(17 18 19 20))
        (put-bytevector $cp-iop #vu8(20 21 22 23 24 25) 1)
        (put-bytevector $cp-iop #vu8(24 25 26 27 28 29) 1 4)))
    "")
  (equal?
    (with-output-to-string
      (lambda ()
        (close-port $cp-iop)))
    "write 13\nclosed\n")
  (error? ; closed
    (put-u8 $cp-iop 0))
  (error? ; closed
    (put-bytevector $cp-iop #vu8(3)))
  (error? ; closed
    (r6rs:flush-output-port $cp-iop))

  (begin
    (define $cp-iop
      (let ([pos 0])
        (make-custom-binary-input/output-port "foo"
          (lambda (bv s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda (bv s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          #f
          (lambda (x) (set! pos x))
          (lambda () (printf "closed\n")))))
    #t)
  (not (port-has-port-position? $cp-iop))
  (error? ; operation not supported
    (port-position $cp-iop))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-u8 $cp-iop 255))
    #t)
  (eqv? (get-u8 $cp-iop) 1)
  (custom-port-warning? ; can't determine position for write
    (put-u8 $cp-iop 255))
  (begin (set-port-position! $cp-iop 50) #t)
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-u8 $cp-iop 255))
    #t)
  (eqv? (get-u8 $cp-iop) 51)
  (custom-port-warning? ; can't determine position for write
    (put-bytevector $cp-iop #vu8(17)))

  (begin
    (define $cp-iop
      (let ([pos 0])
        (make-custom-binary-input/output-port "foo"
          (lambda (bv s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda (bv s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          (lambda () pos)
          #f
          (lambda () (printf "closed\n")))))
    #t)
  (not (port-has-set-port-position!? $cp-iop))
  (error? ; operation not supported
    (set-port-position! $cp-iop 3))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-u8 $cp-iop 255))
    #t)
  (eqv? (get-u8 $cp-iop) 1)
  (custom-port-warning? ; can't set position for write
   ; convoluted because we want warning to return normally so that operation
   ; is completed
    (let ([hit? #f])
      (with-exception-handler
        (lambda (c) (if (warning? c) (set! hit? c) (raise c)))
        (lambda () (put-u8 $cp-iop 255)))
      (when hit? (raise hit?))))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-u8 $cp-iop 255))
    #t)
  (begin (get-u8 $cp-iop) #t) ; position undefined, so value undefined
  (custom-port-warning? ; can't set position for write
    (put-bytevector $cp-iop #vu8(17)))

  (begin
    (define $cp-iop
      (let ([pos 0])
        (make-custom-binary-input/output-port "foo"
          (lambda (bv s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (bytevector-u8-set! bv i (modulo (+ pos i) 256))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda (bv s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          #f
          #f
          (lambda () (printf "closed\n")))))
    #t)
  (not (port-has-port-position? $cp-iop))
  (error? ; operation not supported
    (port-position $cp-iop))
  (not (port-has-set-port-position!? $cp-iop))
  (error? ; operation not supported
    (set-port-position! $cp-iop 3))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-u8 $cp-iop 255))
    #t)
  (eqv? (get-u8 $cp-iop) 1)
  (custom-port-warning? ; can't determine position for write
   ; convoluted because we want warning to return normally so that operation
   ; is completed
    (let ([hit? #f])
      (with-exception-handler
        (lambda (c) (if (warning? c) (set! hit? c) (raise c)))
        (lambda () (put-u8 $cp-iop 255)))
      (when hit? (raise hit?))))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-u8 $cp-iop 255))
    #t)
  (begin (get-u8 $cp-iop) #t) ; position undefined, so value undefined
  (custom-port-warning? ; can't determine position for write
    (put-bytevector $cp-iop #vu8(17)))
)

(mat custom-textual-ports
  (begin
    (define $cp-ip
      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
        (make-custom-textual-input-port "foo"
          (lambda (str s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda () pos)
          (lambda (x) (set! pos x))
          #f)))
    #t)
  (eq? (port-position $cp-ip) 0)
  (error? ; cannot unget
    (unget-char $cp-ip #\q))
  (begin (unget-char $cp-ip (eof-object)) #t)
  (port-eof? $cp-ip)
  (eof-object? (lookahead-char $cp-ip))
  (eof-object? (get-char $cp-ip))
  (equal?
    (get-string-n $cp-ip 10)
    "0123456789")
  (eqv? (port-position $cp-ip) 10)
  (eqv? (get-char $cp-ip) #\a)
  (begin (set-port-position! $cp-ip 36000) #t)
  (eqv? (get-char $cp-ip) #\0)
  (custom-port-warning? (port-position $cp-ip))
  (error? ; not a textual output port
    (put-char $cp-ip #\a))
  (not (port-has-port-length? $cp-ip))
  (not (port-has-set-port-length!? $cp-ip))
  (not (port-has-port-nonblocking?? $cp-ip))
  (not (port-has-set-port-nonblocking!? $cp-ip))
  (error? ; not supported
    (port-length $cp-ip))
  (error? ; not supported
    (set-port-length! $cp-ip 50))
  (error? ; not supported
    (port-nonblocking? $cp-ip))
  (error? ; not supported
    (set-port-nonblocking! $cp-ip #t))
  (error? ; not supported
    (set-port-nonblocking! $cp-ip #f))

  (begin
    (define $cp-op
      (let ([pos 0])
        (make-custom-textual-output-port "foo"
          (lambda (str s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          (lambda () pos)
          (lambda (x) (set! pos x))
          (lambda () (printf "closed\n")))))
    #t)
  (eq? (port-position $cp-op) 0)
  (error? ; not a textual output port
    (unget-char $cp-op 255))
  (not (port-has-port-length? $cp-op))
  (not (port-has-set-port-length!? $cp-op))
  (not (port-has-port-nonblocking?? $cp-op))
  (not (port-has-set-port-nonblocking!? $cp-op))
  (error? ; not supported
    (port-length $cp-op))
  (error? ; not supported
    (set-port-length! $cp-op 50))
  (error? ; not supported
    (port-nonblocking? $cp-op))
  (error? ; not supported
    (set-port-nonblocking! $cp-op #t))
  (error? ; not supported
    (set-port-nonblocking! $cp-op #f))
  (begin (put-char $cp-op #\$) #t)
  (eqv? (port-position $cp-op) 1)
  (begin (set-port-position! $cp-op 17) #t)
  (equal?
    (with-output-to-string
      (lambda ()
        (put-string $cp-op "abcd")
        (put-string $cp-op "defghi" 1)
        (put-string $cp-op "hijklm" 1 4)))
    "")
  (equal? ; in our current implementation...
    (with-output-to-string
      (lambda ()
        (printf "pos = ~s\n" (port-position $cp-op))))
    "write 13\npos = 30\n")
  (equal?
    (with-output-to-string
      (lambda ()
        (printf "pos = ~s\n" (port-position $cp-op))))
    "pos = 30\n")
  (equal?
    (with-output-to-string
      (lambda ()
        (put-string $cp-op "abcd")
        (put-string $cp-op "defghi" 1)
        (put-string $cp-op "hijklm" 1 4)))
    "")
  (equal?
    (with-output-to-string
      (lambda ()
        (close-port $cp-op)))
    "write 13\nclosed\n")
  (error? ; closed
    (put-char $cp-op #\$))
  (error? ; closed
    (put-string $cp-op "3"))
  (error? ; closed
    (r6rs:flush-output-port $cp-op))

  (begin
    (define $cp-iop
      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
        (make-custom-textual-input/output-port "foo"
          (lambda (str s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda (str s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          (lambda () pos)
          (lambda (x) (set! pos x))
          (lambda () (printf "closed\n")))))
    #t)
  (eq? (port-position $cp-iop) 0)
  (error? ; cannot unget
    (unget-char $cp-iop #\$))
  (begin (unget-char $cp-iop (eof-object)) #t)
  (port-eof? $cp-iop)
  (eof-object? (lookahead-char $cp-iop))
  (eof-object? (get-char $cp-iop))
  (equal?
    (get-string-n $cp-iop 10)
    "0123456789")
  (eqv? (port-position $cp-iop) 10)
  (eqv? (get-char $cp-iop) #\a)
  (begin (set-port-position! $cp-iop 36000) #t)
  (eqv? (get-char $cp-iop) #\0)
  (custom-port-warning? (port-position $cp-iop))
  (not (port-has-port-length? $cp-iop))
  (not (port-has-set-port-length!? $cp-iop))
  (not (port-has-port-nonblocking?? $cp-iop))
  (not (port-has-set-port-nonblocking!? $cp-iop))
  (error? ; not supported
    (port-length $cp-iop))
  (error? ; not supported
    (set-port-length! $cp-iop 50))
  (error? ; not supported
    (port-nonblocking? $cp-iop))
  (error? ; not supported
    (set-port-nonblocking! $cp-iop #t))
  (error? ; not supported
    (set-port-nonblocking! $cp-iop #f))
  (custom-port-warning? (put-char $cp-iop #\$))
  (begin (set-port-position! $cp-iop 17) #t)
  (eqv? (port-position $cp-iop) 17)
  (equal?
    (with-output-to-string
      (lambda ()
        (put-string $cp-iop "abcd")
        (put-string $cp-iop "defghi" 1)
        (put-string $cp-iop "hijklm" 1 4)))
    "")
  (equal? ; in our current implementation...
    (with-output-to-string
      (lambda ()
        (printf "pos = ~s\n" (port-position $cp-iop))))
    "write 13\npos = 30\n")
  (equal?
    (with-output-to-string
      (lambda ()
        (printf "pos = ~s\n" (port-position $cp-iop))))
    "pos = 30\n")
  (equal?
    (with-output-to-string
      (lambda ()
        (put-string $cp-iop "abcd")
        (put-string $cp-iop "defghi" 1)
        (put-string $cp-iop "hijklm" 1 4)))
    "")
  (equal?
    (with-output-to-string
      (lambda ()
        (close-port $cp-iop)))
    "write 13\nclosed\n")
  (error? ; closed
    (put-char $cp-iop #\$))
  (error? ; closed
    (put-string $cp-iop "3"))
  (error? ; closed
    (r6rs:flush-output-port $cp-iop))

  (begin
    (define $cp-iop
      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
        (make-custom-textual-input/output-port "foo"
          (lambda (str s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda (str s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          #f
          (lambda (x) (set! pos x))
          (lambda () (printf "closed\n")))))
    #t)
  (not (port-has-port-position? $cp-iop))
  (error? ; operation not supported
    (port-position $cp-iop))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-char $cp-iop #\$))
    #t)
  (eqv? (get-char $cp-iop) #\1)
  (custom-port-warning? ; can't determine position for write
    (put-char $cp-iop #\$))
  (begin (set-port-position! $cp-iop 50) #t)
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-char $cp-iop #\$))
    #t)
  (eqv? (get-char $cp-iop) #\f)
  (custom-port-warning? ; can't determine position for write
    (put-string $cp-iop "a"))

  (begin
    (define $cp-iop
      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
        (make-custom-textual-input/output-port "foo"
          (lambda (str s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda (str s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          (lambda () pos)
          #f
          (lambda () (printf "closed\n")))))
    #t)
  (not (port-has-set-port-position!? $cp-iop))
  (error? ; operation not supported
    (set-port-position! $cp-iop 3))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-char $cp-iop #\$))
    #t)
  (eqv? (get-char $cp-iop) #\1)
  (custom-port-warning? ; can't set position for write
   ; convoluted because we want warning to return normally so that operation
   ; is completed
    (let ([hit? #f])
      (with-exception-handler
        (lambda (c) (if (warning? c) (set! hit? c) (raise c)))
        (lambda () (put-char $cp-iop #\$)))
      (when hit? (raise hit?))))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-char $cp-iop #\$))
    #t)
  (begin (get-char $cp-iop) #t) ; position undefined, so value undefined
  (custom-port-warning? ; can't set position for write
    (put-string $cp-iop "a"))

  (begin
    (define $cp-iop
      (let ([pos 0] [chars "0123456789abcdefghijklmnopqrstuvwxyz"])
        (make-custom-textual-input/output-port "foo"
          (lambda (str s c)
            (let loop ([i s])
              (unless (eq? i (+ s c))
                (string-set! str i (string-ref chars (modulo (+ pos i) 36)))
                (loop (+ 1 i))))
            (set! pos (+ pos c))
            c)
          (lambda (str s c)
            (set! pos (+ pos c))
            (printf "write ~s\n" c)
            c)
          #f
          #f
          (lambda () (printf "closed\n")))))
    #t)
  (not (port-has-port-position? $cp-iop))
  (error? ; operation not supported
    (port-position $cp-iop))
  (not (port-has-set-port-position!? $cp-iop))
  (error? ; operation not supported
    (set-port-position! $cp-iop 3))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-char $cp-iop #\$))
    #t)
  (eqv? (get-char $cp-iop) #\1)
  (custom-port-warning? ; can't determine position for write
   ; convoluted because we want warning to return normally so that operation
   ; is completed
    (let ([hit? #f])
      (with-exception-handler
        (lambda (c) (if (warning? c) (set! hit? c) (raise c)))
        (lambda () (put-char $cp-iop #\$)))
      (when hit? (raise hit?))))
  (begin
    (guard (c [(warning? c) (errorf #f "unexpected warning ~s" c)])
      (put-char $cp-iop #\$))
    #t)
  (begin (get-char $cp-iop) #t) ; position undefined, so value undefined
  (custom-port-warning? ; can't determine position for write
    (put-string $cp-iop "a"))

  (equal?
    (let-values ([(sop get) (open-string-output-port)])
      (define op
        (make-custom-textual-output-port "foo"
          (lambda (str s c)
            (put-string sop str s c)
            c)
          #f #f #f))
      (fresh-line op)
      (fresh-line op)
      (put-string op "hello")
      (fresh-line op)
      (fresh-line op)
      (put-string op "hello")
      (flush-output-port op)
      (fresh-line op)
      (fresh-line op)
      (put-string op "hello\n")
      (flush-output-port op)
      (fresh-line op)
      (fresh-line op)
      (put-string op "hello\n")
      (fresh-line op)
      (close-port op)
      (get))
    "hello\nhello\nhello\nhello\n")

  (equal?
    (let-values ([(sop get) (open-string-output-port)])
      (define op
        (make-custom-textual-input/output-port "foo"
          (lambda (str s c) (errorf #f "oops"))
          (lambda (str s c)
            (put-string sop str s c)
            c)
          #f #f #f))
      (fresh-line op)
      (fresh-line op)
      (put-string op "hello")
      (fresh-line op)
      (fresh-line op)
      (put-string op "hello")
      (flush-output-port op)
      (fresh-line op)
      (fresh-line op)
      (put-string op "hello\n")
      (flush-output-port op)
      (fresh-line op)
      (fresh-line op)
      (put-string op "hello\n")
      (fresh-line op)
      (close-port op)
      (get))
    "hello\nhello\nhello\nhello\n")
)

(mat compression-textual
  (parameters [compress-format 'gzip 'lz4] [compress-level 'low 'medium 'high 'maximum])
  (let ()
    (define cp
      (lambda (src dst)
        (define buf-size 103)
        (let ([buf (make-string buf-size)])
          (call-with-port dst
            (lambda (op)
              (call-with-port src
                (lambda (ip)
                  (let loop ()
                    (do ([i 0 (fx+ i 1)])
                        ((fx= i buf-size))
                      (let ([c (get-char ip)])
                        (unless (eof-object? c) (put-char op c))))
                    (let ([n (get-string-n! ip buf 0 buf-size)])
                      (unless (eof-object? n)
                        (put-string op buf 0 n)
                        (loop)))))))))))
    (define cmp
      (lambda (src1 src2)
        (define buf-size 128)
        (let ([buf (make-string buf-size)])
          (call-with-port src1
            (lambda (ip1)
              (call-with-port src2
                (lambda (ip2)
                  (let loop ([pos 0])
                    (let ([n (get-string-n! ip1 buf 0 buf-size)])
                      (if (eof-object? n)
                          (unless (eof-object? (lookahead-char ip2)) (errorf #f "ip1 eof before ip2"))
                          (if (eof-object? (lookahead-char ip2))
                              (errorf #f "ip2 eof before ip1")
                              (let test ([i 0] [pos pos])
                                (if (= i n)
                                    (loop pos)
                                    (let ([c1 (string-ref buf i)] [c2 (get-char ip2)])
                                      (if (char=? c1 c2)
                                          (test (+ 1 i) (+ pos 1))
                                          (errorf #f "ip1 c = ~s =/= ip2 c = ~s at pos ~s" c1 c2 pos))))))))))))))))
    (define (in fn compressed? codec)
      (open-file-input-port fn
        (if compressed? (file-options compressed) (file-options))
        (buffer-mode block)
        (make-transcoder codec)))
    (define (out fn compressed? codec)
      (open-file-output-port fn
        (if compressed? (file-options compressed replace) (file-options replace))
        (buffer-mode block)
        (make-transcoder codec)))
    (time (cmp (in prettytest.ss #f (latin-1-codec)) (in prettytest.ss #f (latin-1-codec))))
    (time (cmp (in prettytest.ss #t (latin-1-codec)) (in prettytest.ss #f (latin-1-codec))))
    (time (cmp (in prettytest.ss #f (latin-1-codec)) (in prettytest.ss #t (latin-1-codec))))
    (time (cmp (in prettytest.ss #t (latin-1-codec)) (in prettytest.ss #t (latin-1-codec))))
    (time (cmp (in prettytest.ss #f (utf-8-codec)) (in prettytest.ss #f (utf-8-codec))))
    (time (cmp (in prettytest.ss #t (utf-8-codec)) (in prettytest.ss #f (utf-8-codec))))
    (time (cmp (in prettytest.ss #f (utf-8-codec)) (in prettytest.ss #t (utf-8-codec))))
    (time (cmp (in prettytest.ss #t (utf-8-codec)) (in prettytest.ss #t (utf-8-codec))))
    (cp (in prettytest.ss #f (latin-1-codec)) (out "testfile.ss" #t (latin-1-codec)))
    (cmp (in prettytest.ss #f (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec)))
    (cmp (in prettytest.ss #t (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec)))
    (cmp (in prettytest.ss #f (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec)))
    (cmp (in prettytest.ss #t (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec)))
    (cp (in prettytest.ss #f (utf-8-codec)) (out "testfile.ss" #t (utf-8-codec)))
    (cmp (in prettytest.ss #f (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec)))
    (cmp (in prettytest.ss #t (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec)))
    (cmp (in prettytest.ss #f (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec)))
    (cmp (in prettytest.ss #t (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec)))
    #t)
  ; test workaround for bogus gzclose error return for empty input files
  (and
    (eqv? (call-with-port
            (open-file-output-port "testfile.ss" (file-options replace) (buffer-mode block) (native-transcoder))
            (lambda (x) (void)))
          (void))
    (eof-object?
      (call-with-port
        (open-file-input-port "testfile.ss" (file-options compressed)
          (buffer-mode block) (native-transcoder))
        get-char)))
)

(mat string-ports
  (let ()
    (define pretty-test-string
      (call-with-port
        (open-file-input-port prettytest.ss
          (file-options) (buffer-mode none) (native-transcoder))
        get-string-all))
    (define cp ; doesn't close the ports
      (lambda (ip op)
        (define buf-size 103)
        (let ([buf (make-string buf-size)])
          (let loop ()
            (do ([i 0 (fx+ i 1)])
                ((fx= i buf-size))
              (let ([c (get-char ip)])
                (unless (eof-object? c) (put-char op c))))
            (let ([n (get-string-n! ip buf 0 buf-size)])
              (unless (eof-object? n)
                (put-string op buf 0 n)
                (loop)))))))
    (define cmp
      (lambda (src1 src2)
        (define buf-size 64)
        (let ([buf (make-string buf-size)])
          (call-with-port src1
            (lambda (ip1)
              (call-with-port src2
                (lambda (ip2)
                  (let loop ([pos 0])
                    (let ([n (get-string-n! ip1 buf 0 buf-size)])
                      (if (eof-object? n)
                          (unless (eof-object? (lookahead-char ip2)) (errorf #f "ip1 eof before ip2"))
                          (if (eof-object? (lookahead-char ip2))
                              (errorf #f "ip2 eof before ip1")
                              (let test ([i 0] [pos pos])
                                (if (= i n)
                                    (loop pos)
                                    (let ([c1 (string-ref buf i)] [c2 (get-char ip2)])
                                      (if (char=? c1 c2)
                                          (test (+ 1 i) (+ pos 1))
                                          (errorf #f "ip1 c = ~s =/= ip2 c = ~s at pos ~s" c1 c2 pos))))))))))))))))
    (define (in fn compressed? codec)
      (open-file-input-port fn
        (if compressed? (file-options compressed) (file-options))
        (buffer-mode block)
        (make-transcoder codec)))
    (define (out fn compressed? codec)
      (open-file-output-port fn
        (if compressed? (file-options compressed replace) (file-options replace))
        (buffer-mode block)
        (make-transcoder codec)))
    (time (cmp (in prettytest.ss #f (latin-1-codec)) (open-string-input-port pretty-test-string)))
    (time (cmp (open-string-input-port pretty-test-string) (in prettytest.ss #f (latin-1-codec))))
    (let-values ([(op retrieve) (open-string-output-port)])
      (cp (open-string-input-port pretty-test-string) op)
      (cmp (in prettytest.ss #f (latin-1-codec)) (open-string-input-port (retrieve))))
    #t)
)

(mat current-ports
  (input-port? (current-input-port))
  (textual-port? (current-input-port))
  (not (output-port? (open-input-string "hello")))
  (output-port? (current-output-port))
  (textual-port? (current-output-port))
  (output-port? (current-error-port))
  (textual-port? (current-error-port))
  (not (input-port? (open-output-string)))
  (eq? (r6rs:current-input-port) (current-input-port))
  (eq? (r6rs:current-output-port) (current-output-port))
  (eq? (r6rs:current-error-port) (current-error-port))
  (equal?
    (with-output-to-string
      (lambda ()
        (write (list
                 (eq? (r6rs:current-input-port) (current-input-port))
                 (eq? (r6rs:current-output-port) (current-output-port))
                 (eq? (r6rs:current-error-port) (current-error-port))))))
    "(#t #t #t)")
  (error? (current-input-port (standard-input-port)))
  (error? (current-output-port (standard-output-port)))
  (error? (current-error-port (standard-output-port)))
  (error? (current-input-port (open-output-string)))
  (error? (current-output-port (open-input-string "")))
  (error? (current-error-port (open-input-string "")))
  (error? (console-input-port (standard-input-port)))
  (error? (console-output-port (standard-output-port)))
  (error? (console-error-port (standard-output-port)))
  (error? (console-input-port (open-output-string)))
  (error? (console-output-port (open-input-string "")))
  (error? (console-error-port (open-input-string "")))
)

(mat current-transcoder
  (transcoder? (current-transcoder))
  (eqv? (current-transcoder) (native-transcoder))
  (error? (current-transcoder (open-output-string)))
  (parameterize ([current-transcoder (native-transcoder)])
    (eqv? (current-transcoder) (native-transcoder)))
  (parameterize ([current-transcoder (make-transcoder (utf-16le-codec))])
    (with-output-to-file "testfile.ss" (lambda () (write '\x3bb;12345)) 'replace)
    (file-exists? "testfile.ss"))
  (parameterize ([current-transcoder (make-transcoder (utf-16le-codec))])
    (with-input-from-file "testfile.ss"
      (lambda ()
        (and (eqv? (read) '\x3bb;12345) (eof-object? (read))))))
  (equal?
    (call-with-port (open-file-input-port "testfile.ss") get-bytevector-all)
    #vu8(#xBB #x3 #x31 #x0 #x32 #x0 #x33 #x0 #x34 #x0 #x35 #x0))
)

(mat get/put-datum
  (error? (get-datum))
  (error? (get-datum (current-input-port) (current-input-port)))
  (error? (get-datum (open-output-string)))
  (error? (get-datum (open-bytevector-input-port #vu8())))
  (call-with-port
    (open-string-input-port "hey #;there dude!")
    (lambda (p)
      (and (eq? (get-datum p) 'hey)
           (eqv? (get-char p) #\space)
           (eq? (get-datum p) 'dude!)
           (eof-object? (get-datum p)))))
  (error? (put-datum))
  (error? (put-datum (current-output-port)))
  (error? (put-datum (current-output-port) 'a 'a))
  (error? (put-datum (open-input-string "hello") 'a))
  (error? (put-datum (let-values ([(p g) (open-bytevector-output-port)]) p) 'a))
  (equal?
    (let-values ([(p g) (open-string-output-port)])
      (put-datum p '(this is))
      (put-datum p "cool")
      (put-datum p '(or (maybe . not)))
      (g))
    "(this is)\"cool\"(or (maybe . not))")
  (call-with-port
    (open-string-input-port "#3(a b c) #!r6rs #(d e) #!chezscheme #3(f g)")
    (lambda (p)
      (and
        (equal? (get-datum p) '#(a b c))
        (equal? (get-datum p) '#(d e))
        (equal? (get-datum p) '#(f g g))
        (equal? (get-datum p) #!eof))))
 ; make sure that nel and ls are treated properly
  (call-with-port
    (open-string-input-port "#!r6rs \x85; \x2028; #\\x85 #\\x2028 \"\\x85; \\x2028;\"")
    (lambda (p)
      (and
        (equal? (get-datum p) (integer->char #x85))
        (equal? (get-datum p) (integer->char #x2028))
        (equal? (get-datum p) (string (integer->char #x85) #\space (integer->char #x2028))))))
  (equal?
    (call-with-string-output-port
      (lambda (p)
        (put-char p #\x85)
        (put-char p #\space)
        (put-char p #\x2028)
        (put-char p #\space)
        (put-datum p #\x85)
        (put-char p #\space)
        (put-datum p #\x2028)
        (put-char p #\space)
        (put-datum p "\x85; \x2028;")))
    "\x85; \x2028; #\\x85 #\\x2028 \"\\x85; \\x2028;\"")
  (let ()
    (define (rw? x1)
      (let ([str (let-values ([(p e) (open-string-output-port)])
                   (write x1 p)
                   (e))])
        (let ([x2 (read (open-string-input-port str))])
          (equal? x1 x2))))
    (and
      (rw? "  \x85;  ")
      (rw? "  \x2028;  ")
      (rw? #\x85)
      (rw? #\x2028)))
)

(mat utf-16-codec
  (error? (r6rs:utf-16-codec #f))
  (error? (utf-16-codec #f))
 ; test decoding
  (let ()
    (define utf-16->string
      (lambda (eol bv)
        (let ([ip (transcoded-port
                    (let ([n (bytevector-length bv)] [i 0])
                      (make-custom-binary-input-port "foo"
                        (lambda (buf start count)
                          (let ([count (min (+ (random (min count 3)) 1) (fx- n i))])
                            (bytevector-copy! bv i buf start count)
                            (set! i (+ i count))
                            count))
                        (lambda () i)
                        (lambda (p) (set! i p))
                        #f))
                    (make-transcoder (utf-16-codec) eol (error-handling-mode replace)))])
          (call-with-string-output-port
            (lambda (op)
              (define (deref s) (if (eof-object? s) s (string-ref s 0)))
              (let again ()
                (let ([c (if (= (random 5) 3) (deref (get-string-n ip 1)) (get-char ip))])
                  (if (eof-object? c)
                      (let ([pos (port-position ip)])
                        (unless (= pos (bytevector-length bv))
                          (errorf #f "wrong pos ~s at eof" pos)))
                      (begin (put-char op c) (again))))))))))
    (define (big bv)
      (let ([n (bytevector-length bv)])
        (let ([newbv (make-bytevector (+ n 2))])
          (bytevector-u8-set! newbv 0 #xfe)
          (bytevector-u8-set! newbv 1 #xff)
          (do ([i 0 (fx+ i 2)])
              ((fx>= i (fx- n 1))
               (unless (fx= i n)
                 (bytevector-u8-set! newbv (fx+ i 2) (bytevector-u8-ref bv i))))
            (bytevector-u8-set! newbv (fx+ i 2) (bytevector-u8-ref bv i))
            (bytevector-u8-set! newbv (fx+ i 3) (bytevector-u8-ref bv (fx+ i 1))))
          newbv)))
    (define (little bv)
      (let ([n (bytevector-length bv)])
        (let ([newbv (make-bytevector (+ n 2))])
          (bytevector-u8-set! newbv 0 #xff)
          (bytevector-u8-set! newbv 1 #xfe)
          (do ([i 0 (fx+ i 2)])
              ((fx>= i (fx- n 1))
               (unless (fx= i n)
                 (bytevector-u8-set! newbv (fx+ i 2) (bytevector-u8-ref bv i))))
            (bytevector-u8-set! newbv (fx+ i 2) (bytevector-u8-ref bv (fx+ i 1)))
            (bytevector-u8-set! newbv (fx+ i 3) (bytevector-u8-ref bv i)))
          newbv)))
    (define (test eol bv s)
      (do ([n 1000 (fx- n 1)])
          ((fx= n 0))
        (let ([seed (random-seed)])
          (unless (and (equal? (utf-16->string eol bv) s)
                       (equal? (utf-16->string eol (big bv)) s)
                       (equal? (utf-16->string eol (little bv)) s))
            (errorf #f "failed, seed = ~s, bv = ~s, s = ~s" seed bv s)))))
    (test 'lf #vu8(#x00 #x61 #x00 #x0a) "a\n")
    (test 'lf #vu8(#x00 #x61 #x00 #x0d #x00 #x0a #x00 #x0d #x00 #x85 #x00 #x0d #x00 #x0d #x00 #x0a #x00 #x0d #x20 #x28) "a\n\n\n\n\n\n")
    (test 'crlf #vu8(#x00 #x61 #x00 #x0d #x00 #x0a #x00 #x0d #x00 #x85 #x00 #x0d #x00 #x0d #x00 #x0a #x00 #x0d #x20 #x28) "a\n\n\n\n\n\n")
    (test 'none #vu8(#x00 #x61 #x00 #x0d #x00 #x0a #x00 #x0d #x00 #x85 #x00 #x0d #x00 #x0d #x00 #x0a #x00 #x0d #x20 #x28) "a\r\n\r\x85;\r\r\n\r\x2028;")
    (test 'lf #vu8(#x00 #x0a #xd8 #x00 #xdc #x00 #xdb #xff #xdf #xff #xdc #x00 #xd8 #x00 #x00 #x00 #x00) "\n\x10000;\x10ffff;\xfffd;\xfffd;\xfffd;")
    #t)
 ; test encoding
  (let ()
    (define string->utf-16
      (lambda (eol s)
        (let-values ([(op getbv)
                      (let-values ([(bvop getbv) (open-bytevector-output-port)])
                        (values
                          (transcoded-port
                            (let ([i 0])
                              (make-custom-binary-output-port "foo"
                                (lambda (buf start count)
                                  (let ([count (random (min (fx+ count 1) 4))])
                                    (put-bytevector bvop buf start count)
                                    (set! i (+ i count))
                                    count))
                                (lambda () i)
                                #f #f))
                            (make-transcoder (utf-16be-codec) eol (error-handling-mode replace)))
                          getbv))])
          (let ([sip (open-string-input-port s)])
            (define (deref s) (if (eof-object? s) s (string-ref s 0)))
            (let again ()
              (let ([c (get-char sip)])
                (if (eof-object? c)
                    (let ([pos (port-position op)])
                      (close-port op)
                      (let ([bv (getbv)])
                        (unless (= pos (bytevector-length bv))
                          (errorf #f "wrong pos ~s at eof" pos))
                        bv))
                    (begin
                      (if (= (random 5) 3)
                          (put-string op (string c))
                          (put-char op c))
                      (again)))))))))
    (define (test eol s bv)
      (do ([n 1000 (fx- n 1)])
          ((fx= n 0))
        (let ([seed (random-seed)])
          (unless (equal? (string->utf-16 eol s) bv)
            (errorf #f "failed, seed = ~s, s = ~s, bv = ~s" seed s bv)))))
    (test 'lf "a\n" #vu8(#x00 #x61 #x00 #x0a))
    (test 'crlf "a\n" #vu8(#x00 #x61 #x00 #x0d #x00 #x0a))
    (test 'crnel "a\n" #vu8(#x00 #x61 #x00 #x0d #x00 #x85))
    (test 'nel "a\n" #vu8(#x00 #x61 #x00 #x85))
    (test 'ls "a\n" #vu8(#x00 #x61 #x20 #x28))
    (test 'none "a\r\n\r\x85;\r\r\n\r\x2028;" #vu8(#x00 #x61 #x00 #x0d #x00 #x0a #x00 #x0d #x00 #x85 #x00 #x0d #x00 #x0d #x00 #x0a #x00 #x0d #x20 #x28))
    (test 'lf "a\x10000;\x10ffff;\n" #vu8(#x00 #x61 #xd8 #x00 #xdc #x00 #xdb #xff #xdf #xff #x00 #x0a))
    #t)
)

(mat utf-16-BOMs
  (let ()
    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
    (and
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options replace)
            (buffer-mode block) utf-16-tx))
        (define n (port-position iop))            ; should be 0
        (put-string iop "hello\n")                ; should write BOM
        (set-port-position! iop n)                ; should actually position past BOM (position 2)
        (and
          (eqv? n 0)
          (eqv? (port-position iop) 2)
          (equal? (get-string-all iop) "hello\n")
          (eq? (close-port iop) (void))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16-tx))
        (define n (port-position iop))
        (and
          (eqv? n 0)
          (eqv? (get-char iop) #\h)
          (eqv? (port-position iop) 4)
          (equal? (get-string-all iop) "ello\n")
          (eqv? (port-position iop) 14)
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 2)
          (put-string iop "something longer than hello\n")
          (eq? (set-port-position! iop n) (void))
          (equal? (get-string-all iop) "something longer than hello\n")
          (eq? (close-port iop) (void))))))
  (let () ; same as preceding w/slightly different transcoder
    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style lf) (error-handling-mode replace)))
    (and
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options replace)
            (buffer-mode block) utf-16-tx))
        (define n (port-position iop))            ; should be 0
        (put-string iop "hello\n")                ; should write BOM
        (set-port-position! iop n)                ; should actually position past BOM (position 2)
        (and
          (eqv? n 0)
          (eqv? (port-position iop) 2)
          (equal? (get-string-all iop) "hello\n")
          (eq? (close-port iop) (void))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16-tx))
        (define n (port-position iop))
        (and
          (eqv? n 0)
          (equal? (get-string-all iop) "hello\n")
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 2)
          (put-string iop "something longer than hello\n")
          (eq? (set-port-position! iop n) (void))
          (equal? (get-string-all iop) "something longer than hello\n")
          (eq? (close-port iop) (void))))))
  (let ()
    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
    (define utf-16be-tx (make-transcoder (utf-16be-codec) (eol-style none) (error-handling-mode raise)))
    (and
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options replace)
            (buffer-mode block) utf-16-tx))
        (define n (port-position iop))            ; should be 0
        (put-string iop "hello\n")                ; should write BOM
        (set-port-position! iop n)                ; should actually position past BOM (position 2)
        (and
          (eqv? n 0)
          (eqv? (port-position iop) 2)
          (equal? (get-string-all iop) "hello\n")
          (eq? (close-port iop) (void))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16-tx))
       ; lookahead-char should position port past the BOM
        (define c (lookahead-char iop))
        (define n (port-position iop))            ; should be 2
        (and
          (eqv? c #\h)
          (eqv? n 2)
          (equal? (get-string-all iop) "hello\n")
          (eq? (set-port-position! iop n) (void))
          (eq? (put-string iop "something longer than hello\n") (void))
          (eq? (set-port-position! iop n) (void))
          (equal? (get-string-all iop) "something longer than hello\n")
          (eq? (close-port iop) (void))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16be-tx))
        (define n (port-position iop))            ; should be 0
        (and
          (eqv? (get-char iop) #\xfeff)
          (equal? (get-string-all iop) "something longer than hello\n")
          (eq? (set-port-position! iop n) (void))
          (eqv? (get-char iop) #\xfeff)
          (equal? (get-string-all iop) "something longer than hello\n")
          (eq? (close-port iop) (void))))))
  (let ()
    (define utf-16le-tx (make-transcoder (utf-16le-codec) (eol-style none) (error-handling-mode raise)))
    (and
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options replace)
            (buffer-mode block) utf-16le-tx))
        (define n (port-position iop))            ; should be 0
        (put-string iop "hello\n")                ; should not write BOM
        (set-port-position! iop n)                ; should set to 0
        (and
          (eqv? n 0)
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "hello\n")
          (eq? (close-port iop) (void))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16le-tx))
        (define n (port-position iop))            ; should be 0
        (and
          (eq? n 0)
          (equal? (get-string-all iop) "hello\n")
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (eq? (put-string iop "something longer than hello\n") (void))
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "something longer than hello\n")
          (eq? (close-port iop) (void))))))
  (let ()
    (define utf-16be-tx (make-transcoder (utf-16be-codec) (eol-style none) (error-handling-mode raise)))
    (and
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options replace)
            (buffer-mode block) utf-16be-tx))
        (define n (port-position iop))            ; should be 0
        (put-string iop "hello\n")                ; should not write BOM
        (set-port-position! iop n)                ; should set to 0
        (and
          (eqv? n 0)
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "hello\n")
          (eq? (close-port iop) (void))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16be-tx))
        (define n (port-position iop))            ; should be 0
        (and
          (eq? n 0)
          (equal? (get-string-all iop) "hello\n")
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (eq? (put-string iop "something longer than hello\n") (void))
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "something longer than hello\n")
          (eq? (close-port iop) (void))))))
  (let ()
    (define utf-16be-tx (make-transcoder (utf-16be-codec) (eol-style none) (error-handling-mode raise)))
    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
    (and
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options replace)
            (buffer-mode block) utf-16be-tx))
        (define n (port-position iop))            ; should be 0
        (put-string iop "hello\n")                ; should not write BOM
        (set-port-position! iop n)                ; should set to 0
        (and
          (eqv? n 0)
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "hello\n")
          (eq? (close-port iop) (void))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16-tx))
        (define n (port-position iop))            ; should be 0
        (and
          (eq? n 0)
          (equal? (get-string-all iop) "hello\n")
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (eq? (put-string iop "something longer than hello\n") (void))
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "something longer than hello\n")
          (eq? (close-port iop) (void))))))
  (let ()
    (define utf-16le-tx (make-transcoder (utf-16le-codec) (eol-style none) (error-handling-mode raise)))
    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
    (and
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options replace)
            (buffer-mode block) utf-16le-tx))
        (define n0 (port-position iop))             ; should be 0
        (put-char iop #\xfeff)                      ; insert explicit BOM
        (let ()
          (define n (port-position iop))            ; should be 0
          (put-string iop "hello\n")                ; should not write BOM
          (set-port-position! iop n)                ; should set to 0
          (and
            (eqv? n0 0)
            (eqv? n 2)
            (equal? (get-string-all iop) "hello\n")
            (eq? (close-port iop) (void)))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16-tx))
        (define n (port-position iop))
        (and (equal? (get-string-all iop) "hello\n")
             (begin
               (set-port-position! iop n)
               (put-string iop "hello again\n")
               (set-port-position! iop n))
             (and (equal? (get-string-all iop) "hello again\n")
                  (eq? (close-port iop) (void)))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16le-tx))
        (define n (port-position iop))            ; should be 0
        (and
          (eqv? (get-char iop) #\xfeff)           ; BOM should still be there
          (equal? (get-string-all iop) "hello again\n")
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (eq? (put-string iop "hello yet again!\n") (void))
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "hello yet again!\n")   ; BOM is gone now
          (eq? (close-port iop) (void))))))
  (let ()
    (define utf-16le-tx (make-transcoder (utf-16le-codec) (eol-style none) (error-handling-mode raise)))
    (define faux-utf-16-tx (make-transcoder (utf-16-codec 'little) (eol-style none) (error-handling-mode raise)))
    (and
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options replace)
            (buffer-mode block) utf-16le-tx))
        (define n (port-position iop))            ; should be 0
        (put-string iop "hello\n")
        (set-port-position! iop n)
        (and
          (eqv? n 0)
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "hello\n")
          (eq? (close-port iop) (void))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) faux-utf-16-tx))
        (define n (port-position iop))            ; should be 0
        (and
          (eqv? n 0)
          (equal? (get-string-all iop) "hello\n")
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (eq? (put-string iop "hello again\n") (void))
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "hello again\n")
          (eq? (close-port iop) (void))))
      (let ()
        (define iop
          (open-file-input/output-port "testfile.ss" (file-options no-fail no-truncate)
            (buffer-mode block) utf-16le-tx))
        (define n (port-position iop))            ; should be 0
        (and
          (eqv? n 0)
          (equal? (get-string-all iop) "hello again\n")
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (eq? (put-string iop "hello yet again!\n") (void))
          (eq? (set-port-position! iop n) (void))
          (eqv? (port-position iop) 0)
          (equal? (get-string-all iop) "hello yet again!\n")
          (eq? (close-port iop) (void))))))
  (let ()
    (define-syntax and
      (let ()
        (import scheme)
        (syntax-rules ()
          [(_ e ...)
           (and (let ([x e]) (pretty-print x) x) ...)])))
    (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
    (and
      (let ()
        (define op
          (open-file-output-port "testfile.ss" (file-options replace)
            (buffer-mode block) utf-16-tx))
        (define n (port-position op))                  ; should be 0
        (and
          (eqv? n 0)
          (eq? (put-string op "hello\n") (void))       ; should write BOM
          (eq? (set-port-position! op n) (void))       ; should actually position past BOM (position 2)
          (eqv? (port-position op) 2)
          (eq? (put-string op "not hello\n") (void))   ; should not write (another) BOM
          (eq? (close-port op) (void))))
      (let ()
        (define ip
          (open-file-input-port "testfile.ss" (file-options)
            (buffer-mode block) utf-16-tx))
        (define n (port-position ip))                  ; should be 0
        (define c (lookahead-char ip))                 ; should be #\n
        (and
          (eqv? n 0)
          (eqv? c #\n)
          (eqv? (port-position ip) 2)
          (equal? (get-string-all ip) "not hello\n")
          (eq? (set-port-position! ip 2) (void))
          (equal? (get-string-all ip) "not hello\n")
          (eq? (close-port ip) (void))))))
)

(mat encode/decode-consistency
 ; verify that encoding/decoding is consistent (but not necessarily correct)
 ; crank up loop bounds to stress test
  (let ()
    (define (random-string n)
      (define (random-char) (integer->char (random 256)))
      (let ([s (make-string n)])
        (do ([i 0 (fx+ i 1)])
            ((fx= i n))
          (string-set! s i (random-char)))
        s))
    (define (check who s1 s2)
      (unless (string=? s1 s2)
        (errorf who "failed for ~a"
          (parameterize ([print-unicode #f]) (format "~s" s1)))))
    (time
      (let ([latin-1-tx (make-transcoder (latin-1-codec) (eol-style none) (error-handling-mode raise))])
        (do ([n 1000 (fx- n 1)])
            ((fx= n 0) #t)
          (let ([s (random-string (random 50))])
            (check 'latin-1-test4 s (bytevector->string (string->bytevector s latin-1-tx) latin-1-tx)))))))
  (let ()
    (define (random-string n)
      (define (random-char)
        (integer->char
          (let ([k (random (fx- #x110000 (fx- #xe000 #xd800)))])
            (if (fx>= k #xd800)
                (fx+ k (fx- #xe000 #xd800))
                k))))
      (let ([s (make-string n)])
        (unless (fx= n 0)
         ; don't let a BOM sneak in at first character
          (string-set! s 0
            (let f () (let ([c (random-char)]) (if (memv c '(#\xfeff #\xfffe)) (f) c))))
          (do ([i 1 (fx+ i 1)])
              ((fx= i n))
            (string-set! s i (random-char))))
        s))
    (define (check who s1 s2)
      (unless (string=? s1 s2)
        (errorf who "failed for ~a"
          (parameterize ([print-unicode #f]) (format "~s" s1)))))
    (time
      (let ()
        (define utf-8-tx (make-transcoder (utf-8-codec) (eol-style none) (error-handling-mode raise)))
        (define utf-16-tx (make-transcoder (utf-16-codec) (eol-style none) (error-handling-mode raise)))
        (define utf-16le-tx (make-transcoder (utf-16le-codec) (eol-style none) (error-handling-mode raise)))
        (define utf-16be-tx (make-transcoder (utf-16be-codec) (eol-style none) (error-handling-mode raise)))
        (do ([n 1000 (fx- n 1)])
            ((fx= n 0) #t)
          (let ([s (random-string (random 50))])
            (check 'utf-8-test1 s (utf8->string (string->utf8 s)))
            (check 'utf-8-test2 s (utf8->string (string->bytevector s utf-8-tx)))
            (check 'utf-8-test3 s (bytevector->string (string->utf8 s) utf-8-tx))
            (check 'utf-8-test4 s (bytevector->string (string->bytevector s utf-8-tx) utf-8-tx))
            (check 'utf-16-test1a s (utf16->string (string->utf16 s 'big) 'big))
            (check 'utf-16-test1b s (utf16->string (string->utf16 s 'big) 'big #t))
            (check 'utf-16-test2a s (utf16->string (string->bytevector s utf-16-tx) 'big))
            (check 'utf-16-test2b s (utf16->string (string->bytevector s utf-16be-tx) 'big #t))
            (check 'utf-16-test2c s (utf16->string (string->bytevector s utf-16le-tx) 'little #t))
            (check 'utf-16-test3a s (bytevector->string (string->utf16 s 'big) utf-16-tx))
            (check 'utf-16-test3b s (bytevector->string (string->utf16 s 'big) utf-16be-tx))
            (check 'utf-16-test3c s (bytevector->string (string->utf16 s 'little) utf-16le-tx))
            (check 'utf-16-test4a s (bytevector->string (string->bytevector s utf-16-tx) utf-16-tx))
            (check 'utf-16-test4b s (bytevector->string (string->bytevector s utf-16le-tx) utf-16le-tx))
            (check 'utf-16-test4c s (bytevector->string (string->bytevector s utf-16be-tx) utf-16be-tx))
            (check 'utf-16-test5a s (utf16->string (string->utf16 s 'little) 'little))
            (check 'utf-16-test5b s (utf16->string (string->utf16 s 'little) 'little #t))
            (let* ([bv (string->bytevector s utf-16be-tx)]
                   [bvn (bytevector-length bv)]
                   [bv^ (make-bytevector (fx+ bvn 2))])
             ; insert big-endian BOM
              (bytevector-u8-set! bv^ 0 #xfe)
              (bytevector-u8-set! bv^ 1 #xff)
              (bytevector-copy! bv 0 bv^ 2 bvn)
              (check 'utf-16-test6 s (utf16->string bv^ 'big))
              (check 'utf-16-test7 s (bytevector->string bv^ utf-16-tx)))
            (let* ([bv (string->utf16 s 'little)]
                   [bvn (bytevector-length bv)]
                   [bv^ (make-bytevector (fx+ bvn 2))])
             ; insert little-endian BOM
              (bytevector-u8-set! bv^ 0 #xff)
              (bytevector-u8-set! bv^ 1 #xfe)
              (bytevector-copy! bv 0 bv^ 2 bvn)
              (check 'utf-16-test8 s (utf16->string bv^ 'little))
              (check 'utf-16-test9 s (bytevector->string bv^ utf-16-tx)))
          (check 'utf-32-test1a s (utf32->string (string->utf32 s 'big) 'big))
          (check 'utf-32-test1a s (utf32->string (string->utf32 s 'big) 'big #t))
          (check 'utf-32-test2a s (utf32->string (string->utf32 s 'little) 'little))
          (check 'utf-32-test2b s (utf32->string (string->utf32 s 'little) 'little #f)))))))
)

(mat string<->bytevector-conversions
 ; adapted with minor modifications from bv2string.sch, which is:
 ;
 ; Copyright 2007 William D Clinger.
 ;
 ; Permission to copy this software, in whole or in part, to use this
 ; software for any lawful purpose, and to redistribute this software
 ; is granted subject to the restriction that all copies made of this
 ; software must include this copyright notice in full.
 ;
 ; I also request that you send me a copy of any improvements that you
 ; make to this software so that they may be incorporated within it to
 ; the benefit of the Scheme community.
  (begin
    (library (bv2string) (export main)
      (import (rnrs base)
              (rnrs unicode)
              (rename (rnrs bytevectors)
                (utf8->string rnrs:utf8->string)
                (string->utf8 rnrs:string->utf8))
              (rnrs control)
              (rnrs io simple)
              (rnrs mutable-strings))

      ; Crude test rig, just for benchmarking.

      (define utf8->string)
      (define string->utf8)

      (define (test name actual expected)
        (if (not (equal? actual expected))
            (error 'test name)))

      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; The R6RS doesn't specify exactly how many replacement
      ; characters get generated by an encoding or decoding error,
      ; so the results of some tests are compared by treating any
      ; sequence of consecutive replacement characters the same as
      ; a single replacement character.
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (define (string~? s1 s2)
        (define (replacement? c)
          (char=? c #\xfffd))
        (define (canonicalized s)
          (let loop ((rchars (reverse (string->list s)))
                     (cchars '()))
            (cond ((or (null? rchars) (null? (cdr rchars)))
                   (list->string cchars))
                  ((and (replacement? (car rchars))
                        (replacement? (cadr rchars)))
                   (loop (cdr rchars) cchars))
                  (else
                   (loop (cdr rchars) (cons (car rchars) cchars))))))
        (string=? (canonicalized s1) (canonicalized s2)))

      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; Basic sanity tests, followed by stress tests on random inputs.
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (define (string-bytevector-tests
               *random-stress-tests* *random-stress-test-max-size*)

        (define (test-roundtrip bvec tostring tobvec)
          (let* ((s1 (tostring bvec))
                 (b2 (tobvec s1))
                 (s2 (tostring b2)))
            (test "round trip of string conversion" (string=? s1 s2) #t)))

        ; This random number generator doesn't have to be good.
        ; It just has to be fast.

        (define random
          (letrec ((random14
                    (lambda (n)
                      (set! x (mod (+ (* a x) c) (+ m 1)))
                      (mod (div x 8) n)))
                   (a 701)
                   (x 1)
                   (c 743483)
                   (m 524287)
                   (loop
                    (lambda (q r n)
                      (if (zero? q)
                          (mod r n)
                          (loop (div q 16384)
                                (+ (* 16384 r) (random14 16384))
                                n)))))
            (lambda (n)
              (if (< n 16384)
                  (random14 n)
                  (loop (div n 16384) (random14 16384) n)))))
       
        ; Returns a random bytevector of length up to n.

        (define (random-bytevector n)
          (let* ((n (random n))
                 (bv (make-bytevector n)))
            (do ((i 0 (+ i 1)))
                ((= i n) bv)
              (bytevector-u8-set! bv i (random 256)))))

        ; Returns a random bytevector of even length up to n.

        (define (random-bytevector2 n)
          (let* ((n (random n))
                 (n (if (odd? n) (+ n 1) n))
                 (bv (make-bytevector n)))
            (do ((i 0 (+ i 1)))
                ((= i n) bv)
              (bytevector-u8-set! bv i (random 256)))))

        ; Returns a random bytevector of multiple-of-4 length up to n.

        (define (random-bytevector4 n)
          (let* ((n (random n))
                 (n (* 4 (round (/ n 4))))
                 (bv (make-bytevector n)))
            (do ((i 0 (+ i 1)))
                ((= i n) bv)
              (bytevector-u8-set! bv i (random 256)))))

        (test "utf-8, BMP"
              (bytevector=? (string->utf8 "k\x007f;\x0080;\x07ff;\x0800;\xffff;")
                            '#vu8(#x6b
                                  #x7f
                                  #b11000010 #b10000000
                                  #b11011111 #b10111111
                                  #b11100000 #b10100000 #b10000000
                                  #b11101111 #b10111111 #b10111111))
              #t)

        (test "utf-8, supplemental"
              (bytevector=? (string->utf8 "\x010000;\x10ffff;")
                            '#vu8(#b11110000 #b10010000 #b10000000 #b10000000
                                  #b11110100 #b10001111 #b10111111 #b10111111))
              #t)

        (test "utf-8, errors 1"
              (string~? (utf8->string '#vu8(#x61                             ; a
                                            #xc0 #x62                        ; ?b
                                            #xc1 #x63                        ; ?c
                                            #xc2 #x64                        ; ?d
                                            #x80 #x65                        ; ?e
                                            #xc0 #xc0 #x66                   ; ??f
                                            #xe0 #x67                        ; ?g
                                           ))
                        "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e\xfffd;\xfffd;f\xfffd;g")
              #t)

        (test "utf-8, errors 2"
              (string~? (utf8->string '#vu8(#xe0 #x80 #x80 #x68              ; ???h
                                            #xe0 #xc0 #x80 #x69              ; ???i
                                            #xf0 #x6a                        ; ?j
                                           ))
                        "\xfffd;\xfffd;\xfffd;h\xfffd;\xfffd;\xfffd;i\xfffd;j")
              #t)

        (test "utf-8, errors 3"
              (string~? (utf8->string '#vu8(#x61                             ; a
                                            #xf0 #x80 #x80 #x80 #x62         ; ????b
                                            #xf0 #x90 #x80 #x80 #x63         ; .c
                                           ))
                        "a\xfffd;\xfffd;\xfffd;\xfffd;b\x10000;c")
              #t)

        (test "utf-8, errors 4"
              (string~? (utf8->string '#vu8(#x61                             ; a
                                            #xf0 #xbf #xbf #xbf #x64         ; .d
                                            #xf0 #xbf #xbf #x65              ; ?e
                                            #xf0 #xbf #x66                   ; ?f
                                           ))
                        "a\x3ffff;d\xfffd;e\xfffd;f")
              #t)

        (test "utf-8, errors 5"
              (string~? (utf8->string '#vu8(#x61                             ; a
                                            #xf4 #x8f #xbf #xbf #x62         ; .b
                                            #xf4 #x90 #x80 #x80 #x63         ; ????c
                                           ))

                        "a\x10ffff;b\xfffd;\xfffd;\xfffd;\xfffd;c")
              #t)

        (test "utf-8, errors 6"
              (string~? (utf8->string '#vu8(#x61                             ; a
                                            #xf5 #x80 #x80 #x80 #x64         ; ????d
                                           ))

                        "a\xfffd;\xfffd;\xfffd;\xfffd;d")
              #t)

        ; ignores BOM signature
        ; Officially, there is no BOM signature for UTF-8,
        ; so this test is commented out.

      #;(test "utf-8, BOM"
              (string=? (utf8->string '#vu8(#xef #xbb #xbf #x61 #x62 #x63 #x64))
                        "abcd")
              #t)

        (test-roundtrip (random-bytevector 10) utf8->string string->utf8)

        (do ((i 0 (+ i 1)))
            ((= i *random-stress-tests*))
          (test-roundtrip (random-bytevector *random-stress-test-max-size*)
                          utf8->string string->utf8))

        (test "utf-16, BMP"
              (bytevector=? (string->utf16 "k\x007f;\x0080;\x07ff;\x0800;\xffff;")
                            '#vu8(#x00 #x6b
                                  #x00 #x7f
                                  #x00 #x80
                                  #x07 #xff
                                  #x08 #x00
                                  #xff #xff))
              #t)

        (test "utf-16le, BMP"
              (bytevector=? (string->utf16 "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
                                           'little)
                            '#vu8(#x6b #x00
                                  #x7f #x00
                                  #x80 #x00
                                  #xff #x07
                                  #x00 #x08
                                  #xff #xff))
              #t)

        (test "utf-16, supplemental"
              (bytevector=? (string->utf16 "\x010000;\xfdcba;\x10ffff;")
                            '#vu8(#xd8 #x00 #xdc #x00
                                  #xdb #xb7 #xdc #xba
                                  #xdb #xff #xdf #xff))
              #t)

        (test "utf-16le, supplemental"
              (bytevector=? (string->utf16 "\x010000;\xfdcba;\x10ffff;" 'little)
                            '#vu8(#x00 #xd8 #x00 #xdc
                                  #xb7 #xdb #xba #xdc
                                  #xff #xdb #xff #xdf))
              #t)

        (test "utf-16be"
              (bytevector=? (string->utf16 "ab\x010000;\xfdcba;\x10ffff;cd")
                            (string->utf16 "ab\x010000;\xfdcba;\x10ffff;cd" 'big))
              #t)

        (test "utf-16, errors 1"
              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
                        (utf16->string
                         '#vu8(#x00 #x6b
                               #x00 #x7f
                               #x00 #x80
                               #x07 #xff
                               #x08 #x00
                               #xff #xff)
                         'big))
              #t)

        (test "utf-16, errors 2"
              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
                        (utf16->string
                         '#vu8(#x00 #x6b
                               #x00 #x7f
                               #x00 #x80
                               #x07 #xff
                               #x08 #x00
                               #xff #xff)
                         'big #t))
              #t)

        (test "utf-16, errors 3"
              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
                        (utf16->string
                         '#vu8(#xfe #xff     ; big-endian BOM
                               #x00 #x6b
                               #x00 #x7f
                               #x00 #x80
                               #x07 #xff
                               #x08 #x00
                               #xff #xff)
                         'big))
              #t)

        (test "utf-16, errors 4"
              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
                        (utf16->string
                         '#vu8(#x6b #x00
                               #x7f #x00
                               #x80 #x00
                               #xff #x07
                               #x00 #x08
                               #xff #xff)
                         'little #t))
              #t)

        (test "utf-16, errors 5"
              (string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
                        (utf16->string
                         '#vu8(#xff #xfe     ; little-endian BOM
                               #x6b #x00
                               #x7f #x00
                               #x80 #x00
                               #xff #x07
                               #x00 #x08
                               #xff #xff)
                         'big))
              #t)

        (let ((tostring        (lambda (bv) (utf16->string bv 'big)))
              (tostring-big    (lambda (bv) (utf16->string bv 'big #t)))
              (tostring-little (lambda (bv) (utf16->string bv 'little #t)))
              (tobvec          string->utf16)
              (tobvec-big      (lambda (s) (string->utf16 s 'big)))
              (tobvec-little   (lambda (s) (string->utf16 s 'little))))

          (do ((i 0 (+ i 1)))
              ((= i *random-stress-tests*))
            (test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
                            tostring tobvec)
            (test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
                            tostring-big tobvec-big)
            (test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
                            tostring-little tobvec-little)))

        (test "utf-32"
              (bytevector=? (string->utf32 "abc")
                            '#vu8(#x00 #x00 #x00 #x61
                                  #x00 #x00 #x00 #x62
                                  #x00 #x00 #x00 #x63))
              #t)

        (test "utf-32be"
              (bytevector=? (string->utf32 "abc" 'big)
                            '#vu8(#x00 #x00 #x00 #x61
                                  #x00 #x00 #x00 #x62
                                  #x00 #x00 #x00 #x63))
              #t)

        (test "utf-32le"
              (bytevector=? (string->utf32 "abc" 'little)
                            '#vu8(#x61 #x00 #x00 #x00
                                  #x62 #x00 #x00 #x00
                                  #x63 #x00 #x00 #x00))
              #t)

        (test "utf-32, errors 1"
              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
                        (utf32->string
                         '#vu8(#x00 #x00 #x00 #x61
                               #x00 #x00 #xd9 #x00
                               #x00 #x00 #x00 #x62
                               #x00 #x00 #xdd #xab
                               #x00 #x00 #x00 #x63
                               #x00 #x11 #x00 #x00
                               #x00 #x00 #x00 #x64
                               #x01 #x00 #x00 #x65
                               #x00 #x00 #x00 #x65)
                         'big))
              #t)

        (test "utf-32, errors 2"
              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
                        (utf32->string
                         '#vu8(#x00 #x00 #x00 #x61
                               #x00 #x00 #xd9 #x00
                               #x00 #x00 #x00 #x62
                               #x00 #x00 #xdd #xab
                               #x00 #x00 #x00 #x63
                               #x00 #x11 #x00 #x00
                               #x00 #x00 #x00 #x64
                               #x01 #x00 #x00 #x65
                               #x00 #x00 #x00 #x65)
                         'big #t))
              #t)

        (test "utf-32, errors 3"
              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
                        (utf32->string
                         '#vu8(#x00 #x00 #xfe #xff   ; big-endian BOM
                               #x00 #x00 #x00 #x61
                               #x00 #x00 #xd9 #x00
                               #x00 #x00 #x00 #x62
                               #x00 #x00 #xdd #xab
                               #x00 #x00 #x00 #x63
                               #x00 #x11 #x00 #x00
                               #x00 #x00 #x00 #x64
                               #x01 #x00 #x00 #x65
                               #x00 #x00 #x00 #x65)
                         'big))
              #t)

        (test "utf-32, errors 4"
              (string~? "\xfeff;a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
                        (utf32->string
                         '#vu8(#x00 #x00 #xfe #xff   ; big-endian BOM
                               #x00 #x00 #x00 #x61
                               #x00 #x00 #xd9 #x00
                               #x00 #x00 #x00 #x62
                               #x00 #x00 #xdd #xab
                               #x00 #x00 #x00 #x63
                               #x00 #x11 #x00 #x00
                               #x00 #x00 #x00 #x64
                               #x01 #x00 #x00 #x65
                               #x00 #x00 #x00 #x65)
                         'big #t))
              #t)

        (test "utf-32, errors 5"
              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
                        (utf32->string
                         '#vu8(#x61 #x00 #x00 #x00
                               #x00 #xd9 #x00 #x00
                               #x62 #x00 #x00 #x00
                               #xab #xdd #x00 #x00
                               #x63 #x00 #x00 #x00
                               #x00 #x00 #x11 #x00
                               #x64 #x00 #x00 #x00
                               #x65 #x00 #x00 #x01
                               #x65 #x00 #x00 #x00)
                         'little #t))
              #t)

        (test "utf-32, errors 6"
              (string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
                        (utf32->string
                         '#vu8(#xff #xfe #x00 #x00   ; little-endian BOM
                               #x61 #x00 #x00 #x00
                               #x00 #xd9 #x00 #x00
                               #x62 #x00 #x00 #x00
                               #xab #xdd #x00 #x00
                               #x63 #x00 #x00 #x00
                               #x00 #x00 #x11 #x00
                               #x64 #x00 #x00 #x00
                               #x65 #x00 #x00 #x01
                               #x65 #x00 #x00 #x00)
                         'big))
              #t)

        (test "utf-32, errors 7"
              (string~? "\xfeff;a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
                        (utf32->string
                         '#vu8(#xff #xfe #x00 #x00   ; little-endian BOM
                               #x61 #x00 #x00 #x00
                               #x00 #xd9 #x00 #x00
                               #x62 #x00 #x00 #x00
                               #xab #xdd #x00 #x00
                               #x63 #x00 #x00 #x00
                               #x00 #x00 #x11 #x00
                               #x64 #x00 #x00 #x00
                               #x65 #x00 #x00 #x01
                               #x65 #x00 #x00 #x00)
                         'little #t))
              #t)

        (let ((tostring        (lambda (bv) (utf32->string bv 'big)))
              (tostring-big    (lambda (bv) (utf32->string bv 'big #t)))
              (tostring-little (lambda (bv) (utf32->string bv 'little #t)))
              (tobvec          string->utf32)
              (tobvec-big      (lambda (s) (string->utf32 s 'big)))
              (tobvec-little   (lambda (s) (string->utf32 s 'little))))

          (do ((i 0 (+ i 1)))
              ((= i *random-stress-tests*))
            (test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
                            tostring tobvec)
            (test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
                            tostring-big tobvec-big)
            (test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
                            tostring-little tobvec-little)))

      )

      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; Exhaustive tests.
      ;
      ; Tests string <-> bytevector conversion on strings
      ; that contain every Unicode scalar value.
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (define (exhaustive-string-bytevector-tests)

        ; Tests throughout an inclusive range.

        (define (test-char-range lo hi tostring tobytevector)
          (let* ((n (+ 1 (- hi lo)))
                 (s (make-string n))
                 (replacement-character (integer->char #xfffd)))
            (do ((i lo (+ i 1)))
                ((> i hi))
              (let ((c (if (or (<= 0 i #xd7ff)
                               (<= #xe000 i #x10ffff))
                           (integer->char i)
                           replacement-character)))
                (string-set! s (- i lo) c)))
            (test "test of long string conversion"
                  (string=? (tostring (tobytevector s)) s) #t)))

        (define (test-exhaustively name tostring tobytevector)
         ;(display "Testing ")
         ;(display name)
         ;(display " conversions...")
         ;(newline)
          (test-char-range 0 #xffff tostring tobytevector)
          (test-char-range #x10000 #x1ffff tostring tobytevector)
          (test-char-range #x20000 #x2ffff tostring tobytevector)
          (test-char-range #x30000 #x3ffff tostring tobytevector)
          (test-char-range #x40000 #x4ffff tostring tobytevector)
          (test-char-range #x50000 #x5ffff tostring tobytevector)
          (test-char-range #x60000 #x6ffff tostring tobytevector)
          (test-char-range #x70000 #x7ffff tostring tobytevector)
          (test-char-range #x80000 #x8ffff tostring tobytevector)
          (test-char-range #x90000 #x9ffff tostring tobytevector)
          (test-char-range #xa0000 #xaffff tostring tobytevector)
          (test-char-range #xb0000 #xbffff tostring tobytevector)
          (test-char-range #xc0000 #xcffff tostring tobytevector)
          (test-char-range #xd0000 #xdffff tostring tobytevector)
          (test-char-range #xe0000 #xeffff tostring tobytevector)
          (test-char-range #xf0000 #xfffff tostring tobytevector)
          (test-char-range #x100000 #x10ffff tostring tobytevector))

        ; Feel free to replace this with your favorite timing macro.

        (define (timeit x) x)

        (timeit (test-exhaustively "UTF-8" utf8->string string->utf8))

        ; NOTE:  An unfortunate misunderstanding led to a late deletion
        ; of single-argument utf16->string from the R6RS.  To get the
        ; correct effect of single-argument utf16->string, you have to
        ; use two arguments, as below.
        ;
        ;(timeit (test-exhaustively "UTF-16" utf16->string string->utf16))

        (timeit (test-exhaustively "UTF-16"
                                   (lambda (bv) (utf16->string bv 'big))
                                   string->utf16))

        ; NOTE:  To get the correct effect of two-argument utf16->string,
        ; you have to use three arguments, as below.

        (timeit (test-exhaustively "UTF-16BE"
                                   (lambda (bv) (utf16->string bv 'big #t))
                                   (lambda (s) (string->utf16 s 'big))))

        (timeit (test-exhaustively "UTF-16LE"
                                   (lambda (bv) (utf16->string bv 'little #t))
                                   (lambda (s) (string->utf16 s 'little))))

        ; NOTE:  An unfortunate misunderstanding led to a late deletion
        ; of single-argument utf32->string from the R6RS.  To get the
        ; correct effect of single-argument utf32->string, you have to
        ; use two arguments, as below.
        ;
        ;(timeit (test-exhaustively "UTF-32" utf32->string string->utf32))

        (timeit (test-exhaustively "UTF-32"
                                   (lambda (bv) (utf32->string bv 'big))
                                   string->utf32))

        ; NOTE:  To get the correct effect of two-argument utf32->string,
        ; you have to use three arguments, as below.

        (timeit (test-exhaustively "UTF-32BE"
                                   (lambda (bv) (utf32->string bv 'big #t))
                                   (lambda (s) (string->utf32 s 'big))))

        (timeit (test-exhaustively "UTF-32LE"
                                   (lambda (bv) (utf32->string bv 'little #t))
                                   (lambda (s) (string->utf32 s 'little)))))

      (define (main p1 p2)
        (set! utf8->string p1)
        (set! string->utf8 p2)
        (string-bytevector-tests 2 1000)
        (exhaustive-string-bytevector-tests)))
    #t)
 ; first test w/built-in utf8->string and string->utf8
  (begin
    (let () (import (bv2string)) (main utf8->string string->utf8))
    #t)
 ; next test w/utf8->string and string->utf8 synthesized from utf-8-codec
  (let ()
    (define (utf8->string bv)
      (get-string-all (open-bytevector-input-port bv
                        (make-transcoder (utf-8-codec) 'none))))
    (define (string->utf8 s)
      (let-values ([(op get) (open-bytevector-output-port
                               (make-transcoder (utf-8-codec) 'none))])
        (put-string op s)
        (get)))
    (let () (import (bv2string)) (main utf8->string string->utf8))
    #t)
)

(mat open-process-ports ; see also unix.ms (mat nonblocking ...)
  (begin
    (define ($check-port p xput-port? bt-port?)
      (define-syntax err? 
        (syntax-rules ()
          [(_ e1 e2 ...) (guard (c [#t #t]) e1 e2 ... #f)]))
      (unless (and (xput-port? p) (bt-port? p) (file-port? p))
        (errorf #f "~s is not as it should be" p))
      (let ([fd (port-file-descriptor p)])
        (unless (fixnum? fd)
          (errorf #f "unexpected file descriptor ~s" fd)))
      (when (or (port-has-port-position? p)
                (port-has-set-port-position!? p)
                (port-has-port-length? p)
                (port-has-set-port-length!? p))
        (errorf #f "unexpected port-has-xxx results for ~s" p))
      (unless (and (err? (port-position p))
                   (err? (set-port-position! p 0))
                   (err? (port-length p))
                   (err? (set-port-length! p 0)))
        (errorf #f "no error for getting/setting port position/length on ~s" p)))
    (define $emit-dot
      (let ([n 0])
        (lambda ()
          (display ".")
          (set! n (modulo (+ n 1) 72))
          (when (= n 0) (newline))
          (flush-output-port))))
    #t)
 ; test binary ports
  (let-values ([(to-stdin from-stdout from-stderr pid)
                (open-process-ports (patch-exec-path $cat_flush))])
    (define put-string
      (lambda (bp s)
        (put-bytevector bp (string->utf8 s))))
    (define get-string-some
      (lambda (bp)
        (let ([x (get-bytevector-some bp)])
          (if (eof-object? x) x (utf8->string x)))))
    (define get-string-n
      (lambda (bp n)
        (let ([x (get-bytevector-n bp n)])
          (if (eof-object? x) x (utf8->string x)))))
    (dynamic-wind
      void
      (lambda ()
        (put-string to-stdin "life in the fast lane\n")
        (flush-output-port to-stdin)
        (let f ()
          ($check-port to-stdin output-port? binary-port?)
          ($check-port from-stdout input-port? binary-port?)
          ($check-port from-stderr input-port? binary-port?)
          (when (input-port-ready? from-stderr)
            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
          (if (input-port-ready? from-stdout)
              (let ([s (get-string-n from-stdout 10)])
                (unless (equal? s "life in th")
                  (errorf #f "unexpected from-stdout string ~s" s)))
              (begin
                ($emit-dot)
                (f))))
        (let f ([all ""])
          (unless (equal? all "e fast lane\n")
            (when (input-port-ready? from-stderr)
              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
            (let ([s (get-string-some from-stdout)])
              ($emit-dot)
              (f (string-append all s)))))
        (and
          (not (input-port-ready? from-stderr))
          (not (input-port-ready? from-stdout))
          (begin
            (close-port to-stdin)
            (let f ()
              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
                ($emit-dot)
                (f)))
            #t)))
      (lambda ()
        (close-port to-stdin)
        (close-port from-stdout)
        (close-port from-stderr))))
 ; test binary ports w/buffer-mode none
  (let-values ([(to-stdin from-stdout from-stderr pid)
                (open-process-ports (patch-exec-path $cat_flush) (buffer-mode none))])
    (define put-string
      (lambda (bp s)
        (put-bytevector bp (string->utf8 s))))
    (define get-string-some
      (lambda (bp)
        (let ([x (get-bytevector-some bp)])
          (if (eof-object? x) x (utf8->string x)))))
    (define get-string-n
      (lambda (bp n)
        (let ([x (get-bytevector-n bp n)])
          (if (eof-object? x) x (utf8->string x)))))
    (dynamic-wind
      void
      (lambda ()
        ($check-port to-stdin output-port? binary-port?)
        ($check-port from-stdout input-port? binary-port?)
        ($check-port from-stderr input-port? binary-port?)
        (put-string to-stdin "life in the fast lane\n")
        (flush-output-port to-stdin)
        (let f ()
          (when (input-port-ready? from-stderr)
            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
          (if (input-port-ready? from-stdout)
              (let ([s (get-string-n from-stdout 10)])
                (unless (equal? s "life in th")
                  (errorf #f "unexpected from-stdout string ~s" s)))
              (begin
                ($emit-dot)
                (f))))
        (let f ([all ""])
          (unless (equal? all "e fast lane\n")
            (when (input-port-ready? from-stderr)
              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
            (let ([s (get-string-some from-stdout)])
              ($emit-dot)
              (f (string-append all s)))))
        (and
          (not (input-port-ready? from-stderr))
          (not (input-port-ready? from-stdout))
          (begin
            (close-port to-stdin)
            (let f ()
              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
                ($emit-dot)
                (f)))
            #t)))
      (lambda ()
        (close-port to-stdin)
        (close-port from-stdout)
        (close-port from-stderr))))
 ; test textual ports
  (let-values ([(to-stdin from-stdout from-stderr pid)
                (open-process-ports (patch-exec-path $cat_flush) (buffer-mode block) (native-transcoder))])
    (dynamic-wind
      void
      (lambda ()
        ($check-port to-stdin output-port? textual-port?)
        ($check-port from-stdout input-port? textual-port?)
        ($check-port from-stderr input-port? textual-port?)
        (put-string to-stdin "life in the fast lane\n")
        (flush-output-port to-stdin)
        (let f ()
          (when (input-port-ready? from-stderr)
            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
          (if (input-port-ready? from-stdout)
              (let ([s (get-string-n from-stdout 10)])
                (unless (equal? s "life in th")
                  (errorf #f "unexpected from-stdout string ~s" s)))
              (begin
                ($emit-dot)
                (f))))
        (let f ([all ""])
          (unless (equal? all "e fast lane\n")
            (when (input-port-ready? from-stderr)
              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
            (let ([s (get-string-some from-stdout)])
              ($emit-dot)
              (f (string-append all s)))))
        (and
          (not (input-port-ready? from-stderr))
          (not (input-port-ready? from-stdout))
          (begin
            (close-port to-stdin)
            (let f ()
              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
                ($emit-dot)
                (f)))
            #t)))
      (lambda ()
        (close-port to-stdin)
        (close-port from-stdout)
        (close-port from-stderr))))
 ; test textual ports w/buffer-mode none
  (let-values ([(to-stdin from-stdout from-stderr pid)
                (open-process-ports (patch-exec-path $cat_flush) (buffer-mode none) (native-transcoder))])
    (dynamic-wind
      void
      (lambda ()
        ($check-port to-stdin output-port? textual-port?)
        ($check-port from-stdout input-port? textual-port?)
        ($check-port from-stderr input-port? textual-port?)
        (put-string to-stdin "life in the fast lane\n")
        (flush-output-port to-stdin)
        (let f ()
          (when (input-port-ready? from-stderr)
            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
          (if (input-port-ready? from-stdout)
              (let ([s (get-string-n from-stdout 10)])
                (unless (equal? s "life in th")
                  (errorf #f "unexpected from-stdout string ~s" s)))
              (begin
                ($emit-dot)
                (f))))
        (let f ([all ""])
          (unless (equal? all "e fast lane\n")
            (when (input-port-ready? from-stderr)
              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
            (let ([s (get-string-some from-stdout)])
              ($emit-dot)
              (f (string-append all s)))))
        (and
          (not (input-port-ready? from-stderr))
          (not (input-port-ready? from-stdout))
          (begin
            (close-port to-stdin)
            (let f ()
              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
                ($emit-dot)
                (f)))
            #t)))
      (lambda ()
        (close-port to-stdin)
        (close-port from-stdout)
        (close-port from-stderr))))
 ; test textual ports w/buffer-mode line
  (let-values ([(to-stdin from-stdout from-stderr pid)
                (open-process-ports (patch-exec-path $cat_flush) (buffer-mode line) (native-transcoder))])
    (dynamic-wind
      void
      (lambda ()
        ($check-port to-stdin output-port? textual-port?)
        ($check-port from-stdout input-port? textual-port?)
        ($check-port from-stderr input-port? textual-port?)
        (put-string to-stdin "life in the fast lane\n")
        (flush-output-port to-stdin)
        (let f ()
          (when (input-port-ready? from-stderr)
            (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
          (if (input-port-ready? from-stdout)
              (let ([s (get-string-n from-stdout 10)])
                (unless (equal? s "life in th")
                  (errorf #f "unexpected from-stdout string ~s" s)))
              (begin
                ($emit-dot)
                (f))))
        (let f ([all ""])
          (unless (equal? all "e fast lane\n")
            (when (input-port-ready? from-stderr)
              (errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
            (let ([s (get-string-some from-stdout)])
              ($emit-dot)
              (f (string-append all s)))))
        (and
          (not (input-port-ready? from-stderr))
          (not (input-port-ready? from-stdout))
          (begin
            (close-port to-stdin)
            (let f ()
              (unless (and (port-eof? from-stdout) (port-eof? from-stderr))
                ($emit-dot)
                (f)))
            #t)))
      (lambda ()
        (close-port to-stdin)
        (close-port from-stdout)
        (close-port from-stderr))))
)

(mat to-fold-or-not-to-fold
  (begin
    (define ($readit cs? s)
      (define (string-append* s1 . ls)
        (let f ([s1 s1] [ls ls] [n 0])
          (let ([n1 (string-length s1)])
            (if (null? ls)
                (let ([s (make-string (fx+ n n1))])
                  (string-copy! s1 0 s n n1)
                  s)
                (let ([s (f (car ls) (cdr ls) (fx+ n n1 1))])
                  (string-copy! s1 0 s n n1)
                  (string-set! s (fx+ n n1) #\$)
                  s)))))
      (apply string-append*
        (let ([sip (open-input-string s)])
          (parameterize ([case-sensitive cs?])
            (let f ()
              (let ([x (get-datum sip)])
                (if (eof-object? x)
                    '()
                    (cons (cond
                            [(gensym? x)
                             (string-append (symbol->string x) "%"
                               (gensym->unique-string x))]
                            [(symbol? x) (symbol->string x)]
                            [(char? x) (string x)]
                            [else (error 'string-append* "unexpected ~s" x)])
                          (f)))))))))
    #t)
  (case-sensitive)
  (equal?
    ($readit #t "To be or NOT to bE")
    "To$be$or$NOT$to$bE")
  (equal?
    ($readit #f "To be or NOT to bE")
    "to$be$or$not$to$be")
  (equal?
    ($readit #t "To be #!no-fold-case or NOT #!fold-case to bE")
    "To$be$or$NOT$to$be")
  (equal?
    ($readit #t "To be #!fold-case or NOT #!no-fold-case to bE")
    "To$be$or$not$to$bE")
  (equal?
    ($readit #f "To be #!no-fold-case or NOT #!fold-case to bE")
    "to$be$or$NOT$to$be")
  (equal?
    ($readit #f "To be #!fold-case or NOT #!no-fold-case to bE")
    "to$be$or$not$to$bE")
 ; check delimiting
  (equal?
    ($readit #f "To be#!fold-caseor NOT#!no-fold-caseto bE")
    "to$be$or$not$to$bE")
 ; verify case folding is not disabled when Unicode hex escape seen
  (equal?
    ($readit #t "ab\\x43;de")
    "abCde")
  (equal?
    ($readit #f "ab\\x43;de")
    "abcde")
  (equal?
    ($readit #t "#!fold-case ab\\x43;de")
    "abcde")
  (equal?
    ($readit #f "#!fold-case ab\\x43;de")
    "abcde")
  (equal?
    ($readit #t "#!no-fold-case ab\\x43;de")
    "abCde")
  (equal?
    ($readit #f "#!no-fold-case ab\\x43;de")
    "abCde")
 ; verify case folding still works when string changes size
  (equal?
    ($readit #t "Stra\xDF;e #!no-fold-case Stra\xDF;e #!fold-case Stra\xDF;e")
    "Stra\xDF;e$Stra\xDF;e$strasse")
  (equal?
    ($readit #f "Stra\xDF;e #!no-fold-case Stra\xDF;e #!fold-case Stra\xDF;e")
    "strasse$Stra\xDF;e$strasse")
  (equal?
    ($readit #t "Stra\xDF;e #!fold-case Stra\xDF;e #!no-fold-case Stra\xDF;e")
    "Stra\xDF;e$strasse$Stra\xDF;e")
  (equal?
    ($readit #f "Stra\xDF;e #!fold-case Stra\xDF;e #!no-fold-case Stra\xDF;e")
    "strasse$strasse$Stra\xDF;e")
  (equal?
    ($readit #t "Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
    "Aab CdE$abCD eFg$#Ab C$aB cd")
 ; verify case folding is disabled when vertical bars or backslashes
 ; (other than those for Unicode hex escapes) appear
  (equal?
    ($readit #f "Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
    "Aab CdE$abCD eFg$#Ab C$aB cd")
  (equal?
    ($readit #t "#!fold-case Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
    "Aab CdE$abCD eFg$#Ab C$aB cd")
  (equal?
    ($readit #f "#!fold-case Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
    "Aab CdE$abCD eFg$#Ab C$aB cd")
  (equal?
    ($readit #t "#!no-fold-case Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
    "Aab CdE$abCD eFg$#Ab C$aB cd")
  (equal?
    ($readit #f "#!no-fold-case Aa|b C|dE abC|D e|Fg \\#Ab\\ C a\\B\\ cd")
    "Aab CdE$abCD eFg$#Ab C$aB cd")
 ; verify proper case folding for gensyms
  (equal?
    ($readit #t "#{aBc DeF1}")
    "aBc%DeF1")
  (equal?
    ($readit #f "#{aBc DeF2}")
    "abc%def2")
  (equal?
    ($readit #t "#!fold-case #{aBc DeF3}")
    "abc%def3")
  (equal?
    ($readit #f "#!fold-case #{aBc DeF4}")
    "abc%def4")
  (equal?
    ($readit #t "#!no-fold-case #{aBc DeF5}")
    "aBc%DeF5")
  (equal?
    ($readit #f "#!no-fold-case #{aBc DeF6}")
    "aBc%DeF6")
  (equal?
    ($readit #t "#{aBc De\\F7}")
    "aBc%DeF7")
  (equal?
    ($readit #f "#{aBc De\\F8}")
    "abc%DeF8")
  (equal?
    ($readit #t "#!fold-case #{aBc De\\F9}")
    "abc%DeF9")
  (equal?
    ($readit #f "#!fold-case #{aBc De\\F10}")
    "abc%DeF10")
  (equal?
    ($readit #t "#!no-fold-case #{aBc De\\F11}")
    "aBc%DeF11")
  (equal?
    ($readit #f "#!no-fold-case #{aBc De\\F12}")
    "aBc%DeF12")
  (equal?
    ($readit #t "#{a\\Bc DeF13}")
    "aBc%DeF13")
  (equal?
    ($readit #f "#{a\\Bc DeF14}")
    "aBc%def14")
  (equal?
    ($readit #t "#!fold-case #{a\\Bc DeF15}")
    "aBc%def15")
  (equal?
    ($readit #f "#!fold-case #{a\\Bc DeF16}")
    "aBc%def16")
  (equal?
    ($readit #t "#!no-fold-case #{a\\Bc DeF17}")
    "aBc%DeF17")
  (equal?
    ($readit #f "#!no-fold-case #{a\\Bc DeF18}")
    "aBc%DeF18")
  (equal?
    ($readit #t "#{a\\Bc De\\F19}")
    "aBc%DeF19")
  (equal?
    ($readit #f "#{a\\Bc De\\F20}")
    "aBc%DeF20")
  (equal?
    ($readit #t "#!fold-case #{a\\Bc De\\F21}")
    "aBc%DeF21")
  (equal?
    ($readit #f "#!fold-case #{a\\Bc De\\F22}")
    "aBc%DeF22")
  (equal?
    ($readit #t "#!no-fold-case #{a\\Bc De\\F23}")
    "aBc%DeF23")
  (equal?
    ($readit #f "#!no-fold-case #{a\\Bc De\\F24}")
    "aBc%DeF24")
  (equal?
    ($readit #t "#\\newline")
    "\n")
  (equal?
    ($readit #f "#\\newline")
    "\n")
  (equal?
    ($readit #f "#!fold-case #\\newline")
    "\n")
  (equal?
    ($readit #f "#!fold-case #\\newline")
    "\n")
  (equal?
    ($readit #f "#!no-fold-case #\\newline")
    "\n")
  (equal?
    ($readit #f "#!no-fold-case #\\newline")
    "\n")
  (error? ($readit #t "#\\newLine"))
  (equal?
    ($readit #f "#\\newLine")
    "\n")
  (equal?
    ($readit #t "#!fold-case #\\newLine")
    "\n")
  (equal?
    ($readit #f "#!fold-case #\\newLine")
    "\n")
  (error? ($readit #t "#!no-fold-case #\\newLine"))
  (error? ($readit #f "#!no-fold-case #\\newLine"))
)