Eliminate a bunch of references to make-ustring.

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 5164ca1ec5f8336753d5681c4c6470d08873ed36..dca7b66f85ffa51ca8a9173c8541803a18ad5d33 100644 (file)
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -306,33 +306,24 @@ USA.
   (lambda (bytevector #!optional start end)
     (let* ((end (fix:end-index end (bytevector-length bytevector) caller))
           (start (fix:start-index start end caller))
-          (string
-           (make-ustring
-            (let ((truncated
-                   (lambda (index)
-                     (error (string "Truncated " noun " sequence:")
-                            (bytevector-copy bytevector
-                                             index
-                                             (fix:min (fix:+ index 4) end))))))
-              (let loop ((index start) (n-chars 0))
-                (if (fix:<= (fix:+ index step) end)
-                    (let ((n (initial->length (getter bytevector index))))
-                      (let ((index* (fix:+ index n)))
-                        (if (not (fix:<= index* end))
-                            (truncated index))
-                        (loop index* (fix:+ n-chars 1))))
-                    (begin
-                      (if (fix:< index end)
-                          (truncated index))
-                      n-chars)))))))
-      (let loop ((from start) (to 0))
-       (if (fix:< from end)
-           (let ((char (decode-char bytevector from)))
-             (string-set! string to char)
-             (loop (fix:+ from (initial->length (getter bytevector from)))
-                   (fix:+ to 1)))))
-      (or (ustring->legacy-string string)
-         string))))
+          (builder (string-builder)))
+      (let ((truncated
+            (lambda (index)
+              (error (string "Truncated " noun " sequence:")
+                     (bytevector-copy bytevector
+                                      index
+                                      (fix:min (fix:+ index 4) end))))))
+       (let loop ((index start))
+         (if (fix:<= (fix:+ index step) end)
+             (let ((n (initial->length (getter bytevector index))))
+               (let ((index* (fix:+ index n)))
+                 (if (not (fix:<= index* end))
+                     (truncated index))
+                 (builder (decode-char bytevector index))
+                 (loop index*)))
+             (if (fix:< index end)
+                 (truncated index)))))
+      (builder))))
 
 (define utf8->string)
 (define utf16be->string)

diff --git a/src/runtime/input.scm b/src/runtime/input.scm
index d78359b2edee1083e1c154c4e9044f074cb4b289..4357a57a218ae82e6b1b6bafa104cd7aadaf3778 100644 (file)
--- a/src/runtime/input.scm
+++ b/src/runtime/input.scm
@@ -177,7 +177,7 @@ USA.
            (cond ((not n) n)
                  ((fix:> n 0) (if (fix:< n k) (string-head string n) string))
                  (else (eof-object)))))
