Implement string-builder.

This hides most of the details of building strings, and continues to work even
if we add immutable strings.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8918a406efd9a865a9eeec9828c55a2c476f29a0..61c957d93d2a9ecd7aab5ec8b13d4c5b62cd6be7 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1127,6 +1127,7 @@ USA.
          string-any
          string-append
          string-append*
+         string-builder
          string-ci-hash
          string-ci<=?
          string-ci<?

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index a15d4c39d7b573140d630d6357f31d6ee4a41fb3..2e038ef972cfb2060bed9a81b0349c4b59bca9eb 100644 (file)
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -211,28 +211,80 @@ USA.
                       start
                       (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 (full-string-allocate buffer-size))
+         (index 0))
+
+      (define (new-buffer!)
+       (set! buffers (cons (string-slice buffer 0 index) buffers))
+       (set! buffer (full-string-allocate buffer-size))
+       (set! index 0)
+       unspecific)
+
+      (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))))
+         (set! buffer)
+         (set! buffers)
+         (set! index)
+         (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)))
+
+      (lambda (#!optional object)
+       (cond ((default-object? object) (build))
+             ((bitless-char? object) (append-char! object))
+             ((string? object) (append-string! object))
+             (else (error "Not a char or string:" object)))))))
+\f
 (define (string-copy! to at from #!optional start end)
   (let* ((end (fix:end-index end (string-length from) 'string-copy!))
         (start (fix:start-index start end 'string-copy!)))
     (guarantee index-fixnum? at 'string-copy!)
-    (if (not (fix:<= (fix:+ at (fix:- end start)) (string-length to)))
-       (error:bad-range-argument to 'string-copy!))
-    (receive (to at)
-       (if (slice? to)
-           (values (slice-string to)
-                   (fix:+ (slice-start to) at))
-           (values to at))
-      (receive (from start end) (translate-slice from start end)
-       (if (legacy-string? to)
-           (if (legacy-string? from)
-               (copy-loop legacy-string-set! to at
-                          legacy-string-ref from start end)
-               (copy-loop legacy-string-set! to at
-                          %full-string-ref from start end))
-           (if (legacy-string? from)
-               (copy-loop %full-string-set! to at
-                          legacy-string-ref from start end)
-               (%full-string-copy! to at from start end)))))))
+    (let ((final-at (fix:+ at (fix:- end start))))
+      (if (not (fix:<= final-at (string-length to)))
+         (error:bad-range-argument to 'string-copy!))
+      (receive (to at)
+         (if (slice? to)
+             (values (slice-string to)
+                     (fix:+ (slice-start to) at))
+             (values to at))
+       (receive (from start end) (translate-slice from start end)
+         (if (legacy-string? to)
+             (if (legacy-string? from)
+                 (copy-loop legacy-string-set! to at
+                            legacy-string-ref from start end)
+                 (copy-loop legacy-string-set! to at
+                            %full-string-ref from start end))
+             (if (legacy-string? from)
+                 (copy-loop %full-string-set! to at
+                            legacy-string-ref from start end)
+                 (%full-string-copy! to at from start end)))))
+      final-at)))
 
 (define-integrable (%full-string-copy! to at from start end)
   (cp-vector-copy! (%full-string-cp-vector to) at

diff --git a/tests/runtime/test-string.scm b/tests/runtime/test-string.scm
index 597def90375e97fafe63689a779c468e174f843c..ca736b80d44da09d635d1faf57be46528b9a9baa 100644 (file)
--- a/tests/runtime/test-string.scm
+++ b/tests/runtime/test-string.scm
@@ -181,4 +181,71 @@ USA.
     (assert-string-ci= "Strasse" "Stra\xDF;e")
     (assert-string-ci= "STRASSE" "Stra\xDF;e")
     (assert-string-ci= "\x3BE;\x3B1;\x3BF;\x3C2;" "\x39E;\x391;\x39F;\x3A3;")
-    (assert-string-ci= "\x3BE;\x3B1;\x3BF;\x3C3;" "\x39E;\x391;\x39F;\x3A3;")))
\ No newline at end of file
+    (assert-string-ci= "\x3BE;\x3B1;\x3BF;\x3C3;" "\x39E;\x391;\x39F;\x3A3;")))
+\f
+(define-test 'string-builder
+  (lambda ()
+    (let ((end (length latin-alphabet)))
+      (do ((i 0 (fix:+ i 1)))
+         ((not (fix:< i end)))
+       (let ((chars (list-head latin-alphabet i)))
+         (let ((result (build-string chars)))
+           (assert-true (legacy-string? result))
+           (assert-string= result (chars->string chars))))
+       (let ((strings (make-test-strings i latin-alphabet #f)))
+         (let ((result (build-string strings)))
+           (assert-true (legacy-string? result))
+           (assert-string= result (string-append* strings))))
+       (let ((strings (make-test-strings i latin-alphabet #t)))
+         (let ((result (build-string strings)))
+           (assert-true (legacy-string? result))
+           (assert-string= result (string-append* strings))))))
+    (let ((end (length greek-alphabet)))
+      (do ((i 0 (fix:+ i 1)))
+         ((not (fix:< i end)))
+       (let ((chars (list-head greek-alphabet i)))
+         (assert-string= (build-string chars)
+                         (chars->string chars)))
+       (let ((strings (make-test-strings i greek-alphabet #f)))
+         (assert-string= (build-string strings)
+                         (string-append* strings)))
+       (let ((strings (make-test-strings i greek-alphabet #t)))
+         (assert-string= (build-string strings)
+                         (string-append* strings)))))))
+
+(define legacy-string?
+  (make-primitive-procedure 'string? 1))
+
+(define latin-alphabet
+  '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+    #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))
+
+(define greek-alphabet
+  '(#\x3B1 #\x3B2 #\x3B3 #\x3B4 #\x3B5
+    #\x3B6 #\x3B7 #\x3B8 #\x3B9 #\x3BA
+    #\x3BB #\x3BC #\x3BD #\x3BE #\x3BF
+    #\x3C0 #\x3C1 #\x3C2 #\x3C3 #\x3C4
+    #\x3C5 #\x3C6 #\x3C7 #\x3C8 #\x3C9))
+
+(define (build-string objects)
+  (let ((builder (string-builder)))
+    (for-each builder objects)
+    (builder)))
+
+(define (chars->string chars)
+  (let ((s (make-ustring (length chars))))
+    (do ((chars chars (cdr chars))
+        (i 0 (fix:+ i 1)))
+       ((not (pair? chars)))
+      (string-set! s i (car chars)))
+    s))
+
+(define (make-test-strings n alphabet reverse?)
+  (let loop ((k 0) (strings '()))
+    (if (fix:< k n)
+       (loop (fix:+ k 1)
+             (cons (chars->string (list-head alphabet k))
+                   strings))
+       (if reverse?
+           strings
+           (reverse! strings)))))
\ No newline at end of file