From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 20 Feb 2017 01:08:04 +0000 (-0800)
Subject: Eliminate a bunch of references to make-ustring.
X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~56
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1e9b035afa222770df2035f80c331376cc2590a7;p=mit-scheme.git

Eliminate a bunch of references to make-ustring.
---

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 5164ca1ec..dca7b66f8 100644
--- 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 d78359b2e..4357a57a2 100644
--- 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))))
+	"")))
 
 (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 061b4d0a3..e5cd492c5 100644
--- 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)))
 
 ;;;; Numerical Walk
 
diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm
index d6faebe04..775fe2f34 100644
--- a/src/runtime/stringio.scm
+++ b/src/runtime/stringio.scm
@@ -147,9 +147,6 @@ USA.
 
 ;;;; 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))))
 
-(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))
-
-(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))))))
 
 ;;;; 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))
-
+
 (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 d8a1a125b..507480970 100644
--- 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)))))))
 
 (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 b92d92fec..e4d314c81 100644
--- 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 816ed6dab..5f63a8c66 100644
--- 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