~ chicken-core (chicken-5) be1110b93f97e0258f5035e2ab06e92bc2712987

commit be1110b93f97e0258f5035e2ab06e92bc2712987
Author:     Thomas Hintz <t@thintz.com>
AuthorDate: Tue Oct 21 10:38:00 2014 -0700
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Wed Oct 29 07:34:42 2014 +1300

    Improve performance of write-u8vector.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index 720a69c7..a293ed21 100644
--- a/NEWS
+++ b/NEWS
@@ -35,6 +35,9 @@
   - normalize-pathname has been simplified to avoid adding trailing
      slashes or dots (#1153, thanks to Michele La Monaca and Mario Goulart).
 
+- Unit srfi-4:
+   - write-u8vector has been made more efficient (thanks to Thomas Hintz).
+
 - Unit lolevel:
   - Restore long-lost but still documented "vector-like?" procedure (#983)
 
diff --git a/srfi-4.scm b/srfi-4.scm
index fffa8da6..5cd346e0 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -639,15 +639,19 @@ EOF
 (define (subf32vector v from to) (subnvector v 'f32vector 4 from to 'subf32vector))
 (define (subf64vector v from to) (subnvector v 'f64vector 8 from to 'subf64vector))
 
-(define (write-u8vector v #!optional (port ##sys#standard-output) (from 0)
-			(to (u8vector-length v)))
+(define (write-u8vector v #!optional (port ##sys#standard-output) (from 0) to)
   (##sys#check-structure v 'u8vector 'write-u8vector)
   (##sys#check-output-port port #t 'write-u8vector)
-  (do ((i from (fx+ i 1)))
-      ((fx>= i to))
-    (##sys#write-char-0 
-     (integer->char (##core#inline "C_u_i_u8vector_ref" v i))
-     port) ) )
+  (let ((len (##core#inline "C_u_i_8vector_length" v)))
+    (check-range from 0 (fx+ (or to len) 1) 'write-u8vector)
+    (when to (check-range to from (fx+ len 1) 'write-u8vector))
+    ; using (write-string) since the "data" slot of a u8vector is
+    ; represented the same as a string
+    ((##sys#slot (##sys#slot port 2) 3) ; write-string
+     port
+     (if (and (fx= from 0) (or (not to) (fx= to len)))
+	 (##sys#slot v 1)
+	 (##sys#slot (subu8vector v from (or to len)) 1)))))
 
 (define (read-u8vector! n dest #!optional (port ##sys#standard-input) (start 0))
   (##sys#check-input-port port #t 'read-u8vector!)
diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm
index 1d0a1b57..8b781403 100644
--- a/tests/srfi-4-tests.scm
+++ b/tests/srfi-4-tests.scm
@@ -1,7 +1,7 @@
 ;;;; srfi-4-tests.scm
 
 
-(use srfi-1 srfi-4)
+(use srfi-1 srfi-4 ports)
 
 
 (define-syntax test1
@@ -54,3 +54,33 @@
   (assert (equal? u8vec #u8(112 113 114 115 116 107 108 109 110 111)))
   (assert (= 6  (read-u8vector! 10 u8vec input)))
   (assert (equal? u8vec #u8(117 118 119 120 121 122 108 109 110 111))))
+
+(assert (string=?
+	 "abc"
+	 (with-output-to-string
+	   (lambda ()
+	     (write-u8vector #u8(97 98 99))))))
+
+(assert (string=?
+	 "bc"
+	 (with-output-to-string
+	   (lambda ()
+	     (write-u8vector #u8(97 98 99) (current-output-port) 1)))))
+
+(assert (string=?
+	 "a"
+	 (with-output-to-string
+	   (lambda ()
+	     (write-u8vector #u8(97 98 99) (current-output-port) 0 1)))))
+
+(assert (string=?
+	 "b"
+	 (with-output-to-string
+	   (lambda ()
+	     (write-u8vector #u8(97 98 99) (current-output-port) 1 2)))))
+
+(assert (string=?
+	 ""
+	 (with-output-to-string
+	   (lambda ()
+	     (write-u8vector #u8())))))