-       (make-ustring 0))))
+       "")))
 \f
 (define (read #!optional port environment)
   (parse-object (optional-input-port port 'READ) environment))

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index 061b4d0a3b69c36fc5fad59a8b0a94f5fb09f9b1..e5cd492c5224a83d8b18bb5d1b5324e17a973e4b 100644 (file)
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -318,7 +318,7 @@ USA.
                  numerical-walk))
             (node (numerical-walk expression list-depth)))
        (if (positive? indentation)
-           (*unparse-string (make-ustring indentation #\space)))
+           (*unparse-string (make-string indentation #\space)))
        (if as-code?
            (print-node node indentation list-depth)
            (print-non-code-node node indentation list-depth))
@@ -723,7 +723,7 @@ USA.
   (pad-with-spaces column))
 
 (define-integrable (pad-with-spaces n-spaces)
-  (*unparse-string (make-ustring n-spaces #\space)))
+  (*unparse-string (make-string n-spaces #\space)))
 \f
 ;;;; Numerical Walk
 

diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm
index d6faebe04aee933821a3bc5440295ba9a8ae7bd2..775fe2f341f2bd7ab2007c5029ab63c8ae6d3ad6 100644 (file)
--- a/src/runtime/stringio.scm
+++ b/src/runtime/stringio.scm
@@ -147,9 +147,6 @@ USA.
 \f
 ;;;; Output as characters
 
-(define (open-output-string)
-  (make-output-string (make-ustring 16)))
-
 (define (get-output-string port)
   ((port/operation port 'extract-output) port))
 
@@ -178,12 +175,11 @@ USA.
     (lambda (port)
       (with-output-to-port port thunk))))
 \f
-(define (make-output-string buffer)
-  (make-textual-port string-output-type (make-ostate buffer 0 0)))
+(define (open-output-string)
+  (make-textual-port string-output-type (make-ostate (string-builder) 0)))
 
 (define-structure ostate
-  buffer
-  index
+  (builder #f read-only #t)
   column)
 
 (define (make-string-output-type)
@@ -198,59 +194,37 @@ USA.
 
 (define (string-out/write-char port char)
   (let ((os (textual-port-state port)))
-    (maybe-grow-buffer os 1)
-    (string-set! (ostate-buffer os) (ostate-index os) char)
-    (set-ostate-index! os (fix:+ (ostate-index os) 1))
+    ((ostate-builder os) char)
     (set-ostate-column! os (new-column char (ostate-column os)))
     1))
 
 (define (string-out/write-substring port string start end)
   (let ((os (textual-port-state port))
        (n (fix:- end start)))
-    (maybe-grow-buffer os n)
-    (string-copy! (ostate-buffer os) (ostate-index os) string start end)
-    (set-ostate-index! os (fix:+ (ostate-index os) n))
-    (update-column-for-substring! os n)
+    ((ostate-builder os) (string-slice string start end))
+    (update-column-for-substring! os string start end)
     n))
 
 (define (string-out/extract-output port)
-  (let ((os (textual-port-state port)))
-    (string-copy (ostate-buffer os) 0 (ostate-index os))))
+  ((ostate-builder (textual-port-state port))))
 
 (define (string-out/extract-output! port)
   (let* ((os (textual-port-state port))
-        (output (string-copy (ostate-buffer os) 0 (ostate-index os))))
-    (reset-buffer! os)
+        (builder (ostate-builder os))
+        (output (builder)))
+    (builder 'reset!)
+    (set-ostate-column! os 0)
     output))
 
 (define (string-out/output-column port)
   (ostate-column (textual-port-state port)))
 
 (define (string-out/position port)
-  (ostate-index (textual-port-state port)))
+  ((ostate-builder (textual-port-state port)) 'count))
 
 (define (string-out/write-self port output-port)
   port
   (write-string " to string" output-port))
-\f
-(define (maybe-grow-buffer os n)
-  (let ((buffer (ostate-buffer os))
-       (n (fix:+ (ostate-index os) n)))
-    (let ((m (string-length buffer)))
-      (if (fix:< m n)
-         (let ((buffer*
-                (make-ustring
-                 (let loop ((m (fix:+ m m)))
-                   (if (fix:< m n)
-                       (loop (fix:+ m m))
-                       m)))))
-           (string-copy! buffer* 0 buffer 0 (ostate-index os))
-           (set-ostate-buffer! os buffer*))))))
-
-(define (reset-buffer! os)
-  (set-ostate-buffer! os (make-ustring 16))
-  (set-ostate-index! os 0)
-  (set-ostate-column! os 0))
 
 (define (new-column char column)
   (case char
@@ -258,24 +232,18 @@ USA.
     ((#\tab) (fix:+ column (fix:- 8 (fix:remainder column 8))))
     (else (fix:+ column 1))))
 
-(define (update-column-for-substring! os n)
-  (let ((string (ostate-buffer os))
-       (end (ostate-index os)))
-    (let ((start (fix:- (ostate-index os) n)))
-      (letrec
-         ((loop
-           (lambda (i column)
-             (if (fix:< i end)
-                 (loop (fix:+ i 1)
-                       (new-column (string-ref string i) column))
-                 (set-ostate-column! os column)))))
-       (let ((nl (find-newline string start end)))
-         (if nl
-             (loop (fix:+ nl 1) 0)
-             (loop start (ostate-column os))))))))
-
-(define (find-newline string start end)
-  (substring-find-next-char string start end #\newline))
+(define (update-column-for-substring! os string start end)
+  (letrec
+      ((loop
+       (lambda (i column)
+         (if (fix:< i end)
+             (loop (fix:+ i 1)
+                   (new-column (string-ref string i) column))
+             (set-ostate-column! os column)))))
+    (let ((nl (substring-find-previous-char string start end #\newline)))
+      (if nl
+         (loop (fix:+ nl 1) 0)
+         (loop start (ostate-column os))))))
 \f
 ;;;; Output as octets
 
@@ -286,7 +254,7 @@ USA.
 
 (define (open-output-octets)
   (let ((port
-        (let ((os (make-ostate (make-vector-8b 16) 0 #f)))
+        (let ((os (make-ostate (string-builder) #f)))
           (make-generic-i/o-port #f
                                  (make-byte-sink os)
                                  'open-output-octets
@@ -298,56 +266,23 @@ USA.
 (define (make-byte-sink os)
   (make-non-channel-output-sink
    (lambda (bv start end)
-     (let ((index (ostate-index os)))
-       (let ((n (fix:+ index (fix:- end start))))
-        (let ((buffer (ostate-buffer os)))
-          (if (fix:> n (vector-8b-length buffer))
-              (set-ostate-buffer!
-               os
-               (let ((new
-                      (make-vector-8b
-                       (let loop ((m (vector-8b-length buffer)))
-                         (if (fix:>= m n)
-                             m
-                             (loop (fix:+ m m)))))))
-                 (substring-move! buffer 0 index new 0)
-                 new))))
-        (let ((buffer (ostate-buffer os)))
-          (do ((i start (fix:+ i 1))
-               (j index (fix:+ j 1)))
-              ((not (fix:< i end)))
-            (vector-8b-set! buffer j (bytevector-u8-ref bv j))))
-        (set-ostate-index! os n)
-        (fix:- end start))))))
+     (let ((builder (ostate-builder os)))
+       (do ((i start (fix:+ i 1)))
+          ((not (fix:< i end)))
+        (builder (integer->char (bytevector-u8-ref bv i)))))
+     (fix:- end start))))
 
 (define (make-octets-output-type)
-  (make-textual-port-type `((EXTRACT-OUTPUT ,octets-out/extract-output)
-                           (EXTRACT-OUTPUT! ,octets-out/extract-output!)
-                           (POSITION ,octets-out/position)
-                           (WRITE-SELF ,octets-out/write-self))
+  (make-textual-port-type `((extract-output ,string-out/extract-output)
+                           (extract-output! ,string-out/extract-output!)
+                           (position ,string-out/position)
+                           (write-self ,octets-out/write-self))
                          (generic-i/o-port-type #f #t)))
 
-(define (octets-out/extract-output port)
-  (output-port/flush-output port)
-  (let ((os (output-octets-port/os port)))
-    (string-head (ostate-buffer os) (ostate-index os))))
-
-(define (octets-out/extract-output! port)
-  (output-port/flush-output port)
-  (let* ((os (output-octets-port/os port))
-        (output (string-head (ostate-buffer os) (ostate-index os))))
-    (set-ostate-buffer! os (make-vector-8b 16))
-    (set-ostate-index! os 0)
-    output))
-
-(define (octets-out/position port)
-  (output-port/flush-output port)
-  (ostate-index (output-octets-port/os port)))
-
 (define (octets-out/write-self port output-port)
   port
   (write-string " to byte vector" output-port))
-\f
+
 (define string-input-type)
 (define octets-input-type)
 (define string-output-type)

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index d8a1a125bcb827bca98ae3e8142ab555d7b08e88..507480970ecf97f2b36f9db502fa101b40efe536 100644 (file)
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -214,9 +214,15 @@ USA.
 (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))
+    (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))
@@ -228,6 +234,11 @@ USA.
        (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!))
@@ -256,11 +267,14 @@ USA.
                ((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)))))))
 \f
 (define (string-copy! to at from #!optional start end)
@@ -458,21 +472,12 @@ USA.
          #t))))
 
 (define (canonical-decomposition string)
-  (let ((end (string-length string)))
-    (let ((result
-          (make-ustring
-           (do ((i 0 (fix:+ i 1))
-                (j 0 (fix:+ j (length (ucd-dm-value (string-ref string i))))))
-               ((not (fix:< i end)) j)))))
-      (let loop ((i 0) (j 0))
-       (if (fix:< i end)
-           (loop (fix:+ i 1)
-                 (do ((chars (ucd-dm-value (string-ref string i))
-                             (cdr chars))
-                      (j j (fix:+ j 1)))
-                     ((not (pair? chars)) j)
-                   (string-set! result j (car chars))))))
-      result)))
+  (let ((end (string-length string))
+       (builder (string-builder)))
+    (do ((i 0 (fix:+ i 1)))
+       ((not (fix:< i end)))
+      (for-each builder (ucd-dm-value (string-ref string i))))
+    (builder)))
 
 (define (canonical-ordering! string)
   (let ((end (string-length string)))

diff --git a/src/xml/xml-parser.scm b/src/xml/xml-parser.scm
index b92d92feccd34be026fdd089dd9e0abb9ac0d114..e4d314c81fe6efc7e80e9efc80b657084a5c356c 100644 (file)
--- a/src/xml/xml-parser.scm
+++ b/src/xml/xml-parser.scm
@@ -888,26 +888,17 @@ USA.
                                         #\linefeed))
                            2
                            1)))))
-         (let ((n
-                (let loop ((start 0) (n 0))
-                  (let ((index
-                         (substring-find-next-char string start end #\return)))
-                    (if index
-                        (loop (step-over-eol index)
-                              (fix:+ n (fix:+ (fix:- index start) 1)))
-                        (fix:+ n (fix:- end start)))))))
-           (let ((string* (make-ustring n)))
-             (let loop ((start 0) (start* 0))
-               (let ((index
-                      (substring-find-next-char string start end #\return)))
-                 (if index
-                     (let ((start*
-                            (string-copy! string* start* string start index)))
-                       (string-set! string* start* #\newline)
-                       (loop (step-over-eol index)
-                             (fix:+ start* 1)))
-                     (string-copy! string* start* string start end))))
-             string*))))
+         (let ((builder (string-builder)))
+           (let loop ((start 0))
+             (let ((index
+                    (substring-find-next-char string start end #\return)))
+               (if index
+                   (begin
+                     (builder #\newline)
+                     (builder (string-slice string start index))
+                     (loop (step-over-eol index)))
+                   (builder (string-slice string start index)))))
+           (builder))))
       (if (if (default-object? always-copy?) #f always-copy?)
          (string-copy string)
          string)))

diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm
index 816ed6dabb073bcd95638e8b7d6b648b069b495c..5f63a8c664011a0d7d1421b9227302495f1d47d2 100644 (file)
--- a/src/xml/xml-struct.scm
+++ b/src/xml/xml-struct.scm
@@ -616,22 +616,10 @@ USA.
        (else (error:wrong-type-datum value "XML string value"))))
 
 (define (nmtokens->string nmtokens)
-  (if (pair? nmtokens)
-      (let ((nmtoken-length
-            (lambda (nmtoken)
-              (string-length (symbol-name nmtoken)))))
-       (let ((s
-              (make-ustring
-               (let loop ((nmtokens nmtokens) (n 0))
-                 (let ((n (fix:+ n (nmtoken-length (car nmtokens)))))
-                   (if (pair? (cdr nmtokens))
-                       (loop (cdr nmtokens) (fix:+ n 1))
-                       n))))))
-         (let loop ((nmtokens nmtokens) (index 0))
-           (string-copy! s index (symbol-name (car nmtokens)))
-           (if (pair? (cdr nmtokens))
-               (let ((index (fix:+ index (nmtoken-length (car nmtokens)))))
-                 (string-set! s index #\space)
-                 (loop (cdr nmtokens) (fix:+ index 1)))))
-         s))
-      (make-ustring 0)))
\ No newline at end of file
+  (let ((builder (string-builder)))
+    (for-each (lambda (nmtokens)
+               (if (not (builder 'empty?))
+                   (builder #\space))
+               (builder (symbol-name (car nmtokens))))
+             nmtokens)
+    (build)))
\ No newline at end of file