Add tests for bytevector output, and fix some bugs in write-bytevector.

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 01836ffe719eab25bb87a73ded1a320d97e23301..d648c870c2e98fa9f17f5ef2d3d5e1e172bc5592 100644 (file)
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -464,19 +464,24 @@ USA.
              (available (output-buffer-available ob 'write-bytevector)))
          (cond ((fix:<= remaining available)
                 (fix:- (write-to-buffer index remaining) start))
-               ((fix:> available 0)
-                (let ((index* (write-to-buffer index available)))
+               ((fix:< available output-buffer-length)
+                ;; There's already some data in the buffer, so fill it, drain
+                ;; it, and write the rest directly.
+                (let ((index*
+                       (if (fix:> available 0)
+                           (write-to-buffer index available)
+                           index)))
                   (let ((n (drain-output-buffer ob)))
                     (if (and n (fix:> n 0))
                         (if (fix:< n output-buffer-length)
                             ;; partial drain
                             (loop index*)
                             ;; full drain
-                            (write-to-sink index))
+                            (write-to-sink index*))
                         ;; no progress was made
                         (fix:- index* start)))))
                (else
-                (write-to-sink start)))))
+                (write-to-sink index)))))
 
       (define (write-to-buffer index n)
        (let ((bi (buffer-end ob))

diff --git a/tests/runtime/test-binary-port.scm b/tests/runtime/test-binary-port.scm
index 1a7cab4964785d6aa6ba5e9a3ea664db1cdf8bb1..9f443df2bddfd5b1deade1af59831b39935ea263 100644 (file)
--- a/tests/runtime/test-binary-port.scm
+++ b/tests/runtime/test-binary-port.scm
@@ -28,14 +28,24 @@ USA.
 
 (declare (usual-integrations))
 \f
+(define (random-bytevector k)
+  (let ((bv (make-bytevector k)))
+    (do ((i 0 (fix:+ i 1)))
+       ((not (fix:< i k)))
+      (bytevector-u8-set! bv i (random-integer #x100)))
+    bv))
+
 (define bv0 (bytevector))
-(define bv1 (apply bytevector (reverse (iota 9))))
+(define bv1 (random-bytevector 9))
+(define bv2 (random-bytevector 1000))
+(define bv3 (random-bytevector 4096))  ;buffer-size
+(define bv4 (random-bytevector 10000))
+(define all-bvs (list bv0 bv1 bv2 bv3 bv4))
 (define strides '(1 2 3 5 7 11))
 
 (define-test 'peek/read
   (lambda ()
-    (test-peek/read bv0)
-    (test-peek/read bv1)))
+    (for-each test-peek/read all-bvs)))
 
 (define (test-peek/read bv)
   (let ((port (open-input-bytevector bv)))
@@ -55,8 +65,7 @@ USA.
 
 (define-test 'read-bytevector
   (lambda ()
-    (test-read-bytevector bv0)
-    (test-read-bytevector bv1)))
+    (for-each test-read-bytevector all-bvs)))
 
 (define (test-read-bytevector bv)
   (for-each (lambda (stride)
@@ -83,8 +92,7 @@ USA.
 
 (define-test 'read-bytevector!
   (lambda ()
-    (test-read-bytevector! bv0)
-    (test-read-bytevector! bv1)))
+    (for-each test-read-bytevector! all-bvs)))
 
 (define (test-read-bytevector! bv)
   (for-each (lambda (stride)
@@ -112,6 +120,46 @@ USA.
     (assert-equal (bytevector-copy target 0 (bytevector-length bv))
                  bv)))
 
+(define-test 'write-u8
+  (lambda ()
+    (for-each test-write-u8 all-bvs)))
+
+(define (test-write-u8 bv)
+  (let ((port (open-output-bytevector)))
+    (assert-binary-output-port port)
+
+    (do ((i 0 (fix:+ i 1)))
+       ((not (fix:< i (bytevector-length bv))))
+      (write-u8 (bytevector-u8-ref bv i) port))
+
+    (assert-equal (get-output-bytevector port) bv)))
+
+(define-test 'write-bytevector
+  (lambda ()
+    (for-each test-write-bytevector all-bvs)))
+
+(define (test-write-bytevector bv)
+  (for-each (lambda (stride)
+             (test-write-bytevector-1 bv (lambda () stride)))
+           strides)
+  (test-write-bytevector-1 bv (sequential-get-stride strides))
+  (test-write-bytevector-1 bv (sequential-get-stride (reverse strides))))
+
+(define (test-write-bytevector-1 bv get-stride)
+  (let ((port (open-output-bytevector)))
+    (assert-binary-output-port port)
+
+    (let loop ((i 0))
+      (let ((stride (get-stride))
+           (remaining (fix:- (bytevector-length bv) i)))
+       (if (fix:> remaining 0)
+           (let ((i* (fix:+ i (fix:min stride remaining))))
+             (assert-eqv (write-bytevector bv port i i*)
+                         (fix:- i* i))
+             (loop i*)))))
+
+    (assert-equal (get-output-bytevector port) bv)))
+
 (define (sequential-get-stride strides)
   (lambda ()
     (let ((stride (car strides)))