suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

r6rs io/ports-6 repairs and tests

Browse Source 
svn: r9523
This commit is contained in:
Matthew Flatt 2008-04-28 21:59:18 +00:00
parent 53709f1faf
commit e6b2b19030
5 changed files with 496 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/mzlib/port.ss
View File

@ -91,7 +91,7 @@
(copy b)
rd))]))
;; `make-input-port/read-to-peek' sometimes need to wrap a special-value
;; `make-input-port/read-to-peek' sometimes needs to wrap a special-value
;; procedure so that it's only called once when the value is both
;; peeked and read.
(define-values (struct:memoized make-memoized memoized? memoized-ref memoized-set!)
@ -121,7 +121,8 @@
[count-lines!-proc void]
[init-position 1]
[buffer-mode-proc #f]
[buffering? #f])
[buffering? #f]
[on-consumed #f])
(define lock-semaphore (make-semaphore 1))
(define commit-semaphore (make-semaphore 1))
(define-values (peeked-r peeked-w) (make-pipe))
@ -152,6 +153,11 @@
;; our back.
(write-byte 0 peeked-w)
(read-byte peeked-r))
(define (consume-from-peeked s)
(let ([n (read-bytes-avail!* s peeked-r)])
(when on-consumed
(on-consumed n))
n))
(define (read-it-with-lock s)
(if use-manager?
(with-manager-lock (lambda () (do-read-it s)))
@ -164,7 +170,9 @@
s))
(define (do-read-it s)
(if (byte-ready? peeked-r)
peeked-r
(if on-consumed
(consume-from-peeked s)
peeked-r)
;; If nothing is saved from a peeking read,
;; dispatch to `read', otherwise return
;; previously peeked data
@ -179,23 +187,33 @@
(if (and (number? r) (positive? r))
(begin
(write-bytes buf peeked-w 0 r)
peeked-r)
r))
(if on-consumed
(consume-from-peeked s)
peeked-r))
(begin
(when on-consumed
(on-consumed r))
r)))
;; Just read requested amount:
(read s))]
(let ([v (read s)])
(when on-consumed
(on-consumed v))
v))]
[else (if (bytes? (mcar special-peeked))
(let ([b (mcar special-peeked)])
(write-bytes b peeked-w)
(set! special-peeked (mcdr special-peeked))
(when (null? special-peeked)
(set! special-peeked-tail #f))
(read-bytes-avail!* s peeked-r))
(begin0
(mcar special-peeked)
(consume-from-peeked s))
(let ([v (mcar special-peeked)])
(make-progress)
(set! special-peeked (mcdr special-peeked))
(when on-consumed
(on-consumed v))
(when (null? special-peeked)
(set! special-peeked-tail #f))))])))
(set! special-peeked-tail #f))
v))])))
(define (peek-it-with-lock s skip unless-evt)
(if use-manager?
(with-manager-lock (lambda () (do-peek-it s skip unless-evt)))

162
collects/rnrs/io/ports-6.ss
View File

@ -144,7 +144,7 @@
;; ----------------------------------------
(define (make-disconnectable-input-port port)
(define (make-disconnectable-input-port port close?)
(define disconnected? #f)
(define (check-disconnect)
(when disconnected?
@ -156,17 +156,18 @@
(check-disconnect)
(let ([n (read-bytes-avail!* bytes port)])
(if (eq? n 0)
port
(wrap-evt port (lambda (v) 0))
n)))
(lambda (bytes skip evt)
(check-disconnect)
(let ([n (peek-bytes-avail! bytes skip evt port)])
(if (eq? n 0)
port
(wrap-evt port (lambda (v) 0))
n)))
(lambda ()
(unless disconnected?
(close-input-port port)))
(when close?
(close-input-port port))))
(and (port-provides-progress-evts? port)
(lambda ()
(check-disconnect)
@ -189,7 +190,7 @@
(set! disconnected? #t)
port)))
(define (make-disconnectable-output-port port)
(define (make-disconnectable-output-port port close?)
(define disconnected? #f)
(define (check-disconnect)
(when disconnected?
@ -213,7 +214,8 @@
(write-bytes-avail* (subbytes bytes start end) port)])))
(lambda ()
(unless disconnected?
(close-output-port port)))
(when close?
(close-output-port port))))
(and (port-writes-special? port)
(lambda (v can-buffer/block? enable-breaks?)
(check-disconnect)
@ -264,7 +266,7 @@
;; Textual ports are transcoded
(define-struct textual-input-port (port transcoder)
#:property prop:input-port 0)
(define-struct textual-output-port (port transcoder)
(define-struct textual-output-port (port transcoder)
#:property prop:output-port 0)
(define-struct (textual-input/output-port textual-input-port) (out-port)
#:property prop:output-port 0)
@ -294,17 +296,17 @@
(textual-port? (dual-port-in v)))))
(raise-type-error 'binary-port? "port" v)))
(define (wrap-binary-input-port p get-pos set-pos!)
(let-values ([(p disconnect) (make-disconnectable-input-port p)])
(define (wrap-binary-input-port p get-pos set-pos! close?)
(let-values ([(p disconnect) (make-disconnectable-input-port p close?)])
(make-binary-input-port p disconnect get-pos set-pos!)))
(define (wrap-binary-output-port p get-pos set-pos!)
(let-values ([(p disconnect) (make-disconnectable-output-port p)])
(define (wrap-binary-output-port p get-pos set-pos! close?)
(let-values ([(p disconnect) (make-disconnectable-output-port p close?)])
(make-binary-output-port p disconnect get-pos set-pos!)))
(define (wrap-binary-input/output-port p get-pos set-pos!)
(let-values ([(p disconnect) (make-disconnectable-input-port p)]
[(out-p out-disconnect) (make-disconnectable-output-port p)])
(define (wrap-binary-input/output-port p get-pos set-pos! close?)
(let-values ([(p disconnect) (make-disconnectable-input-port p #t)]
[(out-p out-disconnect) (make-disconnectable-output-port p #t)])
(make-binary-input/output-port p disconnect get-pos set-pos!
out-p out-disconnect)))
@ -437,9 +439,8 @@
[(dual-port? p)
(port-has-set-port-position!? (dual-port-in p))]
[else
;; FIXME
(or (file-stream-port? p)
#t)]))
;; we could also allow string ports here
(file-stream-port? p)]))
(define (set-port-position! p pos)
(unless (and (port? p)
@ -455,7 +456,7 @@
[(textual-output-port? p)
(set-port-position! (textual-output-port-port p) pos)]
[(dual-port? p)
(set-port-position! (dual-port-in p))]
(set-port-position! (dual-port-in p) pos)]
[else
(file-position p pos)]))
@ -497,7 +498,8 @@
(transcoded-port p maybe-transcoder)
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(lambda (pos) (file-position p pos))
#t))))
(define (open-bytevector-input-port bytes [maybe-transcoder #f])
(unless (bytes? bytes)
@ -510,7 +512,8 @@
(transcoded-port p maybe-transcoder)
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(lambda (pos) (file-position p pos))
#t))))
(define (open-string-input-port str)
(unless (string? str)
@ -519,7 +522,8 @@
(transcoded-port
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos)))
(lambda (pos) (file-position p pos))
#t)
utf8-transcoder)))
(define standard-input-port
@ -527,7 +531,8 @@
(lambda ()
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(lambda (pos) (file-position p pos))
#f))))
(define input-ports (make-weak-hasheq))
@ -543,18 +548,37 @@
p2)])))
(define (make-custom-binary-input-port id read! get-position set-position! close)
(let ([p (make-input-port/read-to-peek
id
(lambda (bytes)
(let ([v (read! bytes 0 (bytes-length bytes))])
(if (zero? v)
eof
v)))
#f
(or close void))])
(let* ([peeked 0]
[p (make-input-port/read-to-peek
id
(lambda (bytes)
(let ([v (read! bytes 0 (bytes-length bytes))])
(set! peeked (+ peeked v))
(if (zero? v)
eof
v)))
#f
(or close void)
#f void 1
#f #f
(lambda (consumed-n)
(unless (eof-object? consumed-n)
(set! peeked (- consumed-n 1)))))])
(wrap-binary-input-port p
get-position
set-position!)))
(and get-position
(lambda ()
(let ([v (get-position)])
(- v peeked))))
(and set-position!
(lambda (pos)
;; flush peeked
(let loop ()
(unless (zero? peeked)
(read-byte-or-special p)
(loop)))
;; set position
(set-position! pos)))
#t)))
(define (make-custom-textual-input-port id read! get-position set-position! close)
@ -564,19 +588,20 @@
(let-values ([(in out) (make-pipe)])
(lambda (bstr offset len)
(let loop ()
(let ([n (read-bytes-avail! bstr in offset len)])
(if (zero? n)
(let ([str (make-string (bytes-length bstr))])
(let ([len (read! str 0 (bytes-length bstr))])
(if (zero? len)
eof
(begin
(write-string (substring str 0 len) out)
(loop)))))
n)))))
(let ([n (read-bytes-avail!* bstr in offset len)])
(if (zero? n)
(let ([str (make-string (bytes-length bstr))])
(let ([len (read! str 0 (bytes-length bstr))])
(if (zero? len)
0
(begin
(write-string (substring str 0 len) out)
(loop)))))
n)))))
get-position
set-position!
(or close void))))
(or close void))
#f))
;; ----------------------------------------
@ -713,8 +738,9 @@
(if maybe-transcoder
(transcoded-port p maybe-transcoder)
(wrap-binary-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos)))))))
(and file-position (lambda () (file-position p)))
(and file-position (lambda (pos) (file-position p pos)))
#t)))))
(define (open-file-output-port filename
[options (file-options)]
@ -738,11 +764,13 @@
(transcoded-port p maybe-transcoder)
(wrap-binary-output-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))])
(lambda (pos) (file-position p pos))
#t))])
(values
p2
(lambda ()
(flush-output p2)
(unless (port-closed? p2)
(flush-output p2))
(get-output-bytes p #t)))))
(define (call-with-bytevector-output-port proc [maybe-transcoder #f])
@ -769,7 +797,8 @@
(lambda ()
(wrap-binary-output-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(lambda (pos) (file-position p pos))
#f))))
(define standard-error-port
@ -777,7 +806,8 @@
(lambda ()
(wrap-binary-output-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(lambda (pos) (file-position p pos))
#f))))
(define output-ports (make-weak-hasheq))
@ -810,13 +840,14 @@
#f
#f
void
0
1
#f)
get-position
set-position!))
set-position!
#t))
(define (make-custom-textual-output-port id write! get-position set-position! close)
(transcoded-port
(make-textual-output-port
(wrap-binary-output-port
(make-output-port
id
@ -862,11 +893,12 @@
#f
#f
void
0
1
#f)
get-position
set-position!)
utf8-transcoder))
set-position!
#t)
#f))
;; ----------------------------------------
@ -943,14 +975,21 @@
(do-open-file-output-port 'open-file-input/output-port
filename
options
buffer-mode
(if (eq? buffer-mode 'line)
'block
buffer-mode)
maybe-transcoder
(lambda (name #:exists mode)
(let-values ([(in out) (open-input-output-file name #:exists mode)])
(file-stream-buffer-mode out buffer-mode)
(make-dual-port in out)))
;; Input and output buffering make `file-position' iffy.
(if (eq? buffer-mode 'none)
file-position
(case-lambda
[(p) (file-position (dual-port-in p))]
[(p pos)
(flush-output p)
(file-position (dual-port-in p) pos)])
#f)
wrap-binary-input/output-port))
@ -1007,10 +1046,3 @@
(put-string p s)
(result))
(lambda () (close-output-port p)))))

15
collects/scribblings/reference/port-lib.scrbl
View File

@ -59,7 +59,12 @@ input ports as it becomes available.}
(-> (one-of/c 'block 'none #f)))
false/c)
#f]
[buffering? any/c #f])
[buffering? any/c #f]
[on-consume (or/c ((or/c exact-nonnegative-integer? eof-object?
procedure? evt?)
. -> . any)
false/c)
#f])
input-port?]{
Similar to @scheme[make-input-port], but if the given @scheme[read-in]
@ -88,7 +93,13 @@ can be called to read more characters than are immediately demanded by
the user of the new port. If @scheme[buffer] mode is not @scheme[#f],
then @scheme[buffering?] determines the initial buffer mode, and
@scheme[buffering?] is enabled after a buffering change only if the
new mode is @scheme['block].}
new mode is @scheme['block].
If @scheme[on-consumed] is not @scheme[#f], it is called when data is
read from the port, as opposed to merely peeked. The argument to
@scheme[on-consume] is the result value of the port's reading
procedure, so it can be an integer or any result from
@scheme[read-in].}
@defproc[(make-limited-input-port [in input-port?]

365
collects/tests/r6rs/io/ports.ss
View File

@ -3,6 +3,7 @@
(library (tests r6rs io ports)
(export run-io-ports-tests)
(import (rnrs)
(rnrs mutable-strings (6))
(tests r6rs test))
(define-syntax test-transcoders
@ -66,6 +67,37 @@
(test/exn (string->bytevector "a\x185;b" (make-transcoder (latin-1-codec) 'lf 'raise))
&i/o-encoding))]))
(define-syntax test-positions
(syntax-rules ()
[(_ make)
(begin
(let* ([p (make "custom"
(lambda (? start count) 0)
(lambda () 0)
#f
(lambda () 'ok))])
(test (port-has-port-position? p) #t)
(test (port-has-set-port-position!? p) #f)
(test (port-position p) 0)
(test/unspec (close-port p)))
(let* ([p (make "custom"
(lambda (? start count) 0)
#f
(lambda (pos) 'ok)
(lambda () 'ok))])
(test (port-has-port-position? p) #f)
(test (port-has-set-port-position!? p) #t)
(test/unspec (set-port-position! p 0))
(test/unspec (close-port p)))
(let* ([p (make "custom"
(lambda (? start count) 0)
#f
#f
(lambda () 'ok))])
(test (port-has-port-position? p) #f)
(test (port-has-set-port-position!? p) #f)
(test/unspec (close-port p))))]))
(define (run-io-ports-tests)
(test (enum-set->list (file-options)) '())
@ -153,6 +185,7 @@
(test (textual-port? p) #f)
(test (output-port? p) #t)
(test (input-port? p) #f)
(test/unspec (flush-output-port p))
(test/unspec (close-port p)))
;; Don't re-create:
@ -235,10 +268,13 @@
;; Check buffer modes? Just make sure they're accepted:
(let ([p (open-file-output-port "io-tmp1" (file-options no-create) 'line)])
(test (output-port-buffer-mode p) 'line)
(close-port p))
(let ([p (open-file-output-port "io-tmp1" (file-options no-create) 'block)])
(test (output-port-buffer-mode p) 'block)
(close-port p))
(let ([p (open-file-output-port "io-tmp1" (file-options no-create) 'none)])
(test (output-port-buffer-mode p) 'none)
(close-port p))
(let ([p (open-file-input-port "io-tmp1" (file-options) 'line)])
@ -253,6 +289,11 @@
(let ([p (open-file-output-port "io-tmp1" (file-options no-create)
'block (make-transcoder (latin-1-codec)))])
(when (port-has-port-position? p)
(test/unspec (port-position p))
(when (port-has-set-port-position!? p)
(let ([pos (port-position p)])
(test/unspec (set-port-position! p pos)))))
(test (binary-port? p) #f)
(test (textual-port? p) #t)
(test/unspec (put-string p "apple"))
@ -315,18 +356,69 @@
(lambda (str tr)
(let ([p (open-file-output-port "io-tmp1" (file-options no-create)
'block tr)])
(put-string p str)
(close-port p))
(let ([p (open-file-input-port "io-tmp1")])
(dynamic-wind
(lambda () 'ok)
(lambda () (get-bytevector-all p))
(lambda () (close-port p)))))])
(lambda () (put-string p str))
(lambda () (close-port p))))
(let ([p (open-file-input-port "io-tmp1")])
(let ([v (get-bytevector-all p)])
(close-port p)
v)))])
(test-transcoders bytevector->string-via-file
string->bytevector-via-file))
(let ([test-i+o
(lambda (buf)
(let ([p (open-file-input/output-port "io-tmp1"
(file-options no-fail)
buf)])
(if (and (port-has-port-position? p)
(port-has-set-port-position!? p))
(begin
(port-position p)
(test (port-position p) 0)
(test/unspec (put-bytevector p #vu8(7 9 11)))
(unless (eq? buf 'none)
(test/unspec (flush-output-port p)))
(test (port-position p) 3)
(test/unspec (set-port-position! p 0))
(test (get-bytevector-n p 2) #vu8(7 9))
(test/unspec (put-bytevector p #vu8(13 15 17)))
(unless (eq? buf 'none)
(test/unspec (flush-output-port p)))
(test/unspec (set-port-position! p 3))
(test (get-bytevector-n p 2) #vu8(15 17)))
(begin
(test/unspec (put-bytevector p #vu8(7 9 11)))
(test (get-u8 p) (eof-object))))
(test/unspec (close-port p))))])
(test-i+o 'line)
(test-i+o 'block)
(test-i+o 'none))
(let ([p (open-file-input/output-port "io-tmp1"
(file-options no-fail)
'none
(make-transcoder (utf-8-codec)))])
(test/unspec (put-string p "berry"))
(test/unspec (close-port p)))
(let ([p (open-file-input/output-port "io-tmp1"
(file-options no-fail no-truncate)
'none
(make-transcoder (utf-8-codec)))])
(test (get-string-n p 4) "berr")
(test/unspec (put-string p "apple"))
(test/unspec (close-port p)))
(let ([p (open-file-input/output-port "io-tmp1"
(file-options no-fail no-truncate)
'none
(make-transcoder (utf-8-codec)))])
(test (get-string-n p 10) "berrapple")
(test/unspec (close-port p)))
(test/unspec (delete-file "io-tmp1"))
;; ----------------------------------------
;; bytevector ports
@ -338,7 +430,7 @@
(test (lookahead-u8 p) 1)
(test (get-u8 p) 1)
(let ([bv (make-bytevector 10 0)])
(test/unspec (get-bytevector-n! p bv 1 7))
(test (get-bytevector-n! p bv 1 7) 2)
(test bv #vu8(0 2 3 0 0 0 0 0 0 0)))
(test (get-bytevector-some p) (eof-object))
(close-port p))
@ -354,14 +446,261 @@
(test (get) #vu8(10 11 12 13 18 16))
(test (get) #vu8())
(close-port p))
(test (call-with-bytevector-output-port
(lambda (p)
(put-bytevector p #vu8(1 2 3))))
#vu8(1 2 3))
(test (call-with-bytevector-output-port
(lambda (p)
(put-string p "app\x3BB;e"))
(make-transcoder (utf-8-codec)))
#vu8(97 112 112 206 187 101))
(let ([bytevector->string-via-port
(lambda (bv tr)
(let ([p (open-bytevector-input-port bv tr)])
(dynamic-wind
(lambda () 'ok)
(lambda () (get-string-all p))
(lambda () (close-port p)))))]
[string->bytevector-via-port
(lambda (str tr)
(let-values ([(p get) (open-bytevector-output-port tr)])
(dynamic-wind
(lambda () 'ok)
(lambda ()
(put-string p str)
(get))
(lambda ()
(close-port p)))))])
(test-transcoders bytevector->string-via-port
string->bytevector-via-port))
;; ----------------------------------------
;; string ports
(let ([p (open-string-input-port "app\x3BB;e\r\nban")])
(test (input-port? p) #t)
(test (binary-port? p) #f)
(test (textual-port? p) #t)
(test (get-char p) #\a)
(test (lookahead-char p) #\p)
(test (get-line p) "pp\x3BB;e\r")
(let ([s (make-string 10 #\_)])
(test (get-string-n! p s 1 9) 3)
(test s "_ban______")))
(let ([p (open-string-input-port "(1 2 3) 4")])
(test (get-datum p) '(1 2 3))
(close-port p))
(let-values ([(p get) (open-string-output-port)])
(test/unspec (put-string p "app\x3BB;e"))
(test (get) "app\x3BB;e")
(test (get) "")
(close-port p))
(test (call-with-string-output-port
(lambda (p)
(test/unspec (put-string p "app\x3BB;y"))))
"app\x3BB;y")
;; ----------------------------------------
;; custom ports
(let* ([pos 0]
[p (make-custom-binary-input-port
"custom in"
(lambda (bv start count)
(if (= pos 16)
0
(begin
(set! pos (+ 1 pos))
(bytevector-u8-set! bv start pos)
1)))
(lambda () pos)
(lambda (p) (set! pos p))
(lambda () 'ok))])
(test (port-has-port-position? p) #t)
(test (port-has-set-port-position!? p) #t)
(test (port-position p) 0)
(test (get-bytevector-n p 3) #vu8(1 2 3))
(test (port-position p) 3)
(test (lookahead-u8 p) 4)
(test (lookahead-u8 p) 4)
(test (port-position p) 3)
(test/unspec (set-port-position! p 10))
(get-bytevector-n p 2)
(test (get-bytevector-n p 2) #vu8(13 14))
(test (get-bytevector-n p 2) #vu8(15 16))
(test (get-bytevector-n p 2) (eof-object))
(test/unspec (set-port-position! p 2))
(test (get-bytevector-n p 3) #vu8(3 4 5))
(test/unspec (close-port p)))
(test-positions make-custom-binary-input-port)
(let* ([pos 0]
[p (make-custom-textual-input-port
"custom in"
(lambda (bv start count)
(if (= pos 16)
0
(begin
(set! pos (+ 1 pos))
(string-set! bv start (integer->char (+ 96 pos)))
1)))
(lambda () pos)
(lambda (p) (set! pos p))
(lambda () 'ok))])
(test (port-position p) 0)
(test (get-string-n p 3) "abc")
(test (port-position p) 3)
(test (lookahead-char p) #\d)
(test (lookahead-char p) #\d)
(test (port-position p) 3)
(test/unspec (set-port-position! p 10))
(get-string-n p 2)
(test (get-string-n p 2) "mn")
(test (get-string-n p 2) "op")
(test (get-string-n p 2) (eof-object))
(test/unspec (set-port-position! p 2))
(test (get-string-n p 3) "cde")
(test/unspec (close-port p)))
(test-positions make-custom-textual-input-port)
(let* ([accum '()]
[p (make-custom-binary-output-port
"custom out"
(lambda (bv start count)
(let ([bv2 (make-bytevector count)])
(bytevector-copy! bv start bv2 0 count)
(set! accum (append
(reverse (bytevector->u8-list bv2))
accum))
count))
(lambda () (length accum))
(lambda (pos) (set! accum (list-tail accum (- (length accum) pos))))
(lambda () 'ok))])
(test (port-has-port-position? p) #t)
(test (port-has-set-port-position!? p) #t)
(test (port-position p) 0)
(test/unspec (put-bytevector p #vu8(2 4 6)))
(test accum '(6 4 2))
(test (port-position p) 3)
(test/unspec (set-port-position! p 2))
(test (port-position p) 2)
(test accum '(4 2))
(test/unspec (put-bytevector p #vu8(3 7 9 11) 2 1))
(test accum '(9 4 2))
(test/unspec (close-port p)))
(test-positions make-custom-binary-output-port)
(let* ([accum '()]
[p (make-custom-textual-output-port
"custom out"
(lambda (str start count)
(let ([str (substring str start count)])
(set! accum (append
(reverse (string->list str))
accum))
count))
(lambda () (length accum))
(lambda (pos) (set! accum (list-tail accum (- (length accum) pos))))
(lambda () 'ok))])
(test (port-has-port-position? p) #t)
(test (port-has-set-port-position!? p) #t)
(test (port-position p) 0)
(test/unspec (put-string p "abc"))
(test accum '(#\c #\b #\a))
(test (port-position p) 3)
(test/unspec (set-port-position! p 2))
(test (port-position p) 2)
(test accum '(#\b #\a))
(test/unspec (put-string p "xyzw" 2 1))
(test accum '(#\z #\b #\a))
(test/unspec (close-port p)))
(test-positions make-custom-textual-output-port)
(let* ([save #f]
[p (make-custom-binary-input/output-port
"custom in"
(lambda (bv start end)
(bytevector-u8-set! bv start 7)
1)
(lambda (bv start end)
(set! save (bytevector-u8-ref bv start))
1)
#f #f #f)])
(test/unspec (put-u8 p 10))
(test save 10)
(test (get-u8 p) 7)
(close-port p))
(test-positions (lambda (id r/w get set close)
(make-custom-binary-input/output-port
id r/w r/w get set close)))
(let* ([save #f]
[p (make-custom-textual-input/output-port
"custom in"
(lambda (str start end)
(string-set! str start #\!)
1)
(lambda (str start end)
(set! save (string-ref str start))
1)
#f #f #f)])
(test/unspec (put-char p #\q))
(test save #\q)
(test (get-char p) #\!)
(close-port p))
(test-positions (lambda (id r/w get set close)
(make-custom-textual-input/output-port
id r/w r/w get set close)))
;; ----------------------------------------
;; stdin, stderr, stdout
(let ([p (standard-input-port)])
(test (input-port? p) #t)
(test (output-port? p) #f)
(test (binary-port? p) #t)
(test (textual-port? p) #f)
(test/unspec (close-port p)))
(let ([p (standard-output-port)])
(test (input-port? p) #f)
(test (output-port? p) #t)
(test (binary-port? p) #t)
(test (textual-port? p) #f)
(test/unspec (close-port p)))
(let ([p (standard-error-port)])
(test (input-port? p) #f)
(test (output-port? p) #t)
(test (binary-port? p) #t)
(test (textual-port? p) #f)
(test/unspec (close-port p)))
(test (input-port? (current-input-port)) #t)
(test (output-port? (current-input-port)) #f)
(test (binary-port? (current-input-port)) #f)
(test (textual-port? (current-input-port)) #t)
(test (input-port? (current-output-port)) #f)
(test (output-port? (current-output-port)) #t)
(test (binary-port? (current-output-port)) #f)
(test (textual-port? (current-output-port)) #t)
;; ----------------------------------------
;;
)
#;(run-io-ports-tests)
#;(report-test-results)
)
))

10
collects/tests/r6rs/test.ss
View File

@ -21,10 +21,12 @@
(define-syntax test
(syntax-rules ()
[(_ expr expected)
(check-test 'expr
(guard (c [#t (make-err c)])
expr)
expected)]))
(begin
;; (write 'expr) (newline)
(check-test 'expr
(guard (c [#t (make-err c)])
expr)
expected))]))
(define-syntax test/approx
(syntax-rules ()