conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Added tests for custom-binary-output-ports (and fixed it too)

This commit is contained in:
Abdulaziz Ghuloum 2007-12-10 10:53:17 -05:00
parent 3575b0c8d8
commit 4a3f9a334a
3 changed files with 32 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
scheme/ikarus.io.ss
View File

@ -182,10 +182,10 @@
(define r6rs-mode-tag #x1000) (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) read! write! get-position set-position! close buffer-size)
(let ([bv (make-bytevector 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))) set-position! close)))
(define (make-custom-binary-input-port id (define (make-custom-binary-input-port id
@ -198,7 +198,7 @@
(error who "read! is not a procedure" read!)) (error who "read! is not a procedure" read!))
(unless (or (procedure? close) (not close)) (unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" 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)) set-position! close 256))
(define (make-custom-binary-output-port id (define (make-custom-binary-output-port id
@ -211,7 +211,9 @@
(error who "read! is not a procedure" write!)) (error who "read! is not a procedure" write!))
(unless (or (procedure? close) (not close)) (unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" 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)) set-position! close 256))
(define (input-transcoder-attrs x) (define (input-transcoder-attrs x)

2
scheme/last-revision
View File

@ -1 +1 @@
1210 1212

25
scheme/tests/io.ss
View File

@ -463,8 +463,33 @@
(put-string p "HELLO THERE\n") (put-string p "HELLO THERE\n")
(flush-output-port p))) (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) (define (test-io)
(test-custom-binary-input-ports) (test-custom-binary-input-ports)
(test-custom-binary-output-ports)
(run-exhaustive-tests) (run-exhaustive-tests)
(test-input-files)) (test-input-files))
) )