From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 7 Jan 2017 09:19:48 +0000 (-0800)
Subject: Implement bytevector-fill! and change arg order to match R7Rs.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~186
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=994ef242e0fb3421b8cc4f87bbd698b4dd4b37d1;p=mit-scheme.git

Implement bytevector-fill! and change arg order to match R7Rs.
---

diff --git a/src/microcode/bytevector.c b/src/microcode/bytevector.c
index 8b1eb5122..cf103da29 100644
--- a/src/microcode/bytevector.c
+++ b/src/microcode/bytevector.c
@@ -127,9 +127,9 @@ DEFINE_PRIMITIVE ("bytevector-fill!", Prim_bytevector_fill, 4, 4, 0)
   {
     unsigned long length;
     uint8_t * v = (arg_bytevector (1, (&length)));
-    unsigned long end = (arg_ulong_index_integer (3, (length + 1)));
-    unsigned long start = (arg_ulong_index_integer (2, (end + 1)));
-    uint8_t value = (arg_byte (4));
+    uint8_t value = (arg_byte (2));
+    unsigned long end = (arg_ulong_index_integer (4, (length + 1)));
+    unsigned long start = (arg_ulong_index_integer (3, (end + 1)));
     memset ((v + start), value, (end - start));
   }
   PRIMITIVE_RETURN (UNSPECIFIC);
diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index f01d322a5..5fdd04ee3 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -35,7 +35,6 @@ USA.
 
 (define-primitives
   (allocate-bytevector 1)
-  (bytevector-fill! 4)
   (bytevector-length 1)
   (bytevector-u8-ref 2)
   (bytevector-u8-set! 3)
@@ -49,7 +48,7 @@ USA.
 (define (make-bytevector k #!optional byte)
   (let ((bytevector (allocate-bytevector k)))
     (if (not (default-object? byte))
-	(bytevector-fill! bytevector 0 k byte))
+	(bytevector-fill! bytevector byte 0 k))
     bytevector))
 
 (define (bytevector . bytes)
@@ -72,6 +71,13 @@ USA.
       (bytevector-copy! bytevector index (car bytevectors)))
     bytevector))
 
+(define (bytevector-fill! bytevector fill #!optional start end)
+  ((ucode-primitive bytevector-fill! 4)
+   bytevector
+   fill
+   (if (default-object? start) 0 start)
+   (if (default-object? end) (bytevector-length bytevector) end)))
+
 (define (bytevector-copy bytevector #!optional start end)
   ((ucode-primitive bytevector-copy 3)
    bytevector
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c106c2a86..5cf6b9366 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1125,6 +1125,7 @@ USA.
 	  bytevector-append
 	  bytevector-copy
 	  bytevector-copy!
+	  bytevector-fill!
 	  bytevector-length
 	  bytevector-u8-ref
 	  bytevector-u8-set!
diff --git a/tests/runtime/test-bytevector.scm b/tests/runtime/test-bytevector.scm
index 0fe5de2bc..cda1d3db3 100644
--- a/tests/runtime/test-bytevector.scm
+++ b/tests/runtime/test-bytevector.scm
@@ -153,6 +153,32 @@ USA.
 	   (v (apply bytevector bytes)))
       (bytevector-copy! v 5 v 3 7)
       (assert-equal v (bytevector 15 14 13 12 11 12 11 10 9 6 5 4 3 2 1 0)))))
+
+(define-test 'bytevector-fill!
+  (lambda ()
+    (do ((n 0 (+ n 1)))
+	((not (< n 16)))
+      (let ((bytes (reverse (iota n))))
+	(do ((end 0 (+ end 1)))
+	    ((> end n))
+	  (do ((start 0 (+ start 1)))
+	      ((> start end))
+	    (let ((v (apply bytevector bytes)))
+	      (bytevector-fill! v 51 start end)
+	      (assert-equal v
+			    (apply bytevector
+				   (append (sublist bytes 0 start)
+					   (make-list (- end start) 51)
+					   (sublist bytes end n))))))))
+      (assert-range-error
+       (lambda ()
+	 (bytevector-fill! (make-bytevector n) 51 0 (+ n 1))))
+	  (assert-range-error
+	   (lambda ()
+	     (bytevector-fill! (make-bytevector n) 51 n (+ n 1))))
+	  (assert-range-error
+	   (lambda ()
+	     (bytevector-fill! (make-bytevector n) 51 -1 n))))))
 
 (define (test-bytevector-properties v bytes)
   (assert-true (bytevector? v))