From e6b2b190304cb569dbb39a525bc84809940d71e6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 28 Apr 2008 21:59:18 +0000 Subject: [PATCH] r6rs io/ports-6 repairs and tests svn: r9523 --- collects/mzlib/port.ss | 38 +- collects/rnrs/io/ports-6.ss | 162 ++++---- collects/scribblings/reference/port-lib.scrbl | 15 +- collects/tests/r6rs/io/ports.ss | 365 +++++++++++++++++- collects/tests/r6rs/test.ss | 10 +- 5 files changed, 496 insertions(+), 94 deletions(-) diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss index 59384f4b14..922bf97d66 100644 --- a/collects/mzlib/port.ss +++ b/collects/mzlib/port.ss @@ -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))) diff --git a/collects/rnrs/io/ports-6.ss b/collects/rnrs/io/ports-6.ss index 7d70d634de..09ce7285a4 100644 --- a/collects/rnrs/io/ports-6.ss +++ b/collects/rnrs/io/ports-6.ss @@ -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))))) - - - - - - - diff --git a/collects/scribblings/reference/port-lib.scrbl b/collects/scribblings/reference/port-lib.scrbl index 2a20078db2..b73d77e7a4 100644 --- a/collects/scribblings/reference/port-lib.scrbl +++ b/collects/scribblings/reference/port-lib.scrbl @@ -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?] diff --git a/collects/tests/r6rs/io/ports.ss b/collects/tests/r6rs/io/ports.ss index b3a39e48c1..eb7364c03a 100644 --- a/collects/tests/r6rs/io/ports.ss +++ b/collects/tests/r6rs/io/ports.ss @@ -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) - ) + )) diff --git a/collects/tests/r6rs/test.ss b/collects/tests/r6rs/test.ss index 9bd23b5899..e4579bea45 100644 --- a/collects/tests/r6rs/test.ss +++ b/collects/tests/r6rs/test.ss @@ -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 ()