Add uninterned symbols
Uninterned symbols are slightly more expensive to allocate than 0- or 1-argument calls to `gensym`, but they're much cheaper to hash (and print). They're also more consistently distinct when unfasled, and the fasled form is determinsitic. original commit: 3167083008031b1f880e76a6f573563c7d9c888c
This commit is contained in:
parent
7e36c21d81
commit
de2dedcdd7
|
@ -315,6 +315,7 @@ extern void S_prim_init PROTO((void));
|
|||
extern ptr S_strerror PROTO((INT errnum));
|
||||
extern void S_prim5_init PROTO((void));
|
||||
extern void S_dump_tc PROTO((ptr tc));
|
||||
extern ptr S_uninterned PROTO((ptr x));
|
||||
|
||||
/* print.c */
|
||||
extern void S_print_init PROTO((void));
|
||||
|
|
9
c/fasl.c
9
c/fasl.c
|
@ -652,6 +652,15 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
|
|||
*x = S_intern3(&STRIT(*pstrbuf, 0), pn, &STRIT(*pstrbuf, pn), un, Sfalse, Sfalse);
|
||||
return;
|
||||
}
|
||||
case fasl_type_uninterned_symbol: {
|
||||
iptr i, n;
|
||||
ptr str;
|
||||
n = uptrin(f);
|
||||
str = S_string((char *)0, n);
|
||||
for (i = 0; i != n; i += 1) Sstring_set(str, i, uptrin(f));
|
||||
*x = S_uninterned(str);
|
||||
return;
|
||||
}
|
||||
case fasl_type_ratnum:
|
||||
*x = S_rational(FIX(0), FIX(0));
|
||||
faslin(tc, &RATNUM(*x), t, pstrbuf, f);
|
||||
|
|
20
c/prim5.c
20
c/prim5.c
|
@ -962,6 +962,25 @@ static ptr s_strings_to_gensym(ptr pname_str, ptr uname_str) {
|
|||
pname_str, uname_str);
|
||||
}
|
||||
|
||||
ptr S_uninterned(x) ptr x; {
|
||||
ptr sym;
|
||||
static uptr hc;
|
||||
|
||||
require(Sstringp(x),"string->uninterned-symbol","~s is not a string",x);
|
||||
|
||||
sym = S_symbol(Scons(x, Sfalse));
|
||||
|
||||
/* Wraparound on `hc++` is ok. It's technically illegal with
|
||||
threads, since multiple thread might increment `hc` at the same
|
||||
time; we don't care if we miss an increment sometimes, and we
|
||||
assume compilers won't take this as a license for arbitrarily bad
|
||||
behavior: */
|
||||
hc++;
|
||||
INITSYMHASH(sym) = FIX(hc);
|
||||
|
||||
return sym;
|
||||
}
|
||||
|
||||
static ptr s_mkdir(const char *inpath, INT mode) {
|
||||
INT status; ptr res; char *path;
|
||||
|
||||
|
@ -1516,6 +1535,7 @@ void S_prim5_init() {
|
|||
Sforeign_symbol("(cs)s_intern3", (void *)s_intern3);
|
||||
Sforeign_symbol("(cs)s_strings_to_gensym", (void *)s_strings_to_gensym);
|
||||
Sforeign_symbol("(cs)s_intern_gensym", (void *)S_intern_gensym);
|
||||
Sforeign_symbol("(cs)s_uninterned", (void *)S_uninterned);
|
||||
Sforeign_symbol("(cs)cputime", (void *)S_cputime);
|
||||
Sforeign_symbol("(cs)realtime", (void *)S_realtime);
|
||||
Sforeign_symbol("(cs)clock_gettime", (void *)S_clock_gettime);
|
||||
|
|
|
@ -1550,7 +1550,7 @@ These parameters are not consulted until that time; setting them when
|
|||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{gensym?}{\categoryprocedure}{(gensym? \var{obj})}
|
||||
\returns \scheme{#t} if \var{obj} is gensym, \scheme{#f} otherwise
|
||||
\returns \scheme{#t} if \var{obj} is a gensym, \scheme{#f} otherwise
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
|
@ -1564,6 +1564,63 @@ These parameters are not consulted until that time; setting them when
|
|||
\endschemedisplay
|
||||
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{string->uninterned-symbol}{\categoryprocedure}{(string->uninterned-symbol \var{str})}
|
||||
\returns a fresh uninterned symbol
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\var{str} must be a string.
|
||||
|
||||
Returns an uninterned symbol that prints the same as a symbol
|
||||
constructed from \var{str}, but which is not \scheme{eq?} to any
|
||||
other symbol.
|
||||
|
||||
When an uninterned symbol is converted by the fasl writer, the fasl
|
||||
reader will allocate a fresh uninterned symbol each time the fasl
|
||||
stream is read. Multiple occurrences of the same uninterned symbol in
|
||||
the fasl writer's argument will become multiple occurrences of the
|
||||
same new uninterned symbol in the fasl reader's result for the stream.
|
||||
|
||||
\noskip\schemedisplay
|
||||
(string->uninterned-symbol "z") ;=> z
|
||||
(uninterned-symbol? (string->uninterned-symbol "z")) ;=> #t
|
||||
(symbol? (string->uninterned-symbol "z")) ;=> #t
|
||||
(gensym? (string->uninterned-symbol "z")) ;=> #f
|
||||
\endschemedisplay
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{uninterned-symbol?}{\categoryprocedure}{(uninterned-symbol? \var{obj})}
|
||||
\returns \scheme{#t} if \var{obj} is an uninterned symbol, \scheme{#f} otherwise
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noskip\schemedisplay
|
||||
(uninterned-symbol? (string->symbol "z")) ;=> #f
|
||||
(uninterned-symbol? (gensym "z")) ;=> #f
|
||||
(uninterned-symbol? (string->uninterned-symbol "z")) ;=> #t
|
||||
\endschemedisplay
|
||||
|
||||
|
||||
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{uninterned-symbol?}{\categoryprocedure}{(uninterned-symbol? \var{obj})}
|
||||
\returns \scheme{#t} if \var{obj} is an uninterned symbol, \scheme{#f} otherwise
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noskip\schemedisplay
|
||||
(uninterned-symbol? (string->symbol "z")) ;=> #f
|
||||
(uninterned-symbol? (gensym "z")) ;=> #f
|
||||
(uninterned-symbol? (string->uninterned-symbol "z")) ;=> #t
|
||||
\endschemedisplay
|
||||
|
||||
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader\label{property-lists}
|
||||
\formdef{putprop}{\categoryprocedure}{(putprop \var{symbol} \var{key} \var{value})}
|
||||
|
|
19
mats/5_7.ms
19
mats/5_7.ms
|
@ -105,3 +105,22 @@
|
|||
(error? (putprop "hi" 'key 'value))
|
||||
(error? (property-list '(a b c)))
|
||||
)
|
||||
|
||||
(mat uninterned-symbol
|
||||
(symbol? (string->uninterned-symbol "hello"))
|
||||
(uninterned-symbol? (string->uninterned-symbol "hello"))
|
||||
(not (gensym? (string->uninterned-symbol "hello")))
|
||||
|
||||
(equal? "hello" (symbol->string (string->uninterned-symbol "hello")))
|
||||
|
||||
(not (eq? (string->uninterned-symbol "hello")
|
||||
(string->uninterned-symbol "hello")))
|
||||
|
||||
(let-values ([(o get) (open-bytevector-output-port)])
|
||||
(let ([s (string->uninterned-symbol "hello")])
|
||||
(fasl-write (list s s) o)
|
||||
(let ([r (fasl-read (open-bytevector-input-port (get)))])
|
||||
(and (eq? (car r) (cadr r))
|
||||
(equal? "hello" (symbol->string (car r)))))))
|
||||
|
||||
)
|
||||
|
|
|
@ -328,7 +328,7 @@
|
|||
[(_ foo e1 e2) e1] ...
|
||||
[(_ bar e1 e2) e2]))))])))
|
||||
|
||||
(define-constant scheme-version #x09050305)
|
||||
(define-constant scheme-version #x09050306)
|
||||
|
||||
(define-syntax define-machine-types
|
||||
(lambda (x)
|
||||
|
@ -457,6 +457,7 @@
|
|||
|
||||
(define-constant fasl-type-begin 41)
|
||||
(define-constant fasl-type-phantom 42)
|
||||
(define-constant fasl-type-uninterned-symbol 43)
|
||||
|
||||
(define-constant fasl-fld-ptr 0)
|
||||
(define-constant fasl-fld-u8 1)
|
||||
|
@ -1242,7 +1243,7 @@
|
|||
([ptr value]
|
||||
[ptr pvalue]
|
||||
[ptr plist]
|
||||
[ptr name]
|
||||
[ptr name] ; (cons str #f) => uninterned; #f or (cons ptr str) => gensym
|
||||
[ptr splist]
|
||||
[ptr hash]))
|
||||
|
||||
|
|
2
s/cp0.ss
2
s/cp0.ss
|
@ -4876,7 +4876,7 @@
|
|||
(not (preinfo-lambda-name preinfo)))
|
||||
(preinfo-lambda-name-set! preinfo
|
||||
(let ([x ($symbol-name name)])
|
||||
(if (pair? x) (cdr x) x))))
|
||||
(if (pair? x) (or (cdr x) (car x)) x))))
|
||||
(context-case ctxt
|
||||
[(value tail)
|
||||
(bump sc 1)
|
||||
|
|
|
@ -1225,7 +1225,7 @@
|
|||
[(string? x) x]
|
||||
[(symbol? x)
|
||||
(let ([name ($symbol-name x)])
|
||||
(if (pair? name) (cdr name) name))]
|
||||
(if (pair? name) (or (cdr name) (car name)) name))]
|
||||
[(eq? #f x) #f]
|
||||
[else (error 'np-discover-names "x is not a name" x)]))))
|
||||
(Expr : Expr (ir name moi) -> Expr ()
|
||||
|
@ -9503,8 +9503,18 @@
|
|||
(%type-check mask-symbol type-symbol ,e)
|
||||
(bind #t ([t (%mref ,e ,(constant symbol-name-disp))])
|
||||
`(if ,t
|
||||
,(%type-check mask-pair type-pair ,t)
|
||||
,(build-and (%type-check mask-pair type-pair ,t)
|
||||
(build-and (%mref ,t ,(constant pair-cdr-disp))
|
||||
(%constant strue)))
|
||||
,(%constant strue)))))])
|
||||
(define-inline 2 uninterned-symbol?
|
||||
[(e)
|
||||
(bind #t (e)
|
||||
(build-and
|
||||
(%type-check mask-symbol type-symbol ,e)
|
||||
(bind #t ([t (%mref ,e ,(constant symbol-name-disp))])
|
||||
(build-and (%type-check mask-pair type-pair ,t)
|
||||
(build-not (%mref ,t ,(constant pair-cdr-disp)))))))])
|
||||
(let ()
|
||||
(define build-make-symbol
|
||||
(lambda (e-name)
|
||||
|
@ -9541,7 +9551,10 @@
|
|||
(bind #t ([e-name (%mref ,e-sym ,(constant symbol-name-disp))])
|
||||
`(if ,e-name
|
||||
(if ,(%type-check mask-pair type-pair ,e-name)
|
||||
,(%mref ,e-name ,(constant pair-cdr-disp))
|
||||
,(bind #t ([e-cdr (%mref ,e-name ,(constant pair-cdr-disp))])
|
||||
`(if ,e-cdr
|
||||
,e-cdr
|
||||
,(%mref ,e-name ,(constant pair-car-disp))))
|
||||
,e-name)
|
||||
,(%primcall #f sexpr $gensym->pretty-name ,e-sym))))])
|
||||
(define-inline 3 $fxaddress
|
||||
|
|
|
@ -250,6 +250,9 @@
|
|||
(put-u8 p (constant fasl-type-gensym))
|
||||
(wrf-string-help (symbol->string x) p)
|
||||
(wrf-string-help uname p))]
|
||||
[(uninterned-symbol? x)
|
||||
(put-u8 p (constant fasl-type-uninterned-symbol))
|
||||
(wrf-string-help (symbol->string x) p)]
|
||||
[else
|
||||
(put-u8 p (constant fasl-type-symbol))
|
||||
(wrf-string-help (symbol->string x) p)])))
|
||||
|
|
|
@ -300,6 +300,8 @@
|
|||
(symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard safeongoodargs ieee r5rs])
|
||||
(symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs])
|
||||
(string->symbol [sig [(string) -> (symbol)]] [flags true mifoldable discard safeongoodargs ieee r5rs])
|
||||
(string->uninterned-symbol [sig [(string) -> (symbol)]] [flags true discard])
|
||||
(uninterned-symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
|
||||
(char? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
|
||||
(char->integer [sig [(char) -> (fixnum)]] [flags pure mifoldable discard safeongoodargs true ieee r5rs])
|
||||
(integer->char [sig [(sub-ufixnum) -> (char)]] [flags pure mifoldable discard true ieee r5rs])
|
||||
|
|
|
@ -146,6 +146,11 @@
|
|||
(scheme-object)
|
||||
scheme-object))
|
||||
|
||||
(define string->uninterned-symbol
|
||||
(foreign-procedure "(cs)s_uninterned"
|
||||
(scheme-object)
|
||||
scheme-object))
|
||||
|
||||
(define $intern2
|
||||
(foreign-procedure "(cs)s_intern2"
|
||||
(scheme-object scheme-object)
|
||||
|
@ -1261,6 +1266,8 @@
|
|||
|
||||
(define gensym? (lambda (x) (gensym? x)))
|
||||
|
||||
(define uninterned-symbol? (lambda (x) (uninterned-symbol? x)))
|
||||
|
||||
(define fixnum? (lambda (x) (fixnum? x)))
|
||||
|
||||
(define bignum? (lambda (x) (bignum? x)))
|
||||
|
|
Loading…
Reference in New Issue
Block a user