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

add {symbol,keyword}->immutable-string and string-append-immutable

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2019-12-17 19:09:24 -07:00
parent 2270513c27
commit 27eb177b9d
20 changed files with 196 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

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

30
pkgs/racket-doc/scribblings/reference/data.scrbl
View File

@ -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[(keyword<? [a-keyword keyword?] [b-keyword keyword?] ...) boolean?]{
@ -71,6 +93,8 @@ for each pair of keywords is the same as using
@racket[keyword->string] with @racket[string->bytes/utf-8] and
@racket[bytes<?].
@mz-examples[(keyword<? '#:apple '#:banana)]
@history/arity[]}
@; ----------------------------------------------------------------------

11
pkgs/racket-doc/scribblings/reference/strings.scrbl
View File

@ -155,6 +155,17 @@ contains the concatenated characters of the given @racket[str]s. If no
@mz-examples[(string-append "Apple" "Banana")]}
@defproc[(string-append-immutable [str string?] ...) (and/c string? immutable?)]{
The same as @racket[string-append], but the result is an immutable
string.
@mz-examples[(string-append-immutable "Apple" "Banana")
(immutable? (string-append-immutable "A" "B"))]
@history[#:added "7.5.0.14"]}
@defproc[(string->list [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

47
pkgs/racket-doc/scribblings/reference/symbols.scrbl
View File

@ -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[(symbol<? [a-sym symbol?] [b-sym symbol?] ...) boolean?]{

18
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -433,6 +433,10 @@
(test "ab" symbol->string 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 keyword<? (string->keyword "\uFF") (string->keyword "\uA0"))
(test #f keyword<? (string->keyword "\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 keyword<? 1 -1)
@ -824,6 +833,15 @@
(err/rt-test (string-append 1))
(err/rt-test (string-append "hello" 1))
(err/rt-test (string-append "hello" 1 "done"))
(test "foobar" string-append-immutable "foo" "bar")
(test "foo" string-append-immutable "foo")
(test "" string-append-immutable)
(test "" string-append-immutable "" "")
(test #t immutable? (string-append-immutable "foo" "bar"))
(test #t immutable? (string-append-immutable "foo"))
(test #t immutable? (string-append-immutable "" ""))
(test #t immutable? (string-append-immutable))
(test #f immutable? (string-append (string->immutable-string "hello")))
(test "" make-string 0)
(define s (string-copy "hello"))
(define s2 (string-copy s))

2
racket/src/cs/compile-file.ss
View File

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

3
racket/src/cs/primitive/kernel.ss
View File

@ -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)]
[keyword<? (known-procedure/folding -2)]
[keyword? (known-procedure/pure/folding 2)]
@ -793,6 +794,7 @@
[string->uninterned-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-ci<? (known-procedure/no-prompt -2)]
[string-ci=? (known-procedure/no-prompt -2)]
@ -879,6 +881,7 @@
[subprocess-wait (known-procedure 2)]
[subprocess? (known-procedure 2)]
[substring (known-procedure/no-prompt 12)]
[symbol->immutable-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)]

2
racket/src/cs/rumble.sls
View File

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

4
racket/src/cs/rumble/keyword.ss
View File

@ -20,6 +20,10 @@
(check who keyword? kw)
(symbol->string (keyword-symbol kw)))
(define/who (keyword->immutable-string kw)
(check who keyword? kw)
(#%symbol->string (keyword-symbol kw)))
(define/who keyword<?
(case-lambda
[(a)

4
racket/src/cs/rumble/symbol.ss
View File

@ -52,6 +52,10 @@
(check who symbol? s)
(string-copy (#%symbol->string 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

7
racket/src/expander/expand/env.rkt
View File

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

6
racket/src/io/print/main.rkt
View File

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

2
racket/src/io/print/symbol.rkt
View File

@ -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 #\[)

7
racket/src/racket/src/optimize.c
View File

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

2
racket/src/racket/src/schminc.h
View File

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

2
racket/src/racket/src/schvers.h
View File

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

4
racket/src/racket/src/startup.inc
View File

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

23
racket/src/racket/src/string.c
View File

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

10
racket/src/racket/src/strops.inc
View File

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

47
racket/src/racket/src/symbol.c
View File

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