make strings within symbols always immutable

original commit: 7859d16dac7bae6ab836e2200003583dc572deba

c/externs.h

@@ -177,6 +177,7 @@ extern ptr S_intern3 PROTO((const string_char *pname, iptr plen, const string_ch
 extern ptr S_intern4 PROTO((ptr sym));
 extern void S_intern_gensym PROTO((ptr g));
 extern void S_retrofit_nonprocedure_code PROTO((void));
+extern ptr S_mkstring PROTO((const string_char *s, iptr n));
 
 /* io.c */
 extern IBOOL S_file_existsp PROTO((const char *inpath, IBOOL followp));

c/fasl.c

@@ -658,6 +658,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
             n = uptrin(f);
             str = S_string((char *)0, n);
             for (i = 0; i != n; i += 1) Sstring_set(str, i, uptrin(f));
+            STRTYPE(str) |= string_immutable_flag;
             *x = S_uninterned(str);
             return;
         }

c/intern.c

@@ -224,9 +224,14 @@ static ptr mkstring(const string_char *s, iptr n) {
   iptr i;
   ptr str = S_string(NULL, n);
   for (i = 0; i != n; i += 1) STRIT(str, i) = s[i];
+  STRTYPE(str) |= string_immutable_flag;
   return str;
 }
 
+ptr S_mkstring(const string_char *s, iptr n) {
+  return mkstring(s, n);
+}
+
 /* handles single-byte characters, implicit length */
 ptr S_intern(const unsigned char *s) {
   iptr n = strlen((const char *)s);
@@ -292,7 +297,8 @@ ptr S_intern_sc(const string_char *name, iptr n, ptr name_str) {
     b = b->next;
   }
 
-  /* if (name_str == Sfalse) */ name_str = mkstring(name, n);
+  if ((name_str == Sfalse) || !(STRTYPE(name_str) & string_immutable_flag))
+    name_str = mkstring(name, n);
   sym = S_symbol(name_str);
   INITSYMHASH(sym) = FIX(hc);
   oblist_insert(sym, idx, 0);
@@ -328,8 +334,10 @@ ptr S_intern3(const string_char *pname, iptr plen, const string_char *uname, ipt
     b = b->next;
   }
 
-  if (pname_str == Sfalse) pname_str = mkstring(pname, plen);
+  if ((pname_str == Sfalse) || !(STRTYPE(pname_str) & string_immutable_flag))
-  if (uname_str == Sfalse) uname_str = mkstring(uname, ulen);
+    pname_str = mkstring(pname, plen);
+  if ((uname_str == Sfalse)  || !(STRTYPE(uname_str) & string_immutable_flag))
+    uname_str = mkstring(uname, ulen);
   sym = S_symbol(Scons(uname_str, pname_str));
   INITSYMHASH(sym) = FIX(hc);
   oblist_insert(sym, idx, 0);

c/prim5.c

@@ -967,6 +967,8 @@ ptr S_uninterned(x) ptr x; {
   static uptr hc;
 
   require(Sstringp(x),"string->uninterned-symbol","~s is not a string",x);
+  if (!(STRTYPE(x) & string_immutable_flag))
+    x = S_mkstring(&STRIT(x, 0), Sstring_length(x));
 
   sym = S_symbol(Scons(x, Sfalse));
 

makefiles/Mf-install.in

@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.7
+Version=csv9.5.3.8
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot

mats/5_7.ms

@@ -25,6 +25,7 @@
     (not (eq? (gensym "hi")
          (gensym "hi")))
     (equal? (symbol->string (gensym "hi")) "hi")
+    (immutable-string? (symbol->string (gensym "hi")))
     (error? (gensym '#(a b c)))
  )
 
@@ -68,6 +69,7 @@
 
 (mat symbol->string
     (equal? (symbol->string 'foo) "foo")
+    (immutable-string? (symbol->string 'foo))
     (equal? (symbol->string (string->symbol "hi")) "hi")
     (equal? (symbol->string (gensym "hi there")) "hi there")
     (error? (symbol->string 3))
@@ -80,7 +82,7 @@
     (gensym->unique-string 3))
   (error? ; not a gensym
     (gensym->unique-string 'spam))
-  (string? (gensym->unique-string (gensym)))
+  (immutable-string? (gensym->unique-string (gensym)))
   (equal?
     (gensym->unique-string '#{g0 e6sfz8u1obe67hsew4stu0-0})
     "e6sfz8u1obe67hsew4stu0-0")
@@ -112,6 +114,7 @@
      (not (gensym? (string->uninterned-symbol "hello")))
 
      (equal? "hello" (symbol->string (string->uninterned-symbol "hello")))
+     (immutable-string? (symbol->string (string->uninterned-symbol "hello")))
 
      (not (eq? (string->uninterned-symbol "hello")
                (string->uninterned-symbol "hello")))

mats/misc.ms

@@ -5424,6 +5424,14 @@
       (let ([l2 (eval 'fasl-immutable-round-trip)])
         (and (equal? l l2)
              (immutable? l2))))
+    (define (round-trip-symbol sym)
+      (let-values ([(o get) (open-bytevector-output-port)])
+        (fasl-write sym o)
+        (let ([s (fasl-read (open-bytevector-input-port (get)))])
+          (and (symbol? s)
+               (immutable-string? (symbol->string s))
+               (or (not (gensym? s))
+                   (immutable-string? (gensym->unique-string s)))))))
     #t)
 
   (immutable? immutable-objs)
@@ -5433,6 +5441,10 @@
   (round-trip-via-strip immutable-objs)
   (round-trip-via-strip immutable-zero-objs)
 
+  (round-trip-symbol 'hello)
+  (round-trip-symbol (string->symbol "hola"))
+  (round-trip-symbol (gensym "bonjour"))
+
   ;; Make sure `fasl-read` didn't mark "mutable" null values
   ;; as immutable:
   (mutable-vector? '#())

s/5_7.ss

@@ -178,12 +178,14 @@
               (let ([name ($symbol-name sym)])
                 (if (not name)
                     (let ([uname (generate-unique-name)])
+                      ($string-set-immutable! uname)
                       ($set-symbol-name! sym
                         (cons uname (generate-pretty-name)))
                       ($intern-gensym sym)
                       uname)
                     (or (car name)
                         (let ([uname (generate-unique-name)])
+                          ($string-set-immutable! uname)
                           (set-car! name uname)
                           ($intern-gensym sym)
                           uname))))))))))
@@ -202,9 +204,22 @@
     (case-lambda
       [() (#3%gensym)]
       [(pretty-name)
-       (unless (string? pretty-name) ($oops who "~s is not a string" pretty-name))
+       (if (immutable-string? pretty-name)
-       (#3%gensym pretty-name)]
+           (#3%$gensym pretty-name)
+           (if (string? pretty-name)
+               (#3%$gensym (string->immutable-string pretty-name))
+               ($oops who "~s is not a string" pretty-name)))]
       [(pretty-name unique-name)
        (unless (string? pretty-name) ($oops who "~s is not a string" pretty-name))
        (unless (string? unique-name) ($oops who "~s is not a string" unique-name))
+       ($strings->gensym pretty-name unique-name)]))
+  (set-who! $gensym
+    (case-lambda
+      [() (#3%$gensym)]
+      [(pretty-name)
+       (unless (immutable-string? pretty-name) ($oops who "~s is not an immutable string" pretty-name))
+       (#3%$gensym pretty-name)]
+      [(pretty-name unique-name)
+       (unless (immutable-string? pretty-name) ($oops who "~s is not an immutable string" pretty-name))
+       (unless (immutable-string? unique-name) ($oops who "~s is not an immutable string" unique-name))
        ($strings->gensym pretty-name unique-name)])))

s/cmacros.ss

@@ -328,7 +328,7 @@
                  [(_ foo e1 e2) e1] ...
                  [(_ bar e1 e2) e2]))))])))
 
-(define-constant scheme-version #x09050307)
+(define-constant scheme-version #x09050308)
 
 (define-syntax define-machine-types
   (lambda (x)

s/cpnanopass.ss

@@ -9537,13 +9537,17 @@
                 (set! ,(%mref ,t ,(constant pair-cdr-disp)) ,e-pname)
                 (set! ,(%mref ,t ,(constant pair-car-disp)) ,(%constant sfalse))
                 ,(build-make-symbol t))))
-          (define-inline 3 gensym
+          (define-inline 3 $gensym
             [() (build-make-symbol (%constant sfalse))]
             [(e-pname) (bind #f (e-pname) (go e-pname))]
             [(e-pname e-uname) #f])
+          (define-inline 3 gensym
+            [() (build-make-symbol (%constant sfalse))]
+            [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))]
+            [(e-pname e-uname) #f])
           (define-inline 2 gensym
             [() (build-make-symbol (%constant sfalse))]
-            [(e-pname) (and (constant? string? e-pname) (go e-pname))]
+            [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))]
             [(e-pname e-uname) #f]))
         (define-inline 3 symbol->string
           [(e-sym)

s/primdata.ss

@@ -2061,6 +2061,7 @@
   ($gc-cpu-time [flags true])
   ($gc-real-time [flags true])
   ($generation [flags single-valued])
+  ($gensym [sig [() (string) (string string) -> (gensym)]] [flags alloc]) ; needs immutable strings
   ($gensym->pretty-name [flags single-valued])
   ($guard [flags])
   ($hand-coded [flags single-valued])