From 27eb177b9da50a19538d03ff95e92e0fd633f966 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Dec 2019 19:09:24 -0700 Subject: [PATCH] add `{symbol,keyword}->immutable-string` and `string-append-immutable` There could be many more functions that produce immutable strings directly, and we want the default functions to do that in some future language. For now, these three rae the most immediately useful for avoiding unnecessary allocation in Racket CS. --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/data.scrbl | 30 ++++++++++-- .../scribblings/reference/strings.scrbl | 11 +++++ .../scribblings/reference/symbols.scrbl | 47 ++++++++++++------- pkgs/racket-test-core/tests/racket/basic.rktl | 18 +++++++ racket/src/cs/compile-file.ss | 2 +- racket/src/cs/primitive/kernel.ss | 3 ++ racket/src/cs/rumble.sls | 2 + racket/src/cs/rumble/keyword.ss | 4 ++ racket/src/cs/rumble/symbol.ss | 4 ++ racket/src/expander/expand/env.rkt | 7 +-- racket/src/io/print/main.rkt | 6 +-- racket/src/io/print/symbol.rkt | 2 +- racket/src/racket/src/optimize.c | 7 ++- racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schvers.h | 2 +- racket/src/racket/src/startup.inc | 4 +- racket/src/racket/src/string.c | 23 +++++++++ racket/src/racket/src/strops.inc | 10 +++- racket/src/racket/src/symbol.c | 47 +++++++++++++++++++ 20 files changed, 196 insertions(+), 37 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index c7dfa7366c..866108d921 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.5.0.13") +(define version "7.5.0.14") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/data.scrbl b/pkgs/racket-doc/scribblings/reference/data.scrbl index e943c2f13a..f01d44ed40 100644 --- a/pkgs/racket-doc/scribblings/reference/data.scrbl +++ b/pkgs/racket-doc/scribblings/reference/data.scrbl @@ -52,17 +52,39 @@ table; see @secref["symbols"] for more information. @defproc[(keyword? [v any/c]) boolean?]{ -Returns @racket[#t] if @racket[v] is a keyword, @racket[#f] otherwise.} +Returns @racket[#t] if @racket[v] is a keyword, @racket[#f] otherwise. + +@mz-examples[(keyword? '#:apple) + (keyword? 'define) + (keyword? '#:define)]} + @defproc[(keyword->string [keyword keyword?]) string?]{ Returns a string for the @racket[display]ed form of @racket[keyword], -not including the leading @litchar{#:}.} +not including the leading @litchar{#:}. + +@mz-examples[(keyword->string '#:apple)]} + + +@defproc[(keyword->immutable-string [sym keyword?]) (and/c string? immutable?)]{ + +Like @racket[keyword->string], but the result is an immutable string, +not necessarily freshly allocated. + +@mz-examples[(keyword->immutable-string '#:apple) + (immutable? (keyword->immutable-string '#:apple))] + +@history[#:added "7.5.0.14"]} + @defproc[(string->keyword [str string?]) keyword?]{ Returns a keyword whose @racket[display]ed form is the same as that of -@racket[str], but with a leading @litchar{#:}.} +@racket[str], but with a leading @litchar{#:}. + +@mz-examples[(string->keyword "apple")]} + @defproc[(keywordstring] with @racket[string->bytes/utf-8] and @racket[byteslist [str string?]) (listof char?)]{ Returns a new list of characters corresponding to the content of @racket[str]. That is, the length of the list is @racket[(string-length str)], and the diff --git a/pkgs/racket-doc/scribblings/reference/symbols.scrbl b/pkgs/racket-doc/scribblings/reference/symbols.scrbl index ded8e0760e..4200e0620c 100644 --- a/pkgs/racket-doc/scribblings/reference/symbols.scrbl +++ b/pkgs/racket-doc/scribblings/reference/symbols.scrbl @@ -41,35 +41,46 @@ used as an ephemeron key (see @secref["ephemerons"]). @defproc[(symbol? [v any/c]) boolean?]{Returns @racket[#t] if @racket[v] is a symbol, @racket[#f] otherwise. -@examples[(symbol? 'Apple) (symbol? 10)]} +@mz-examples[(symbol? 'Apple) (symbol? 10)]} @defproc[(symbol-interned? [sym symbol?]) boolean?]{Returns @racket[#t] if @racket[sym] is @tech{interned}, @racket[#f] otherwise. -@examples[(symbol-interned? 'Apple) - (symbol-interned? (gensym)) - (symbol-interned? (string->unreadable-symbol "Apple"))]} +@mz-examples[(symbol-interned? 'Apple) + (symbol-interned? (gensym)) + (symbol-interned? (string->unreadable-symbol "Apple"))]} @defproc[(symbol-unreadable? [sym symbol?]) boolean?]{Returns @racket[#t] if @racket[sym] is an @tech{unreadable symbol}, @racket[#f] otherwise. -@examples[(symbol-unreadable? 'Apple) - (symbol-unreadable? (gensym)) - (symbol-unreadable? (string->unreadable-symbol "Apple"))]} +@mz-examples[(symbol-unreadable? 'Apple) + (symbol-unreadable? (gensym)) + (symbol-unreadable? (string->unreadable-symbol "Apple"))]} @defproc[(symbol->string [sym symbol?]) string?]{Returns a freshly allocated mutable string whose characters are the same as in @racket[sym]. -@examples[(symbol->string 'Apple)]} +@mz-examples[(symbol->string 'Apple)]} + + +@defproc[(symbol->immutable-string [sym symbol?]) (and/c string? immutable?)]{ + +Like @racket[symbol->string], but the result is an immutable string, +not necessarily freshly allocated. + +@mz-examples[(symbol->immutable-string 'Apple) + (immutable? (symbol->immutable-string 'Apple))] + +@history[#:added "7.5.0.14"]} @defproc[(string->symbol [str string?]) symbol?]{Returns an @tech{interned} symbol whose characters are the same as in @racket[str]. -@examples[(string->symbol "Apple") (string->symbol "1")]} +@mz-examples[(string->symbol "Apple") (string->symbol "1")]} @defproc[(string->uninterned-symbol [str string?]) symbol?]{Like @@ -77,10 +88,10 @@ used as an ephemeron key (see @secref["ephemerons"]). @tech{uninterned} symbol. Calling @racket[string->uninterned-symbol] twice with the same @racket[str] returns two distinct symbols. -@examples[(string->uninterned-symbol "Apple") - (eq? 'a (string->uninterned-symbol "a")) - (eq? (string->uninterned-symbol "a") - (string->uninterned-symbol "a"))]} +@mz-examples[(string->uninterned-symbol "Apple") + (eq? 'a (string->uninterned-symbol "a")) + (eq? (string->uninterned-symbol "a") + (string->uninterned-symbol "a"))]} @defproc[(string->unreadable-symbol [str string?]) symbol?]{Like @@ -89,17 +100,17 @@ used as an ephemeron key (see @secref["ephemerons"]). twice with equivalent @racket[str]s returns the same symbol, but @racket[read] never produces the symbol. -@examples[(string->unreadable-symbol "Apple") - (eq? 'a (string->unreadable-symbol "a")) - (eq? (string->unreadable-symbol "a") - (string->unreadable-symbol "a"))]} +@mz-examples[(string->unreadable-symbol "Apple") + (eq? 'a (string->unreadable-symbol "a")) + (eq? (string->unreadable-symbol "a") + (string->unreadable-symbol "a"))]} @defproc[(gensym [base (or/c string? symbol?) "g"]) symbol?]{Returns a new @tech{uninterned} symbol with an automatically-generated name. The optional @racket[base] argument is a prefix symbol or string.} -@examples[(gensym "apple")] +@mz-examples[(gensym "apple")] @defproc[(symbolstring y) (test y string->symbol "ab") +(test #f eq? (symbol->string 'apple) (symbol->string 'apple)) +(test "apple" symbol->immutable-string 'apple) +(test #t immutable? (symbol->immutable-string 'apple)) + #ci(test #t eq? 'mISSISSIppi 'mississippi) #ci(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) #cs(test #t 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) @@ -466,6 +470,11 @@ (test #f keywordkeyword "\uFF") (string->keyword "\uA0")) (test #f keywordkeyword "\uA0") (string->keyword "\uA0")) +(test #f eq? (keyword->string '#:apple) (keyword->string '#:apple)) +(test "apple" keyword->immutable-string '#:apple) +(test #t immutable? (keyword->immutable-string '#:apple)) + + (arity-test keyword? 1 1) (arity-test keywordimmutable-string "hello"))) (test "" make-string 0) (define s (string-copy "hello")) (define s2 (string-copy s)) diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index 1d06077117..d199e6e09b 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -2,7 +2,7 @@ ;; Check to make we're using a build of Chez Scheme ;; that has all the features we need. (define-values (need-maj need-min need-sub need-dev) - (values 9 5 3 8)) + (values 9 5 3 9)) (unless (guard (x [else #f]) (eval 'scheme-fork-version-number)) (error 'compile-file diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index bff092f910..cdec7945ce 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/racket/src/cs/primitive/kernel.ss @@ -461,6 +461,7 @@ [integer-sqrt/remainder (known-procedure/no-prompt 2)] [integer? (known-procedure/pure/folding 2)] [interned-char? (known-procedure/pure 2)] + [keyword->immutable-string (known-procedure/no-prompt 2)] [keyword->string (known-procedure/no-prompt 2)] [keyworduninterned-symbol (known-procedure/no-prompt 2)] [string->unreadable-symbol (known-procedure/no-prompt 2)] [string-append (known-procedure/no-prompt -1)] + [string-append-immutable (known-procedure/no-prompt -1)] [string-ci<=? (known-procedure/no-prompt -2)] [string-ciimmutable-string (known-procedure/no-prompt 2)] [symbol->string (known-procedure/no-prompt 2)] [symbol-interned? (known-procedure/no-prompt 2)] [symbol-unreadable? (known-procedure/no-prompt 2)] diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index afe0b9eb39..d8a9a673a8 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -321,6 +321,7 @@ string->uninterned-symbol string->unreadable-symbol symbol->string + symbol->immutable-string list? list-pair? @@ -367,6 +368,7 @@ keyword? keyword->string + keyword->immutable-string string->keyword keywordstring (keyword-symbol kw))) +(define/who (keyword->immutable-string kw) + (check who keyword? kw) + (#%symbol->string (keyword-symbol kw))) + (define/who keywordstring s))) +(define/who (symbol->immutable-string s) + (check who symbol? s) + (#%symbol->string s)) + (define/who (string->unreadable-symbol str) (check who string? str) (#%gensym str diff --git a/racket/src/expander/expand/env.rkt b/racket/src/expander/expand/env.rkt index efea193609..4f7e882648 100644 --- a/racket/src/expander/expand/env.rkt +++ b/racket/src/expander/expand/env.rkt @@ -110,9 +110,10 @@ (define c (add1 (unbox counter))) (set-box! counter c) (define sym (syntax-content id)) - (define key (string->uninterned-symbol (string-append (symbol->string (or local-sym sym)) - "_" - (number->string c)))) + (define key (string->uninterned-symbol (string-append-immutable + (symbol->immutable-string (or local-sym sym)) + "_" + (number->string c)))) (add-binding-in-scopes! (syntax-scope-set id phase) sym (make-local-binding key #:frame-id frame-id)) key) diff --git a/racket/src/io/print/main.rkt b/racket/src/io/print/main.rkt index b43ccc34b6..2c8106822d 100644 --- a/racket/src/io/print/main.rkt +++ b/racket/src/io/print/main.rkt @@ -227,7 +227,7 @@ [else (print-bytes v o max-length)])] [(symbol? v) (cond - [(eq? mode DISPLAY-MODE) (write-string/max (symbol->string v) o max-length)] + [(eq? mode DISPLAY-MODE) (write-string/max (symbol->immutable-string v) o max-length)] [else (print-symbol v o max-length config)])] [(keyword? v) (let ([max-length (write-string/max "#:" o max-length)]) @@ -309,7 +309,7 @@ (define l (vector->list (struct->vector v struct-dots))) (define alt-list-constructor ;; strip "struct:" from the first element of `l`: - (string-append "(" (substring (symbol->string (car l)) 7))) + (string-append "(" (substring (symbol->immutable-string (car l)) 7))) (print-list p who (cdr l) mode o max-length graph config #f alt-list-constructor)] [(prefab-struct-key v) => (lambda (key) @@ -339,7 +339,7 @@ (define (fail-unreadable who v) (raise (exn:fail - (string-append (symbol->string who) + (string-append (symbol->immutable-string who) ": printing disabled for unreadable value" "\n value: " (parameterize ([print-unreadable #t]) diff --git a/racket/src/io/print/symbol.rkt b/racket/src/io/print/symbol.rkt index 9d97a35a5f..5e0243cff7 100644 --- a/racket/src/io/print/symbol.rkt +++ b/racket/src/io/print/symbol.rkt @@ -20,7 +20,7 @@ (config-get config read-case-sensitive) #t)] #:for-keyword? [for-keyword? #f]) - (define str (symbol->string sym)) + (define str (symbol->immutable-string sym)) (define (is-simple? ch i) (not (or (char=? ch #\() (char=? ch #\[) diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index bb22a2da90..95eb8defef 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -3344,9 +3344,12 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, Optimize_Inf } else if (IS_NAMED_PRIM(rator, "string-ref")) { return scheme_char_p_proc; } else if (IS_NAMED_PRIM(rator, "string-append") + || IS_NAMED_PRIM(rator, "string-append-immutable") || IS_NAMED_PRIM(rator, "string->immutable-string") || IS_NAMED_PRIM(rator, "symbol->string") - || IS_NAMED_PRIM(rator, "keyword->string")) { + || IS_NAMED_PRIM(rator, "symbol->immutable-string") + || IS_NAMED_PRIM(rator, "keyword->string") + || IS_NAMED_PRIM(rator, "keyword->immutable-string")) { return scheme_string_p_proc; } else if (IS_NAMED_PRIM(rator, "bytes-append") || IS_NAMED_PRIM(rator, "bytes->immutable-bytes")) { @@ -4663,12 +4666,14 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz check_known(info, app_o, rator, rand, "length", scheme_list_p_proc, scheme_true, info->unsafe_mode); check_known(info, app_o, rator, rand, "string-append", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "string-append-immutable", scheme_string_p_proc, scheme_true, info->unsafe_mode); check_known(info, app_o, rator, rand, "bytes-append", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); check_known(info, app_o, rator, rand, "string->immutable-string", scheme_string_p_proc, scheme_true, info->unsafe_mode); check_known(info, app_o, rator, rand, "bytes->immutable-bytes", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); check_known(info, app_o, rator, rand, "string->symbol", scheme_string_p_proc, scheme_true, info->unsafe_mode); check_known(info, app_o, rator, rand, "symbol->string", scheme_symbol_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "symbol->string-immutable", scheme_symbol_p_proc, scheme_true, info->unsafe_mode); check_known(info, app_o, rator, rand, "string->keyword", scheme_string_p_proc, scheme_true, info->unsafe_mode); check_known(info, app_o, rator, rand, "keyword->string", scheme_keyword_p_proc, scheme_true, info->unsafe_mode); diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index b2532a7c1c..94e098a1ea 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -14,7 +14,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1460 +#define EXPECTED_PRIM_COUNT 1463 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 86a895ed1f..6acbdea775 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 5 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 13 +#define MZSCHEME_VERSION_W 14 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 021795387c..f5cc4930f0 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -15267,8 +15267,8 @@ static const char *startup_source = "(let-values(((sym_0)(syntax-content id_0)))" "(let-values(((key_0)" "(string->uninterned-symbol" -"(string-append" -"(symbol->string" +"(string-append-immutable" +"(symbol->immutable-string" "(let-values(((or-part_0) local-sym_0))(if or-part_0 or-part_0 sym_0)))" " \"_\"" "(number->string c_0)))))" diff --git a/racket/src/racket/src/string.c b/racket/src/racket/src/string.c index ad722a2713..b6044c25b2 100644 --- a/racket/src/racket/src/string.c +++ b/racket/src/racket/src/string.c @@ -73,6 +73,7 @@ static Scheme_Object *string_locale_upcase (int argc, Scheme_Object *argv[]); static Scheme_Object *string_locale_downcase (int argc, Scheme_Object *argv[]); static Scheme_Object *substring (int argc, Scheme_Object *argv[]); static Scheme_Object *string_append (int argc, Scheme_Object *argv[]); +static Scheme_Object *string_append_immutable (int argc, Scheme_Object *argv[]); static Scheme_Object *string_to_list (int argc, Scheme_Object *argv[]); static Scheme_Object *list_to_string (int argc, Scheme_Object *argv[]); static Scheme_Object *string_copy (int argc, Scheme_Object *argv[]); @@ -178,6 +179,7 @@ ROSYM static Scheme_Object *racket_symbol, *cgc_symbol, *_3m_symbol, *cs_symbol; ROSYM static Scheme_Object *force_symbol, *infer_symbol; ROSYM static Scheme_Object *platform_3m_path, *platform_cgc_path, *platform_cs_path; READ_ONLY static Scheme_Object *zero_length_char_string; +READ_ONLY static Scheme_Object *zero_length_char_immutable_string; READ_ONLY static Scheme_Object *zero_length_byte_string; SHARED_OK static char *embedding_banner; @@ -256,8 +258,11 @@ scheme_init_string (Scheme_Startup_Env *env) infer_symbol = scheme_intern_symbol("infer"); REGISTER_SO(zero_length_char_string); + REGISTER_SO(zero_length_char_immutable_string); REGISTER_SO(zero_length_byte_string); zero_length_char_string = scheme_alloc_char_string(0, 0); + zero_length_char_immutable_string = scheme_alloc_char_string(0, 0); + SCHEME_SET_CHAR_STRING_IMMUTABLE(zero_length_char_immutable_string); zero_length_byte_string = scheme_alloc_byte_string(0, 0); REGISTER_SO(complete_symbol); @@ -421,6 +426,10 @@ scheme_init_string (Scheme_Startup_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); scheme_addto_prim_instance("string-append", p, env); + p = scheme_make_immed_prim(string_append_immutable, "string-append-immutable", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string-append-immutable", p, env); + scheme_addto_prim_instance("string->list", scheme_make_immed_prim(string_to_list, "string->list", @@ -1071,6 +1080,20 @@ Scheme_Object *scheme_string_eq_2(Scheme_Object *str1, Scheme_Object *str2) return string_eq(2, a); } +Scheme_Object *string_append_immutable(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *r; + + r = do_string_append("string-append-immutable", argc, argv); + + if (r == zero_length_char_string) + return zero_length_char_immutable_string; + + SCHEME_SET_CHAR_STRING_IMMUTABLE(r); + + return r; +} + /**********************************************************************/ /* byte strings */ /**********************************************************************/ diff --git a/racket/src/racket/src/strops.inc b/racket/src/racket/src/strops.inc index 2948a15cf0..7efe12f88b 100644 --- a/racket/src/racket/src/strops.inc +++ b/racket/src/racket/src/strops.inc @@ -317,7 +317,7 @@ X__(substring) (int argc, Scheme_Object *argv[]) } static Scheme_Object * -X__(string_append) (int argc, Scheme_Object *argv[]) +X__(do_string_append) (const char *who, int argc, Scheme_Object *argv[]) { Scheme_Object *naya, *s; Xchar *chars; @@ -328,7 +328,7 @@ X__(string_append) (int argc, Scheme_Object *argv[]) for (i = 0; i < argc; i++) { s = argv[i]; if (!SCHEME_X_STRINGP(s)) - scheme_wrong_contract(XSTRINGSTR "-append", IS_STR, i, argc, argv); + scheme_wrong_contract(who, IS_STR, i, argc, argv); len += SCHEME_X_STRTAG_VAL(s); } @@ -348,6 +348,12 @@ X__(string_append) (int argc, Scheme_Object *argv[]) return naya; } +static Scheme_Object * +X__(string_append) (int argc, Scheme_Object *argv[]) +{ + return X__(do_string_append)(XSTRINGSTR "-append", argc, argv); +} + Scheme_Object * X(scheme_append, _string)(Scheme_Object *str1, Scheme_Object *str2) { diff --git a/racket/src/racket/src/symbol.c b/racket/src/racket/src/symbol.c index e078261a22..eb1899428e 100644 --- a/racket/src/racket/src/symbol.c +++ b/racket/src/racket/src/symbol.c @@ -51,10 +51,12 @@ static Scheme_Object *string_to_symbol_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *string_to_uninterned_symbol_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *string_to_unreadable_symbol_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *symbol_to_string_prim (int argc, Scheme_Object *argv[]); +static Scheme_Object *symbol_to_immutable_string_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *keyword_p_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *keyword_lt (int argc, Scheme_Object *argv[]); static Scheme_Object *string_to_keyword_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *keyword_to_string_prim (int argc, Scheme_Object *argv[]); +static Scheme_Object *keyword_to_immutable_string_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *gensym(int argc, Scheme_Object *argv[]); @@ -336,6 +338,10 @@ scheme_init_symbol (Scheme_Startup_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); scheme_addto_prim_instance("symbol->string", p, env); + p = scheme_make_folding_prim(symbol_to_immutable_string_prim, "symbol->immutable-string", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("symbol->immutable-string", p, env); + REGISTER_SO(scheme_keyword_p_proc); p = scheme_make_folding_prim(keyword_p_prim, "keyword?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED @@ -354,6 +360,10 @@ scheme_init_symbol (Scheme_Startup_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); scheme_addto_prim_instance("keyword->string", p, env); + p = scheme_make_folding_prim(keyword_to_immutable_string_prim, "keyword->immutable-string", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("keyword->immutable-string", p, env); + ADD_IMMED_PRIM("gensym", gensym, 0, 1, env); } @@ -850,6 +860,24 @@ symbol_to_string_prim (int argc, Scheme_Object *argv[]) return scheme_symbol_to_string(sym); } +static Scheme_Object * +symbol_to_immutable_string_prim (int argc, Scheme_Object *argv[]) +{ + Scheme_Object *sym, *str; + + sym = argv[0]; + + if (!SCHEME_SYMBOLP(sym)) + scheme_wrong_contract("symbol->immutable-string", "symbol?", 0, argc, argv); + + /* Could cache, but currently we don't */ + + str = scheme_symbol_to_string(sym); + SCHEME_SET_CHAR_STRING_IMMUTABLE(str); + + return str; +} + static Scheme_Object * keyword_p_prim (int argc, Scheme_Object *argv[]) @@ -937,6 +965,25 @@ keyword_to_string_prim (int argc, Scheme_Object *argv[]) SCHEME_SYM_LEN(argv[0])); } +static Scheme_Object * +keyword_to_immutable_string_prim (int argc, Scheme_Object *argv[]) +{ + Scheme_Object *str; + + if (!SCHEME_KEYWORDP(argv[0])) + scheme_wrong_contract("keyword->immutable-string", "keyword?", 0, argc, argv); + + /* Could cache, but currently we don't */ + + str = scheme_make_sized_offset_utf8_string((char *)(argv[0]), + SCHEME_SYMSTR_OFFSET(argv[0]), + SCHEME_SYM_LEN(argv[0])); + + SCHEME_SET_CHAR_STRING_IMMUTABLE(str); + + return str; +} + static Scheme_Object *gensym(int argc, Scheme_Object *argv[]) { char buffer[100], *str;