From 0ea8d997be2a526616200d2ce3e5601564f5e8bf Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 19 Oct 2018 20:16:29 -0700
Subject: [PATCH] Adapt LIARC to use new strings.

---
 src/compiler/machines/C/cout.scm     | 52 +++++++++++++++-------------
 src/compiler/machines/C/ctop.scm     | 25 ++++++-------
 src/compiler/machines/C/stackify.scm |  2 +-
 src/compiler/machines/C/stackops.scm | 21 ++++-------
 4 files changed, 46 insertions(+), 54 deletions(-)

diff --git a/src/compiler/machines/C/cout.scm b/src/compiler/machines/C/cout.scm
index cc998b041..ce152b5dc 100644
--- a/src/compiler/machines/C/cout.scm
+++ b/src/compiler/machines/C/cout.scm
@@ -603,31 +603,33 @@ USA.
 ;; the characters are not really characters at all.
 
 (define (C-quotify-data-string/breakup string)
-  (let ((n-bytes (vector-8b-length string))
-	(new-string
-	 (lambda ()
-	   (let ((s (make-string 66)))
-	     (string-set! s 0 #\")
-	     s))))
-    (let loop ((i 0) (s (new-string)) (j 1))
-      (if (fix:< i n-bytes)
-	  (if (fix:< j 62)
-	      (let ((b (vector-8b-ref string i)))
-		(string-set! s j #\\)
-		(string-set! s (fix:+ j 1) #\x)
-		(string-set! s (fix:+ j 2)
-			     (digit->char (fix:quotient b #x10) 16))
-		(string-set! s (fix:+ j 3)
-			     (digit->char (fix:remainder b #x10) 16))
-		(loop (fix:+ i 1) s (fix:+ j 4)))
-	      (begin
-		(string-set! s j #\")
-		(cons s (loop i (new-string) 1))))
-	  (if (fix:> j 1)
-	      (begin
-		(string-set! s j #\")
-		(list (substring s 0 (fix:+ j 1))))
-	      '())))))
+  (let ((builder (string-builder)))
+    (map (lambda (part)
+	   (builder 'reset!)
+	   (builder #\")
+	   (string-for-each
+	    (lambda (char)
+	      (let ((b (char->integer char)))
+		(builder #\\)
+		(builder #\x)
+		(builder (digit->char (fix:quotient b #x10) 16))
+		(builder (digit->char (fix:remainder b #x10) 16))))
+	    part)
+	   (builder #\")
+	   (builder 'immutable))
+	 (split-string string 64))))
+
+(define (split-string string n)
+  (let ((len (string-length string)))
+    (let loop ((start 0) (parts '()))
+      (let ((end (fix:+ start n)))
+	(if (fix:<= end len)
+	    (reverse!
+	     (cons (string-slice string start len)
+		   parts))
+	    (loop end
+		  (cons (string-slice string start end)
+			parts)))))))
 
 (define (handle-objects start-offset)
   (if *use-stackify?*
diff --git a/src/compiler/machines/C/ctop.scm b/src/compiler/machines/C/ctop.scm
index 3193fdacc..0c8ed3922 100644
--- a/src/compiler/machines/C/ctop.scm
+++ b/src/compiler/machines/C/ctop.scm
@@ -435,21 +435,18 @@ USA.
 
 (define compiler:dump-info-file compiler:dump-bci-file)
 
-;; This defintion exported to compiler to handle losing C name restrictions
+;; This definition exported to compiler to handle losing C name restrictions.
 
 (define (canonicalize-label-name prefix)
   (if (string-null? prefix)
       "empty_string"
-      (let* ((str (if (char-alphabetic? (string-ref prefix 0))
-		      (string-copy prefix)
-		      (string-append "Z_" prefix)))
-	     (len (string-length str)))
-	(do ((i 0 (1+ i)))
-	    ((>= i len) str)
-	  (let ((char (string-ref str i)))
-	    (if (not (char-alphanumeric? char))
-		(string-set! str i
-			     (case char
-			       ((#\?) #\P)
-			       ((#\!) #\B)
-			       (else #\_)))))))))
+      (string-map (lambda (char)
+		    (if (char-alphanumeric? char)
+			char
+			(case char
+			  ((#\?) #\P)
+			  ((#\!) #\B)
+			  (else #\_))))
+		  (if (char-alphabetic? (string-ref prefix 0))
+		      prefix
+		      (string-append "Z_" prefix)))))
\ No newline at end of file
diff --git a/src/compiler/machines/C/stackify.scm b/src/compiler/machines/C/stackify.scm
index d7fd2d568..6dcd3ee0f 100644
--- a/src/compiler/machines/C/stackify.scm
+++ b/src/compiler/machines/C/stackify.scm
@@ -250,7 +250,7 @@ USA.
 	(length (string-list/length sl)))
     (if (fix:< ptr (string-length current))
 	(begin
-	  (vector-8b-set! current ptr byte)
+	  (string-set! current ptr (integer->char byte))
 	  (set-string-list/pointer! sl (fix:+ ptr 1))
 	  (set-string-list/length! sl (fix:+ length 1))
 	  sl)
diff --git a/src/compiler/machines/C/stackops.scm b/src/compiler/machines/C/stackops.scm
index 709e6ac03..4582b4a83 100644
--- a/src/compiler/machines/C/stackops.scm
+++ b/src/compiler/machines/C/stackops.scm
@@ -359,20 +359,13 @@ push-primitive-7			; name in string table
 	unspecific)))
 
 (define (stackify/c-quotify str)
-  (let* ((len (string-length str))
-	 (res (make-string len)))
-    (do ((i 0 (1+ i)))
-	((>= i len) res)
-      (let ((c (string-ref str i)))
-	(case c
-	  ((#\*)
-	   (string-set! res i #\S))
-	  ((#\- #\/)
-	   (string-set! res i #\_))
-	  ((#\+)
-	   (string-set! res i #\P))
-	  (else
-	   (string-set! res i c)))))))
+  (string-map (lambda (c)
+		(case c
+		  ((#\*) #\S)
+		  ((#\- #\/) #\_)
+		  ((#\+) #\P)
+		  (else c)))
+	      str))
 
 (define (stackify/dump-c-enums output)
   (with-output-to-file output
-- 
2.25.1