From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 21 Feb 2017 03:40:04 +0000 (-0800)
Subject: Implement bytevector-builder.
X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~50
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c67b3b44229733e1abc15fbe5d8b8ce38c381714;p=mit-scheme.git

Implement bytevector-builder.
---

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index dca7b66f8..ced0b4ee4 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -121,6 +121,31 @@ USA.
   (if (default-object? modulus)
       ((ucode-primitive string-hash) bytevector)
       ((ucode-primitive string-hash-mod) bytevector modulus)))
+
+(define (bytevector-builder)
+  (let ((builder
+	 (make-sequence-builder (lambda () (allocate-bytevector 16))
+				bytevector-length
+				bytevector-u8-set!
+				bytevector-builder:finish-build)))
+    (lambda (#!optional object)
+      (cond ((default-object? object) ((builder 'build)))
+	    ((byte? object) ((builder 'append-element!) object))
+	    ((bytevector? object) ((builder 'append-sequence!) object))
+	    ((memq object '(empty? count reset!)) ((builder object)))
+	    (else (error "Not a byte or bytevector:" object))))))
+
+(define (bytevector-builder:finish-build parts)
+  (let ((result
+	 (do ((parts parts (cdr parts))
+	      (n 0 (fix:+ n (cdar parts))))
+	     ((not (pair? parts))
+	      (allocate-bytevector n)))))
+    (do ((parts parts (cdr parts))
+	 (i 0 (fix:+ i (cdar parts))))
+	((not (pair? parts)))
+      (bytevector-copy! result i (caar parts) 0 (cdar parts)))
+    result))
 
 ;;;; U16 accessors
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a91129471..e580ec291 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1194,6 +1194,7 @@ USA.
 	  (byte? u8?)
 	  bytevector
 	  bytevector-append
+	  bytevector-builder
 	  bytevector-copy
 	  bytevector-copy!
 	  bytevector-fill!
diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 81263b0be..979b3dde9 100644
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -237,8 +237,9 @@ USA.
 		  (legacy-string-allocate n)
 		  (full-string-allocate n))))))
     (do ((parts parts (cdr parts))
-	 (i 0 (string-copy! result i (caar parts) 0 (cdar parts))))
-	((not (pair? parts))))
+	 (i 0 (fix:+ i (cdar parts))))
+	((not (pair? parts)))
+      (string-copy! result i (caar parts) 0 (cdar parts)))
     result))
 
 (define (string-copy! to at from #!optional start end)