From ecaec06f647e72e470649856148ec3d4cf101e31 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 17 Dec 2019 18:53:33 -0700
Subject: [PATCH] add `string-append-immutable`

original commit: 353ee30534757fb37bfe231e9be21482d9f858ce
---
 csug/objects.stex                | 13 ++++++-
 makefiles/Mf-install.in          |  2 +-
 mats/5_5.ms                      | 17 ++++++++
 mats/root-experr-compile-0-f-f-f |  3 ++
 s/5_4.ss                         | 66 ++++++++++++++++++++------------
 s/cmacros.ss                     |  2 +-
 s/primdata.ss                    |  5 ++-
 7 files changed, 79 insertions(+), 29 deletions(-)

diff --git a/csug/objects.stex b/csug/objects.stex
index ee088b1c1a..cdd055bacb 100644
--- a/csug/objects.stex
+++ b/csug/objects.stex
@@ -430,7 +430,8 @@ recently.
 \index{immutable strings}\index{mutable strings}%
 All strings are mutable by default, including constants.
 A program can create immutable strings via
-\index{\scheme{string->immutable-string}}\scheme{string->immutable-string}.
+\index{\scheme{string->immutable-string}}\scheme{string->immutable-string}
+or \index{\scheme{string-append-immutable}}\scheme{string-append-immutable}.
 Any attempt to modify an immutable string causes an exception to be raised.
 
 The length and indices of a string in {\ChezScheme} are always fixnums.
@@ -583,6 +584,16 @@ is immutable; otherwise, the result is an immutable string with the same content
 \endschemedisplay
 
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{string-append-immutable}{\categoryprocedure}{(string-append-immutable \var{string} \dots)}
+\returns an immutable string that appends the argument \var{string}s
+\listlibraries
+\endentryheader
+
+\noindent
+Like \scheme{string-append}, but produces an immutable string.
+
 \section{Vectors}
 
 {\ChezScheme} extends the syntax of vectors to allow the length of the
diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in
index 334ad551ce..f7fe1f0f12 100644
--- a/makefiles/Mf-install.in
+++ b/makefiles/Mf-install.in
@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.8
+Version=csv9.5.3.9
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot
diff --git a/mats/5_5.ms b/mats/5_5.ms
index 40b4e3b547..10ed32c996 100644
--- a/mats/5_5.ms
+++ b/mats/5_5.ms
@@ -661,13 +661,30 @@
        (and (equal? x "          ")
             (not (eq? x (string-append x)))))
     (equal? (string-append "abc") "abc")
+    (not (immutable-string? (string-append (string->immutable-string "abc"))))
     (equal? (string-append "abc" "xyz") "abcxyz")
     (equal? (string-append "hi " "there " "mom") "hi there mom")
+    (not (immutable-string? (string-append "hi " "there " "mom")))
     (equal? (string-append "" "there") "there")
     (equal? (string-append "hi " "") "hi ")
     (eqv? (string-append "" "") "")
  )
 
