diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss index a8eae65..dcc47c2 100644 --- a/scheme/ikarus.io.ss +++ b/scheme/ikarus.io.ss @@ -182,10 +182,10 @@ (define r6rs-mode-tag #x1000) - (define ($make-custom-binary-input-port id + (define ($make-custom-binary-port attrs id read! write! get-position set-position! close buffer-size) (let ([bv (make-bytevector buffer-size)]) - ($make-port 0 0 bv 0 #f #f 0 id read! write! get-position + ($make-port 0 0 bv 0 #f #f attrs id read! write! get-position set-position! close))) (define (make-custom-binary-input-port id @@ -198,7 +198,7 @@ (error who "read! is not a procedure" read!)) (unless (or (procedure? close) (not close)) (error who "close should be either a procedure or #f" close)) - ($make-custom-binary-input-port id read! #f get-position + ($make-custom-binary-port 0 id read! #f get-position set-position! close 256)) (define (make-custom-binary-output-port id @@ -211,7 +211,9 @@ (error who "read! is not a procedure" write!)) (unless (or (procedure? close) (not close)) (error who "close should be either a procedure or #f" close)) - ($make-custom-binary-input-port id #f write! get-position + ($make-custom-binary-port + (fxior fast-put-tag fast-put-byte-tag) + id #f write! get-position set-position! close 256)) (define (input-transcoder-attrs x) diff --git a/scheme/last-revision b/scheme/last-revision index 9c2de76..1f8248c 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1210 +1212 diff --git a/scheme/tests/io.ss b/scheme/tests/io.ss index b42594e..67e7291 100755 --- a/scheme/tests/io.ss +++ b/scheme/tests/io.ss @@ -463,8 +463,33 @@ (put-string p "HELLO THERE\n") (flush-output-port p))) +(define (test-custom-binary-output-ports) + (define ls '()) + (let ([p (make-custom-binary-output-port "foo" + (lambda (bv i c) + (let f ([i i] [c c]) + (unless (fx= c 0) + (set! ls (cons (bytevector-u8-ref bv i) ls)) + (f (fx+ i 1) (fx- c 1)))) + c) + #f + #f + #f)]) + (let f ([i 0]) + (unless (fx= i 10000) + (put-u8 p (mod i 256)) + (f (+ i 1)))) + (flush-output-port p) + (let f ([i 0] [ls (reverse ls)]) + (unless (null? ls) + (assert (fx= (mod i 256) (car ls))) + (f (fx+ i 1) (cdr ls)))))) + + + (define (test-io) (test-custom-binary-input-ports) + (test-custom-binary-output-ports) (run-exhaustive-tests) (test-input-files)) )