Refactor make-sequence-builder and add vector-builder.

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 4cbecc02c838be892f6cb2d5d0858df74f1984e1..95c310b246076b372e2f00363514681448f3f1ae 100644 (file)
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -113,33 +113,14 @@ USA.
       ((ucode-primitive string-hash) bytevector)
       ((ucode-primitive string-hash-mod) bytevector modulus)))
 
-(define (bytevector-builder)
-  (let ((builder
-        (make-sequence-builder allocate-bytevector
-                               bytevector-length
-                               bytevector-u8-ref
-                               bytevector-u8-set!
-                               (lambda (bv) bv)
-                               16
-                               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))
+(define (bytevector-builder #!optional buffer-length)
+  (make-sequence-builder u8? bytevector? allocate-bytevector bytevector-length
+                        bytevector-u8-set! bytevector-copy!
+    (if (default-object? buffer-length)
+       16
+       (begin
+         (guarantee positive-fixnum? buffer-length 'bytevector-builder)
+         buffer-length))))
 \f
 (define (list->bytevector bytes)
   (let ((bytevector (allocate-bytevector (length bytes))))

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 1ab2a8357078f7bb4bc1804719c4ad671514e707..dc9b9fd9726e06afa3c665f4b8d02ab453b32e23 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -580,69 +580,76 @@ USA.
 \f
 ;;;; Builder for vector-like sequences
 
-(define (make-sequence-builder make-sequence sequence-length sequence-ref
-                              sequence-set! sequence-copy buffer-length
-                              finish-build)
-    ;; This is optimized to minimize copying, so it wastes some space.
+(define (make-sequence-builder elt? seq? make-seq seq-length seq-set! seq-copy!
+                              buffer-length)
   (let ((buffers)
        (buffer)
-       (index))
+       (start)
+       (index)
+       (count))
 
     (define (reset!)
       (set! buffers '())
-      (set! buffer (make-sequence buffer-length))
+      (set! buffer (make-seq buffer-length))
+      (set! start 0)
       (set! index 0)
+      (set! count 0)
       unspecific)
 
-    (define (new-buffer!)
-      (set! buffers (cons (cons buffer index) buffers))
-      (set! buffer (make-sequence buffer-length))
-      (set! index 0)
-      unspecific)
-
-    (define (empty?)
-      (and (fix:= 0 index)
-          (null? buffers)))
-
-    (define (count)
-      (do ((buffers buffers (cdr buffers))
-          (n 0 (fix:+ n (cdr (car buffers)))))
-         ((not (pair? buffers)) (fix:+ n index))))
-
-    (define (append-element! element)
-      (if (not (fix:< index buffer-length))
-         (new-buffer!))
-      (sequence-set! buffer index element)
+    (define (append-elt! elt)
+      (seq-set! buffer index elt)
       (set! index (fix:+ index 1))
-      unspecific)
-
-    (define (append-sequence! sequence)
-      (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)))
+      (set! count (fix:+ count 1))
+      (if (not (fix:< index buffer-length))
+         (begin
+           (set! buffers (cons (get-partial) buffers))
+           (set! buffer (make-seq buffer-length))
+           (set! start 0)
+           (set! index 0)
+           unspecific)))
+
+    (define (append-seq! seq)
+      (let ((length (seq-length seq)))
+       (if (fix:> length 0)
            (begin
-             (if (fix:> index 0)
-                 (new-buffer!))
-             (set! buffers
-                   (cons (cons (sequence-copy sequence) length)
-                         buffers))
+             (if (fix:> index start)
+                 (begin
+                   (set! buffers (cons (get-partial) buffers))
+                   (set! start index)))
+             (set! buffers (cons (vector seq 0 length) buffers))
+             (set! count (fix:+ count length))
              unspecific))))
 
     (define (build)
-      (finish-build (reverse (cons (cons buffer index) buffers))))
+      (let ((result (make-seq count)))
+       (do ((parts (reverse
+                    (if (fix:> index start)
+                        (cons (get-partial) buffers)
+                        buffers))
+                   (cdr parts))
+            (i 0
+               (let ((v (car parts)))
+                 (let ((start (vector-ref v 1))
+                       (end (vector-ref v 2)))
+                 (seq-copy! result i (vector-ref v 0) start end)
+                 (fix:+ i (fix:- end start))))))
+           ((not (pair? parts))))
+       result))
+
+    (define (get-partial)
+      (vector buffer start index))
 
     (reset!)
-    (lambda (operator)
-      (case operator
-       ((append-element!) append-element!)
-       ((append-sequence!) append-sequence!)
-       ((build) build)
-       ((empty?) empty?)
-       ((count) count)
-       ((reset!) reset!)
-       (else (error "Unknown operator:" operator))))))
+    (lambda (#!optional object)
+      (cond ((default-object? object) (build))
+           ((elt? object) (append-elt! object))
+           ((seq? object) (append-seq! object))
+           (else
+            (case object
+              ((empty?) (fix:= count 0))
+              ((count) count)
+              ((reset!) (reset!))
+              (else (error "Unsupported argument:" object))))))))
 \f
 ;;;; Ephemerons
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0d30485dceccb3bdddab2f146fceb5d3cba11a2b..2cad4fedc995e1121249d9ae4a5af8c36489f8bb 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -779,6 +779,7 @@ USA.
          vector->list
          vector-append
          vector-binary-search
+         vector-builder
          vector-copy
          vector-copy!
          vector-eighth

diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm
index 9b20aca087309ad9e7603b421bf7040594faff7a..58fd6b9836e74dee066068e74099a75bfd5d16c0 100644 (file)
--- a/src/runtime/vector.scm
+++ b/src/runtime/vector.scm
@@ -59,6 +59,15 @@ USA.
       (error:wrong-type-argument size "vector index" 'MAKE-VECTOR))
   ((ucode-primitive vector-cons) size (if (default-object? fill) #f fill)))
 
+(define (vector-builder #!optional buffer-length)
+  (make-sequence-builder any-object? vector? make-vector vector-length
+                        vector-set! vector-copy!
+    (if (default-object? buffer-length)
+       16
+       (begin
+         (guarantee positive-fixnum? buffer-length 'vector-builder)
+         buffer-length))))
+
 (define (vector->list vector #!optional start end)
   (subvector->list vector
                   (if (default-object? start) 0 start)