+(mat string-append-immutable
+    (error? (string-append-immutable 'a))
+    (error? (string-append-immutable "hi" 'b))
+    (error? (string-append-immutable "hi" 'b "there"))
+    (eqv? (string-append-immutable) (string->immutable-string ""))
+    (equal? (string-append-immutable "abc") "abc")
+    (immutable-string? (string-append-immutable "abc"))
+    (equal? (string-append-immutable "abc" "xyz") "abcxyz")
+    (equal? (string-append-immutable "hi " "there " "mom") "hi there mom")
+    (immutable-string? (string-append-immutable "hi " "there " "mom"))
+    (equal? (string-append-immutable "" "there") "there")
+    (equal? (string-append-immutable "hi " "") "hi ")
+    (eqv? (string-append-immutable "" "") (string->immutable-string ""))
+ )
+
 (mat substring
     (error? (substring))
     (error? (substring "hi"))
diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f
index b38e4e7243..2961005073 100644
--- a/mats/root-experr-compile-0-f-f-f
+++ b/mats/root-experr-compile-0-f-f-f
@@ -2136,6 +2136,9 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
 5_5.mo:Expected error in mat string-append: "string-append: b is not a string".
 5_5.mo:Expected error in mat string-append: "string-append: b is not a string".
 5_5.mo:Expected error in mat string-append: "string-copy: a is not a string".
+5_5.mo:Expected error in mat string-append-immutable: "string-append-immutable: a is not a string".
+5_5.mo:Expected error in mat string-append-immutable: "string-append-immutable: b is not a string".
+5_5.mo:Expected error in mat string-append-immutable: "string-append-immutable: b is not a string".
 5_5.mo:Expected error in mat substring: "incorrect argument count in call (substring)".
 5_5.mo:Expected error in mat substring: "incorrect argument count in call (substring "hi")".
 5_5.mo:Expected error in mat substring: "incorrect argument count in call (substring "hi" 0)".
diff --git a/s/5_4.ss b/s/5_4.ss
index 3a2d1988f6..9036c3de07 100644
--- a/s/5_4.ss
+++ b/s/5_4.ss
@@ -30,30 +30,48 @@
                 ((fx= i n) s2)
                 (string-set! s2 j (string-ref s1 i)))))))
 
-(define-who string-append
-  (case-lambda
-    [(s1 s2)
-     (unless (string? s1) ($oops who "~s is not a string" s1))
-     (unless (string? s2) ($oops who "~s is not a string" s2))
-     (let ([n1 (string-length s1)] [n2 (string-length s2)])
-       (let ([n (+ n1 n2)])
-         (unless (fixnum? n) ($oops who "result string size ~s is not a fixnum" n))
-         (let ([s (make-string n)])
-           (string-copy! s1 0 s 0 n1)
-           (string-copy! s2 0 s n1 n2)
-           s)))]
-    [args
-     (let f ([ls args] [n 0])
-       (if (null? ls)
-           (if (fixnum? n)
-               (make-string n)
-               ($oops who "result string size ~s is not a fixnum" n))
-           (let ([s1 (car ls)])
-             (unless (string? s1) ($oops who "~s is not a string" s1))
-             (let ([m (string-length s1)])
-               (let ([s2 (f (cdr ls) (+ n m))])
-                 (string-copy! s1 0 s2 n m)
-                 s2)))))]))
+(let ()
+  (define do-string-append2
+    (lambda (who s1 s2)
+      (unless (string? s1) ($oops who "~s is not a string" s1))
+      (unless (string? s2) ($oops who "~s is not a string" s2))
+      (let ([n1 (string-length s1)] [n2 (string-length s2)])
+        (let ([n (+ n1 n2)])
+          (unless (fixnum? n) ($oops who "result string size ~s is not a fixnum" n))
+          (let ([s (make-string n)])
+            (string-copy! s1 0 s 0 n1)
+            (string-copy! s2 0 s n1 n2)
+            s)))))
+
+  (define do-string-append
+    (lambda (who args)
+      (let f ([ls args] [n 0])
+        (if (null? ls)
+            (if (fixnum? n)
+                (make-string n)
+                ($oops who "result string size ~s is not a fixnum" n))
+            (let ([s1 (car ls)])
+              (unless (string? s1) ($oops who "~s is not a string" s1))
+              (let ([m (string-length s1)])
+                (let ([s2 (f (cdr ls) (+ n m))])
+                  (string-copy! s1 0 s2 n m)
+                  s2)))))))
+
+  (define (immutable! str)
+    (cond
+     [(eqv? str "") ($tc-field 'null-immutable-string ($tc))]
+     [else ($string-set-immutable! str)
+           str]))
+
+  (set-who! string-append
+    (case-lambda
+     [(s1 s2) (do-string-append2 who s1 s2)]
+     [args (do-string-append who args)]))
+
+  (set-who! string-append-immutable
+    (case-lambda
+     [(s1 s2) (immutable! (do-string-append2 who s1 s2))]
+     [args (immutable! (do-string-append who args))])))
 
 (define string->list
    (lambda (s)
diff --git a/s/cmacros.ss b/s/cmacros.ss
index 5a65abea25..74e4020069 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -328,7 +328,7 @@
                  [(_ foo e1 e2) e1] ...
                  [(_ bar e1 e2) e2]))))])))
 
-(define-constant scheme-version #x09050308)
+(define-constant scheme-version #x09050309)
 
 (define-syntax define-machine-types
   (lambda (x)
diff --git a/s/primdata.ss b/s/primdata.ss
index 1b2a4c28bc..52a99d71c0 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -300,8 +300,6 @@
   (symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard safeongoodargs ieee r5rs])
   (symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs])
   (string->symbol [sig [(string) -> (interned-symbol)]] [flags true mifoldable discard safeongoodargs ieee r5rs])
-  (string->uninterned-symbol [sig [(string) -> (uninterned-symbol)]] [flags true discard safeongoodargs])
-  (uninterned-symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (char? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
   (char->integer [sig [(char) -> (fixnum)]] [flags pure mifoldable discard safeongoodargs true ieee r5rs])
   (integer->char [sig [(sub-ufixnum) -> (char)]] [flags pure mifoldable discard true ieee r5rs])
@@ -1672,6 +1670,7 @@
   (statistics [sig [() -> (sstats)]] [flags unrestricted alloc])
   (string->multibyte [feature windows] [sig [(sub-uint string) -> (bytevector)]] [flags true discard])
   (string->number [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard]) ; radix not restricted to 2, 4, 8, 16
+  (string-append-immutable [sig [(string ...) -> (string)]] [flags alloc safeongoodargs ieee r5rs])
   (string<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs])        ; not restricted to 2+ arguments
   (string<? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs])         ; not restricted to 2+ arguments
   (string=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard cp03 safeongoodargs])         ; not restricted to 2+ arguments
@@ -1684,6 +1683,7 @@
   (string-ci>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs])   ; not restricted to 2+ arguments
   (string-copy! [sig [(string sub-length string sub-length sub-length) -> (void)]] [flags true])
   (string->immutable-string [sig [(string) -> (string)]] [flags alloc safeongoodargs])
+  (string->uninterned-symbol [sig [(string) -> (uninterned-symbol)]] [flags true discard safeongoodargs])
   (string-truncate! [sig [(string length) -> (string)]] [flags true])
   (strip-fasl-file [sig [(pathname pathname fasl-strip-options) -> (void)]] [flags true])
   (sub1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
@@ -1733,6 +1733,7 @@
   (unbox [sig [(box) -> (ptr)]] [flags mifoldable discard safeongoodargs])
   (unget-u8 [sig [(binary-input-port eof/u8) -> (void)]] [flags true])
   (unget-char [sig [(textual-input-port eof/char) -> (void)]] [flags true])
+  (uninterned-symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (unlock-object [sig [(ptr) -> (void)]] [flags unrestricted true])
   (unread-char [sig [(char) (char textual-input-port) -> (void)]] [flags true])
   (utf-16-codec [sig [() -> (codec)] [(sub-symbol) -> (codec)]] [flags pure true]) ; has optional eness argument