suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make strings within symbols always immutable

Browse Source 
original commit: 7859d16dac7bae6ab836e2200003583dc572deba
This commit is contained in:
Matthew Flatt 2019-12-16 17:11:49 -07:00
parent f858bec12a
commit c8ea435c85
11 changed files with 58 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
c/externs.h
View File

@ -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));

1
c/fasl.c
View File

@ -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;
}

14
c/intern.c
View File

@ -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);

2
c/prim5.c
View File

@ -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));

2
makefiles/Mf-install.in
View File

@ -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

5
mats/5_7.ms
View File

@ -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")))

12
mats/misc.ms
View File

@ -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? '#())

19
s/5_7.ss
View File

@ -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))
(#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)])))

2
s/cmacros.ss
View File

@ -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)

8
s/cpnanopass.ss
View File

@ -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)

1
s/primdata.ss
View File

@ -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])