>From 45e4f87d35c4a7b2e779feade9d1da2d326876e0 Mon Sep 17 00:00:00 2001
From: Thomas Hintz <address@hidden>
Date: Tue, 21 Oct 2014 10:38:00 -0700
Subject: [PATCH] Improving performance of write-u8vector.

Signed-off-by: Peter Bex <address@hidden>
---
 NEWS                   |    3 +++
 srfi-4.scm             |   18 +++++++++++-------
 tests/srfi-4-tests.scm |   32 +++++++++++++++++++++++++++++++-
 3 files changed, 45 insertions(+), 8 deletions(-)

diff --git a/NEWS b/NEWS
index 6fa2a4b..ba7f3b7 100644
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,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 fffa8da..5cd346e 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 1d0a1b5..8b78140 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())))))
-- 
1.7.10.4