From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 23 Apr 2017 00:54:10 +0000 (-0700)
Subject: Simplify string, string*, string-append, string-append*.
X-Git-Tag: mit-scheme-pucked-9.2.12~158^2~14
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cc5cd5cc930672edfd6782722f3d3e87a706e473;p=mit-scheme.git

Simplify string, string*, string-append, string-append*.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4b1a24121..767ba31a5 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1055,9 +1055,7 @@ USA.
 	  substring?
 	  vector->string)
   (export (runtime predicate-metadata)
-	  register-ustring-predicates!)
-  (export (runtime symbol)
-	  %string*))
+	  register-ustring-predicates!))
 
 (define-package (runtime bytevector)
   (files "bytevector")
diff --git a/src/runtime/symbol.scm b/src/runtime/symbol.scm
index 4b31d7bc5..31a132761 100644
--- a/src/runtime/symbol.scm
+++ b/src/runtime/symbol.scm
@@ -62,7 +62,7 @@ USA.
 	  (else (error "Illegal symbol name:" s)))))
 
 (define (symbol . objects)
-  (string->symbol (%string* objects 'symbol)))
+  (string->symbol (string* objects)))
 
 (define (intern string)
   ((ucode-primitive string->symbol) (foldcase->utf8 string)))
diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index eab35875c..61f48ba77 100644
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -84,8 +84,7 @@ USA.
 		       '<= mutable-string?)
   (register-predicate! ustring? 'unicode-string '<= string?)
   (register-predicate! slice? 'string-slice '<= string?)
-  (register-predicate! 8-bit-string? '8-bit-string '<= string?)
-  (register-predicate! ->string-component? '->string-component))
+  (register-predicate! 8-bit-string? '8-bit-string '<= string?))
 
 ;;;; Unicode string layout
 
@@ -1584,59 +1583,33 @@ USA.
 ;;;; Append and general constructor
 
 (define (string-append . strings)
-  (%string-append* strings))
+  (string-append* strings))
 
 (define (string-append* strings)
-  (guarantee list? strings 'string-append*)
-  (%string-append* strings))
-
-(define (%string-append* strings)
-  (let ((string
-	 (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)
-		  (mutable-ustring-allocate n))))))
-    (let loop ((strings strings) (i 0))
-      (if (pair? strings)
-	  (let ((n (string-length (car strings))))
-	    (string-copy! string i (car strings) 0 n)
-	    (loop (cdr strings) (fix:+ i n)))))
-    string))
+  (let ((builder (string-builder)))
+    (for-each (lambda (string)
+		(guarantee string? string 'string-append)
+		(builder string))
+	      strings)
+    (builder)))
 
 (define (string . objects)
-  (%string* objects 'string))
+  (string* objects))
 
 (define (string* objects)
-  (guarantee list? objects 'string*)
-  (%string* objects 'string*))
-
-(define (%string* objects caller)
-  (%string-append*
-   (map (lambda (object)
-	  (->string object caller))
-	objects)))
-
-(define (->string object caller)
-  (cond ((not object) "")
-	((bitless-char? object) (char->string object))
-	((string? object) object)
-	((symbol? object) (symbol->string object))
-	((pathname? object) (->namestring object))
-	((number? object) (number->string object))
-	((uri? object) (uri->string object))
-	(else (error:not-a ->string-component? object caller))))
-
-(define (->string-component? object)
-  (or (not object)
-      (bitless-char? object)
-      (string? object)
-      (symbol? object)
-      (pathname? object)
-      (number? object)
-      (uri? object)))
+  (let ((builder (string-builder)))
+    (for-each (lambda (object)
+		(if object
+		    (builder
+		     (cond ((bitless-char? object) object)
+			   ((string? object) object)
+			   ((symbol? object) (symbol->string object))
+			   ((pathname? object) (->namestring object))
+			   ((number? object) (number->string object))
+			   ((uri? object) (uri->string object))
+			   (else (error "Unknown string component:" object))))))
+	      objects)
+    (builder)))
 
 ;;;; Mapping