From c8ea435c853e3e7d8e39df5f3910b12915a8d4be Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Dec 2019 17:11:49 -0700 Subject: [PATCH] make strings within symbols always immutable original commit: 7859d16dac7bae6ab836e2200003583dc572deba --- c/externs.h | 1 + c/fasl.c | 1 + c/intern.c | 14 +++++++++++--- c/prim5.c | 2 ++ makefiles/Mf-install.in | 2 +- mats/5_7.ms | 5 ++++- mats/misc.ms | 12 ++++++++++++ s/5_7.ss | 21 ++++++++++++++++++--- s/cmacros.ss | 2 +- s/cpnanopass.ss | 8 ++++++-- s/primdata.ss | 1 + 11 files changed, 58 insertions(+), 11 deletions(-) diff --git a/c/externs.h b/c/externs.h index 366cd4dc39..e0bf4a0a00 100644 --- a/c/externs.h +++ b/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)); diff --git a/c/fasl.c b/c/fasl.c index 512a518098..a8c4e07cf7 100644 --- a/c/fasl.c +++ b/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; } diff --git a/c/intern.c b/c/intern.c index f094f55f97..c71396ca52 100644 --- a/c/intern.c +++ b/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 (uname_str == Sfalse) uname_str = mkstring(uname, ulen); + if ((pname_str == Sfalse) || !(STRTYPE(pname_str) & string_immutable_flag)) + 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); diff --git a/c/prim5.c b/c/prim5.c index 04c9c7bff5..55f89420ce 100644 --- a/c/prim5.c +++ b/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)); diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index 061dadcca5..334ad551ce 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.7 +Version=csv9.5.3.8 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/mats/5_7.ms b/mats/5_7.ms index e54033edbf..85ac5f1d06 100644 --- a/mats/5_7.ms +++ b/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"))) diff --git a/mats/misc.ms b/mats/misc.ms index 27028491b9..b09f0c9f16 100644 --- a/mats/misc.ms +++ b/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? '#()) diff --git a/s/5_7.ss b/s/5_7.ss index 5aa4ef0ef2..551fe9ac24 100644 --- a/s/5_7.ss +++ b/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)))))))))) @@ -197,14 +199,27 @@ [(x) (unless (and (or (fixnum? x) (bignum? x)) (>= x 0)) ($oops 'gensym-count "~s is not a nonnegative integer" x)) - (set! count x)])) + (set! count x)])) (set-who! gensym (case-lambda [() (#3%gensym)] [(pretty-name) - (unless (string? pretty-name) ($oops who "~s is not a string" pretty-name)) - (#3%gensym pretty-name)] + (if (immutable-string? 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)]))) diff --git a/s/cmacros.ss b/s/cmacros.ss index c192dd9a17..5a65abea25 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 #x09050307) +(define-constant scheme-version #x09050308) (define-syntax define-machine-types (lambda (x) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index c008168ab5..bf37d2dd34 100644 --- a/s/cpnanopass.ss +++ b/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) diff --git a/s/primdata.ss b/s/primdata.ss index f317c58ae9..1b2a4c28bc 100644 --- a/s/primdata.ss +++ b/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])