Generalize string-builder to be useful for other sequences.

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 1e32ddf14e8fd455c3eaca89407cedc831109b66..2a6582e9542b2968685c19432a1ff658a9ab2dcb 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -585,6 +585,63 @@ USA.
        ((get-if-available) get)
        (else (error "Unknown operator:" operator))))))
 \f
+;;;; Builder for vector-like sequences
+
+(define (make-sequence-builder make-buffer sequence-length sequence-set!
+                              finish-build)
+    ;; This is optimized to minimize copying, so it wastes some space.
+  (let ((buffers)
+       (buffer)
+       (index))
+
+    (define (reset!)
+      (set! buffers '())
+      (set! buffer (make-buffer))
+      (set! index 0)
+      unspecific)
+
+    (define (new-buffer!)
+      (set! buffers (cons (cons buffer index) buffers))
+      (set! buffer (make-buffer))
+      (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 (sequence-length buffer)))
+         (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)
+
+    (define (build)
+      (finish-build (reverse (cons (cons buffer index) buffers))))
+
+    (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))))))
+\f
 ;;;; Ephemerons
 
 ;;; The layout of an ephemeron is as follows:

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 61c957d93d2a9ecd7aab5ec8b13d4c5b62cd6be7..a91129471acb35174cfa5c8ae4c8dc4bc31d1e21 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -516,6 +516,7 @@ USA.
          make-hashed-metadata-table
          make-hook-list
          make-non-pointer-object
+         make-sequence-builder
          non-pointer-type-code?
          null-procedure
          obarray->list

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 507480970ecf97f2b36f9db502fa101b40efe536..81263b0be940dc7faafdff16f7092084723a784c 100644 (file)
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -212,70 +212,34 @@ USA.
                       (fix:- end start))))))
 \f
 (define (string-builder)
-  ;; This is optimized to minimize copying, so it wastes some space.
-  (let ((buffer-size 16))
-    (let ((buffers)
-         (buffer)
-         (index))
-
-      (define (reset!)
-       (set! buffers '())
-       (set! buffer (full-string-allocate buffer-size))
-       (set! index 0)
-       unspecific)
-
-      (define (new-buffer!)
-       (set! buffers (cons (string-slice buffer 0 index) buffers))
-       (set! buffer (full-string-allocate buffer-size))
-       (set! index 0)
-       unspecific)
-
-      (define (empty?)
-       (and (fix:= 0 index)
-            (null? buffers)))
-
-      (define (count)
-       (do ((buffers buffers (cdr buffers))
-            (n 0 (fix:+ n (string-length (car buffers)))))
-           ((not (pair? buffers)) (fix:+ n index))))
-
-      (define (append-char! char)
-       (if (not (fix:< index buffer-size))
-           (new-buffer!))
-       (string-set! buffer index char)
-       (set! index (fix:+ index 1))
-       unspecific)
-
-      (define (append-string! string)
-       (if (fix:> index 0)
-           (new-buffer!))
-       (set! buffers (cons string buffers))
-       unspecific)
-
-      (define (build)
-       (let ((strings (reverse (cons (string-slice buffer 0 index) buffers))))
-         (let ((result
-                (do ((strings strings (cdr strings))
-                     (n 0 (fix:+ n (string-length (car strings))))
-                     (8-bit? #t (and 8-bit? (string-8-bit? (car strings)))))
-                    ((not (pair? strings))
-                     (if 8-bit?
-                         (legacy-string-allocate n)
-                         (full-string-allocate n))))))
-           (do ((strings strings (cdr strings))
-                (i 0 (string-copy! result i (car strings))))
-               ((not (pair? strings))))
-           result)))
-
-      (reset!)
-      (lambda (#!optional object)
-       (cond ((default-object? object) (build))
-             ((bitless-char? object) (append-char! object))
-             ((string? object) (append-string! object))
-             ((eq? 'empty? object) (empty?))
-             ((eq? 'count object) (count))
-             ((eq? 'reset! object) (reset!))
-             (else (error "Not a char or string:" object)))))))
+  (let ((builder
+        (make-sequence-builder (lambda () (full-string-allocate 16))
+                               string-length
+                               string-set!
+                               string-builder:finish-build)))
+    (lambda (#!optional object)
+      (cond ((default-object? object) ((builder 'build)))
+           ((bitless-char? object) ((builder 'append-element!) object))
+           ((string? object) ((builder 'append-sequence!) object))
+           ((memq object '(empty? count reset!)) ((builder object)))
+           (else (error "Not a char or string:" object))))))
+
+(define (string-builder:finish-build parts)
+  (let ((result
+        (do ((parts parts (cdr parts))
+             (n 0 (fix:+ n (cdar parts)))
+             (8-bit? #t
+                     (and 8-bit?
+                          (string-8-bit?
+                           (string-slice (caar parts) 0 (cdar parts))))))
+            ((not (pair? parts))
+             (if 8-bit?
+                 (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))))
+    result))
 \f
 (define (string-copy! to at from #!optional start end)
   (let* ((end (fix:end-index end (string-length from) 'string-copy!))