From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 7 Mar 2017 01:25:46 +0000 (-0800)
Subject: Change sequence builders to copy small sequences.
X-Git-Tag: mit-scheme-pucked-9.2.12~195^2~7
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3b05e1e622932f11a075303faa09ab63aa82b025;p=mit-scheme.git

Change sequence builders to copy small sequences.
---

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index bd544837d..9abe8c59b 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -123,9 +123,11 @@ USA.
 
 (define (bytevector-builder)
   (let ((builder
-	 (make-sequence-builder (lambda () (allocate-bytevector 16))
+	 (make-sequence-builder allocate-bytevector
 				bytevector-length
+				bytevector-u8-ref
 				bytevector-u8-set!
+				16
 				bytevector-builder:finish-build)))
     (lambda (#!optional object)
       (cond ((default-object? object) ((builder 'build)))
diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 0aeb00512..bf8adf72e 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -580,8 +580,8 @@ USA.
 
 ;;;; Builder for vector-like sequences
 
-(define (make-sequence-builder make-buffer sequence-length sequence-set!
-			       finish-build)
+(define (make-sequence-builder make-sequence sequence-length sequence-ref
+			       sequence-set! buffer-length finish-build)
     ;; This is optimized to minimize copying, so it wastes some space.
   (let ((buffers)
 	(buffer)
@@ -589,13 +589,13 @@ USA.
 
     (define (reset!)
       (set! buffers '())
-      (set! buffer (make-buffer))
+      (set! buffer (make-sequence buffer-length))
       (set! index 0)
       unspecific)
 
     (define (new-buffer!)
       (set! buffers (cons (cons buffer index) buffers))
-      (set! buffer (make-buffer))
+      (set! buffer (make-sequence buffer-length))
       (set! index 0)
       unspecific)
 
@@ -609,17 +609,23 @@ USA.
 	  ((not (pair? buffers)) (fix:+ n index))))
 
     (define (append-element! element)
-      (if (not (fix:< index (sequence-length buffer)))
+      (if (not (fix:< index buffer-length))
 	  (new-buffer!))
       (sequence-set! buffer index element)
       (set! index (fix:+ index 1))
       unspecific)
 
     (define (append-sequence! sequence)
-      (if (fix:> index 0)
-	  (new-buffer!))
-      (set! buffers (cons (cons sequence (sequence-length sequence)) buffers))
-      unspecific)
+      (let ((length (sequence-length sequence)))
+	(if (fix:<= length buffer-length)
+	    (do ((i 0 (fix:+ i 1)))
+		((not (fix:< i length)))
+	      (append-element! (sequence-ref sequence i)))
+	    (begin
+	      (if (fix:> index 0)
+		  (new-buffer!))
+	      (set! buffers (cons (cons sequence length) buffers))
+	      unspecific))))
 
     (define (build)
       (finish-build (reverse (cons (cons buffer index) buffers))))
diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 70211868a..8ed272258 100644
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -216,9 +216,11 @@ USA.
 
 (define (string-builder)
   (let ((builder
-	 (make-sequence-builder (lambda () (full-string-allocate 16))
+	 (make-sequence-builder full-string-allocate
 				string-length
+				string-ref
 				string-set!
+				16
 				string-builder:finish-build)))
     (lambda (#!optional object)
       (cond ((default-object? object) ((builder 'build)))