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

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)

scheme/last-revision

@@ -1 +1 @@
-1210
+1212

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))
 )