~ chicken-core (chicken-5) 8665e7a859d30048b82d161b1c1719d04403910e
commit 8665e7a859d30048b82d161b1c1719d04403910e
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Apr 6 17:03:15 2019 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu May 2 15:38:42 2019 +0200
Change representation of keywords
- Keywords are no longer encoded with a leading NUL byte. This allows
us to have proper read/write invariance of symbols and keywords and
ensures we don't return #t for keyword? on symbols starting with \0.
- Keywords are now kept in symbol table completely separate from the
one used for actual symbols.
- The plist of a keyword is now #f instead of '(). This is the one
thing we can use to differentiate a keyword without attempting to
look it up in the keyword table (which won't work while GC'ing).
- In order to be able to decide in which table to intern a symbol,
when encoding literals, keywords and symbols are prefixed with a
special byte: A \1-prefixed literal is decoded as a regular symbol,
a \2-prefixed literal is read as a keyword.
- When persisting or unpersisting a symbol, loop through *all* the
symbol tables when trying to locate the symbol.
Another small change is in how keywords are converted to nodes by the
compiler; originally they would (accidentally) be represented as
##core#variable nodes. The intention was to auto-quote them in
canonicalize-expression, but due to how the cond was placed this
result would be thrown away and would be converted into ##core#variable
instead.
This is the first step towards fixing #1578. For bootstrapping
reasons, this current implementation still accepts NUL-prefixed
symbols as keywords. There is backwards compatible support code which
detects such symbols and interns them into (or looks them up in) the
keyword table instead.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/c-backend.scm b/c-backend.scm
index 4ad307d0..037eab3e 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -42,6 +42,7 @@
chicken.foreign
chicken.format
chicken.internal
+ chicken.keyword
chicken.platform
chicken.sort
chicken.string
@@ -739,11 +740,14 @@
((char? lit)
(gen #t to "=C_make_character(" (char->integer lit) ");") )
((symbol? lit) ; handled slightly specially (see C_h_intern_in)
- (let* ([str (##sys#slot lit 1)]
- [cstr (c-ify-string str)]
- [len (##sys#size str)] )
+ (let* ((str (##sys#slot lit 1))
+ (cstr (c-ify-string str))
+ (len (##sys#size str))
+ (intern (if (keyword? lit)
+ "C_h_intern_kw"
+ "C_h_intern")))
(gen #t to "=")
- (gen "C_h_intern(&" to #\, len ", C_text(" cstr "));")))
+ (gen intern "(&" to #\, len ", C_text(" cstr "));")))
((null? lit)
(gen #t to "=C_SCHEME_END_OF_LIST;") )
((and (not (##sys#immediate? lit)) ; nop
@@ -1483,8 +1487,9 @@ return((C_header_bits(lit) >> 24) & 0xff);
((symbol? lit)
(let ((str (##sys#slot lit 1)))
(string-append
- "\x01"
+ "\x01"
(encode-size (string-length str))
+ (if (keyword? lit) "\x02" "\x01")
str) ) )
((##sys#immediate? lit)
(bomb "invalid literal - cannot encode" lit))
diff --git a/chicken.h b/chicken.h
index 68b636df..20dab23e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -583,7 +583,7 @@ void *alloca ();
#define C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR 2
#define C_BAD_ARGUMENT_TYPE_ERROR 3
#define C_UNBOUND_VARIABLE_ERROR 4
-/* Unused: 5 */
+#define C_BAD_ARGUMENT_TYPE_SYMBOL_IS_KEYWORD_ERROR 5
#define C_OUT_OF_MEMORY_ERROR 6
#define C_DIVISION_BY_ZERO_ERROR 7
#define C_OUT_OF_RANGE_ERROR 8
@@ -1760,8 +1760,10 @@ C_fctexport C_word C_fcall C_string_aligned8(C_word **ptr, int len, C_char *str)
C_fctexport C_word C_fcall C_string2(C_word **ptr, C_char *str) C_regparm;
C_fctexport C_word C_fcall C_string2_safe(C_word **ptr, int max, C_char *str) C_regparm;
C_fctexport C_word C_fcall C_intern(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_intern_kw(C_word **ptr, int len, C_char *str) C_regparm;
C_fctexport C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
C_fctexport C_word C_fcall C_h_intern(C_word *slot, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_h_intern_kw(C_word *slot, int len, C_char *str) C_regparm;
C_fctexport C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
C_fctexport C_word C_fcall C_intern2(C_word **ptr, C_char *str) C_regparm;
C_fctexport C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value) C_regparm;
@@ -1827,6 +1829,7 @@ C_fctexport void C_fcall C_gc_unprotect(int n) C_regparm;
C_fctexport C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size) C_regparm;
C_fctexport C_SYMBOL_TABLE *C_find_symbol_table(char *name) C_regparm;
C_fctexport C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable) C_regparm;
+C_fctexport C_word C_find_keyword(C_word str, C_SYMBOL_TABLE *stable) C_regparm;
C_fctexport C_word C_fcall C_lookup_symbol(C_word sym) C_regparm;
C_fctexport void C_do_register_finalizer(C_word x, C_word proc);
C_fctexport int C_do_unregister_finalizer(C_word x);
@@ -1866,6 +1869,7 @@ C_fctexport C_cpsproc(C_gc) C_noret;
C_fctexport C_cpsproc(C_open_file_port) C_noret;
C_fctexport C_cpsproc(C_allocate_vector) C_noret;
C_fctexport C_cpsproc(C_string_to_symbol) C_noret;
+C_fctexport C_cpsproc(C_string_to_keyword) C_noret;
C_fctexport C_cpsproc(C_build_symbol) C_noret;
C_fctexport C_cpsproc(C_number_to_string) C_noret;
C_fctexport C_cpsproc(C_fixnum_to_string) C_noret;
@@ -2192,11 +2196,7 @@ inline static C_word C_u_i_namespaced_symbolp(C_word x)
inline static C_word C_u_i_keywordp(C_word x)
{
- /* TODO: This representation is rather bogus */
- C_word n = C_symbol_name(x);
- return C_mk_bool(C_symbol_value(x) == x &&
- C_header_size(n) > 0 &&
- ((C_byte *)C_data_pointer(n))[0] == '\0');
+ return C_mk_bool(C_symbol_plist(x) == C_SCHEME_FALSE);
}
inline static C_word C_flonum(C_word **ptr, double n)
@@ -2658,9 +2658,10 @@ inline static C_word C_i_symbolp(C_word x)
inline static int C_persistable_symbol(C_word x)
{
- /* Symbol is bound (and not a keyword), or has a non-empty plist */
- return ((C_truep(C_boundp(x)) && !C_truep(C_u_i_keywordp(x))) ||
- C_symbol_plist(x) != C_SCHEME_END_OF_LIST);
+ /* Symbol is bound, or has a non-empty plist (but is not a keyword) */
+ return ((C_truep(C_boundp(x)) ||
+ C_symbol_plist(x) != C_SCHEME_END_OF_LIST) &&
+ !C_truep(C_u_i_keywordp(x)));
}
inline static C_word C_i_pairp(C_word x)
diff --git a/core.scm b/core.scm
index 06a4cf7f..eabba538 100644
--- a/core.scm
+++ b/core.scm
@@ -522,7 +522,8 @@
(else (find-id id (cdr se)))))
(define (lookup id)
- (cond ((find-id id (##sys#current-environment)))
+ (cond ((keyword? id) id)
+ ((find-id id (##sys#current-environment)))
((##sys#get id '##core#macro-alias) symbol? => values)
(else id)))
@@ -560,6 +561,11 @@
x) )
(define (resolve-variable x0 e dest ldest h)
+
+ (when (memq x0 unlikely-variables)
+ (warning
+ (sprintf "reference to variable `~s' possibly unintended" x0) ))
+
(let ((x (lookup x0)))
(d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) (##sys#current-environment))))
(cond ((not (symbol? x)) x0) ; syntax?
@@ -614,12 +620,8 @@
(print "\n;; END OF FILE"))))) ) )
(define (walk x e dest ldest h outer-ln tl?)
- (cond ((symbol? x)
- (cond ((keyword? x) `(quote ,x))
- ((memq x unlikely-variables)
- (warning
- (sprintf "reference to variable `~s' possibly unintended" x) )))
- (resolve-variable x e dest ldest h))
+ (cond ((keyword? x) `(quote ,x))
+ ((symbol? x) (resolve-variable x e dest ldest h))
((not (pair? x))
(if (constant? x)
`(quote ,x)
diff --git a/expand.scm b/expand.scm
index 277c035b..2092798c 100644
--- a/expand.scm
+++ b/expand.scm
@@ -111,6 +111,7 @@
(let ((seen '()))
(let walk ((x exp))
(cond ((assq x seen) => cdr)
+ ((keyword? x) x)
((symbol? x)
(let ((x2 (getp x '##core#macro-alias) ) )
(cond ((getp x '##core#real-name))
@@ -836,7 +837,7 @@
(cons (rename (car sym)) (rename (cdr sym))))
((vector? sym)
(list->vector (rename (vector->list sym))))
- ((not (symbol? sym)) sym)
+ ((or (not (symbol? sym)) (keyword? sym)) sym)
((assq sym renv) =>
(lambda (a)
(dd `(RENAME/RENV: ,sym --> ,(cdr a)))
@@ -859,7 +860,8 @@
(do ((i 0 (fx+ i 1))
(f #t (compare (vector-ref s1 i) (vector-ref s2 i))))
((or (fx>= i len) (not f)) f))))))
- ((and (symbol? s1) (symbol? s2))
+ ((and (symbol? s1) (not (keyword? s1))
+ (symbol? s2) (not (keyword? s2)))
(let ((ss1 (or (getp s1 '##core#macro-alias)
(lookup2 1 s1 dse)
s1) )
@@ -897,7 +899,7 @@
(cons (mirror-rename (car sym)) (mirror-rename (cdr sym))))
((vector? sym)
(list->vector (mirror-rename (vector->list sym))))
- ((not (symbol? sym)) sym)
+ ((or (not (symbol? sym)) (keyword? sym)) sym)
(else ; Code stolen from strip-syntax
(let ((renamed (lookup sym se) ) )
(cond ((assq-reverse sym renv) =>
diff --git a/library.scm b/library.scm
index e7ada7f4..c7ce2b5a 100644
--- a/library.scm
+++ b/library.scm
@@ -2666,6 +2666,7 @@ EOF
(define ##sys#snafu '##sys#fnord)
(define ##sys#intern-symbol (##core#primitive "C_string_to_symbol"))
+(define ##sys#intern-keyword (##core#primitive "C_string_to_keyword"))
(define (##sys#interned-symbol? x) (##core#inline "C_lookup_symbol" x))
(define (##sys#string->symbol str)
@@ -2673,10 +2674,7 @@ EOF
(##sys#intern-symbol str) )
(define (##sys#symbol->string s)
- (let ((str (##sys#slot s 1)))
- (if (##core#inline "C_u_i_keywordp" s) ; Keywords encoded as \000foo
- (##sys#substring str 1 (string-length str))
- str)))
+ (##sys#slot s 1))
(set! scheme#symbol->string
(lambda (s)
@@ -2738,7 +2736,7 @@ EOF
(let ([string string] )
(lambda (s)
(##sys#check-string s 'string->keyword)
- (##sys#intern-symbol (##sys#string-append (string (integer->char 0)) s)) ) ) )
+ (##sys#intern-keyword s) ) ) )
(define keyword->string
(let ([keyword? keyword?])
@@ -3709,8 +3707,7 @@ EOF
(case-sensitive case-sensitive)
(parentheses-synonyms parentheses-synonyms)
(symbol-escape symbol-escape)
- (current-read-table ##sys#current-read-table)
- (kwprefix (string (integer->char 0))))
+ (current-read-table ##sys#current-read-table))
(lambda (port infohandler)
(let ((csp (case-sensitive))
(ksp (keyword-style))
@@ -4119,8 +4116,7 @@ EOF
(##sys#intern-symbol tok) )
(define (build-keyword tok)
- (##sys#intern-symbol
- (##sys#string-append kwprefix tok)))
+ (##sys#intern-keyword tok))
;; now have the state to make a decision.
(set! reserved-characters
@@ -5381,7 +5377,7 @@ EOF
(if fn (list fn) '()))))
((3) (apply ##sys#signal-hook #:type-error loc "bad argument type" args))
((4) (apply ##sys#signal-hook #:runtime-error loc "unbound variable" args))
- ;; ((5) ...unused...)
+ ((5) (apply ##sys#signal-hook #:type-error loc "symbol is a keyword, which has no plist" args))
((6) (apply ##sys#signal-hook #:limit-error loc "out of memory" args))
((7) (apply ##sys#signal-hook #:arithmetic-error loc "division by zero" args))
((8) (apply ##sys#signal-hook #:bounds-error loc "out of range" args))
diff --git a/runtime.c b/runtime.c
index 55d6db2a..4ba8dda1 100644
--- a/runtime.c
+++ b/runtime.c
@@ -155,6 +155,7 @@ static C_TLS int timezone;
#endif
#define DEFAULT_SYMBOL_TABLE_SIZE 2999
+#define DEFAULT_KEYWORD_TABLE_SIZE 999
#define DEFAULT_HEAP_SIZE DEFAULT_STACK_SIZE
#define MINIMAL_HEAP_SIZE DEFAULT_STACK_SIZE
#define DEFAULT_SCRATCH_SPACE_SIZE 256
@@ -400,7 +401,8 @@ static C_TLS C_char
*save_string;
static C_TLS C_SYMBOL_TABLE
*symbol_table,
- *symbol_table_list;
+ *symbol_table_list,
+ *keyword_table;
static C_TLS C_word
**collectibles,
**collectibles_top,
@@ -714,6 +716,12 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
if(symbol_table == NULL)
return 0;
+ /* TODO: Should we use "symbols" here too? */
+ keyword_table = C_new_symbol_table("kw", DEFAULT_KEYWORD_TABLE_SIZE);
+
+ if(keyword_table == NULL)
+ return 0;
+
page_size = 0;
stack_size = stack ? stack : DEFAULT_STACK_SIZE;
C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);
@@ -924,6 +932,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_number_to_string);
C_pte(C_make_symbol);
C_pte(C_string_to_symbol);
+ C_pte(C_string_to_keyword);
C_pte(C_apply);
C_pte(C_call_cc);
C_pte(C_values);
@@ -1120,6 +1129,22 @@ void initialize_symbol_table(void)
}
+C_regparm C_word C_find_keyword(C_word str, C_SYMBOL_TABLE *kwtable)
+{
+ C_char *sptr = C_c_string(str);
+ int len = C_header_size(str);
+ int key;
+ C_word s;
+
+ if(kwtable == NULL) kwtable = keyword_table;
+
+ key = hash_string(len, sptr, kwtable->size, kwtable->rand, 0);
+
+ if(C_truep(s = lookup(key, len, sptr, kwtable))) return s;
+ else return C_SCHEME_FALSE;
+}
+
+
void C_ccall sigsegv_trampoline(C_word c, C_word *av)
{
barf(C_MEMORY_VIOLATION_ERROR, NULL);
@@ -1353,7 +1378,6 @@ void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *st
" -:sSIZE set nursery (stack) size\n"
" -:tSIZE set symbol-table size\n"
" -:fSIZE set maximal number of pending finalizers\n"
- " -:w enable garbage collection of unused symbols\n"
" -:x deliver uncaught exceptions of other threads to primordial one\n"
" -:b enter REPL on error\n"
" -:B sound bell on major GC\n"
@@ -1670,6 +1694,11 @@ void barf(int code, char *loc, ...)
c = 1;
break;
+ case C_BAD_ARGUMENT_TYPE_SYMBOL_IS_KEYWORD_ERROR:
+ msg = C_text("symbol is a keyword, which has no plist");
+ c = 1;
+ break;
+
case C_OUT_OF_MEMORY_ERROR:
msg = C_text("not enough memory");
c = 0;
@@ -2266,16 +2295,41 @@ void C_unregister_lf(void *handle)
C_regparm C_word C_fcall C_intern(C_word **ptr, int len, C_char *str)
{
- return C_intern_in(ptr, len, str, symbol_table);
+ if (*str == '\0') { /* OBSOLETE: Backwards compatibility */
+ return C_intern_kw(ptr, len-1, str+1);
+ } else {
+ return C_intern_in(ptr, len, str, symbol_table);
+ }
}
C_regparm C_word C_fcall C_h_intern(C_word *slot, int len, C_char *str)
{
- return C_h_intern_in(slot, len, str, symbol_table);
+ if (*str == '\0') { /* OBSOLETE: Backwards compatibility */
+ return C_h_intern_kw(slot, len-1, str+1);
+ } else {
+ return C_h_intern_in(slot, len, str, symbol_table);
+ }
}
+C_regparm C_word C_fcall C_intern_kw(C_word **ptr, int len, C_char *str)
+{
+ C_word kw = C_intern_in(ptr, len, str, keyword_table);
+ C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */
+ C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */
+ return kw;
+}
+
+
+C_regparm C_word C_fcall C_h_intern_kw(C_word *slot, int len, C_char *str)
+{
+ C_word kw = C_h_intern_in(slot, len, str, keyword_table);
+ C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */
+ C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */
+ return kw;
+}
+
C_regparm C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)
{
int key;
@@ -2395,15 +2449,19 @@ C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE
C_regparm C_word C_fcall C_i_persist_symbol(C_word sym)
{
C_word bucket;
+ C_SYMBOL_TABLE *stp;
C_i_check_symbol(sym);
- bucket = lookup_bucket(sym, NULL);
- if (C_truep(bucket)) { /* It could be an uninterned symbol(?) */
- /* Change weak to strong ref to ensure long-term survival */
- C_block_header(bucket) = C_block_header(bucket) & ~C_SPECIALBLOCK_BIT;
- /* Ensure survival on next minor GC */
- if (C_in_stackp(sym)) C_mutate_slot(&C_block_item(bucket, 0), sym);
+ for(stp = symbol_table_list; stp != NULL; stp = stp->next) {
+ bucket = lookup_bucket(sym, stp);
+
+ if (C_truep(bucket)) {
+ /* Change weak to strong ref to ensure long-term survival */
+ C_block_header(bucket) = C_block_header(bucket) & ~C_SPECIALBLOCK_BIT;
+ /* Ensure survival on next minor GC */
+ if (C_in_stackp(sym)) C_mutate_slot(&C_block_item(bucket, 0), sym);
+ }
}
return C_SCHEME_UNDEFINED;
}
@@ -2415,6 +2473,7 @@ C_regparm C_word C_fcall C_i_persist_symbol(C_word sym)
C_regparm C_word C_fcall C_i_unpersist_symbol(C_word sym)
{
C_word bucket;
+ C_SYMBOL_TABLE *stp;
C_i_check_symbol(sym);
@@ -2423,11 +2482,14 @@ C_regparm C_word C_fcall C_i_unpersist_symbol(C_word sym)
return C_SCHEME_FALSE;
}
- bucket = lookup_bucket(sym, NULL);
- if (C_truep(bucket)) { /* It could be an uninterned symbol(?) */
- /* Turn it into a weak ref */
- C_block_header(bucket) = C_block_header(bucket) | C_SPECIALBLOCK_BIT;
- return C_SCHEME_TRUE;
+ for(stp = symbol_table_list; stp != NULL; stp = stp->next) {
+ bucket = lookup_bucket(sym, NULL);
+
+ if (C_truep(bucket)) {
+ /* Turn it into a weak ref */
+ C_block_header(bucket) = C_block_header(bucket) | C_SPECIALBLOCK_BIT;
+ return C_SCHEME_TRUE;
+ }
}
return C_SCHEME_FALSE;
}
@@ -2481,20 +2543,19 @@ double compute_symbol_table_load(double *avg_bucket_len, int *total_n)
C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable)
{
C_word bucket, sym, b2, *p;
- int keyw = C_header_size(string) > 0 && *((char *)C_data_pointer(string)) == 0;
p = *ptr;
sym = (C_word)p;
p += C_SIZEOF_SYMBOL;
C_block_header_init(sym, C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1));
- C_set_block_item(sym, 0, keyw ? sym : C_SCHEME_UNBOUND); /* keyword? */
+ C_set_block_item(sym, 0, C_SCHEME_UNBOUND);
C_set_block_item(sym, 1, string);
C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);
*ptr = p;
b2 = stable->table[ key ]; /* previous bucket */
/* Create new weak or strong bucket depending on persistability */
- if (C_persistable_symbol(sym) || C_truep(C_permanentp(string))) {
+ if (C_truep(C_permanentp(string))) {
bucket = C_a_pair(ptr, sym, b2);
} else {
bucket = C_a_weak_pair(ptr, sym, b2);
@@ -10569,11 +10630,51 @@ void C_ccall C_string_to_symbol(C_word c, C_word *av)
len = C_header_size(string);
name = (C_char *)C_data_pointer(string);
- key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);
- if(!C_truep(s = lookup(key, len, name, symbol_table)))
- s = add_symbol(&a, key, string, symbol_table);
+ if (*name == '\0' && len > 1) { /* OBSOLETE: Backwards compatibility */
+ key = hash_string(len-1, name+1, keyword_table->size, keyword_table->rand, 0);
+ if(!C_truep(s = lookup(key, len-1, name+1, keyword_table))) {
+ C_word *a2 = C_alloc(C_bytestowords(len-1)+1);
+ C_word string2 = C_string(&a2, len-1, name+1);
+ s = add_symbol(&a, key, string, keyword_table);
+ C_set_block_item(s, 0, s); /* Keywords evaluate to themselves */
+ C_set_block_item(s, 2, C_SCHEME_FALSE); /* Keywords have no plists */
+ }
+ } else {
+ key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);
+ if(!C_truep(s = lookup(key, len, name, symbol_table)))
+ s = add_symbol(&a, key, string, symbol_table);
+ }
+
+ C_kontinue(k, s);
+}
+
+void C_ccall C_string_to_keyword(C_word c, C_word *av)
+{
+ C_word
+ /* closure = av[ 0 ] */
+ k = av[ 1 ],
+ string;
+ int len, key;
+ C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR);
+ C_char *name;
+
+ if(c != 3) C_bad_argc(c, 3);
+ string = av[ 2 ];
+
+ if(C_immediatep(string) || C_header_bits(string) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->keyword", string);
+
+ len = C_header_size(string);
+ name = (C_char *)C_data_pointer(string);
+ key = hash_string(len, name, keyword_table->size, keyword_table->rand, 0);
+
+ if(!C_truep(s = lookup(key, len, name, keyword_table))) {
+ s = add_symbol(&a, key, string, keyword_table);
+ C_set_block_item(s, 0, s); /* Keywords evaluate to themselves */
+ C_set_block_item(s, 2, C_SCHEME_FALSE); /* Keywords have no plists */
+ }
C_kontinue(k, s);
}
@@ -12542,7 +12643,14 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
if(dest == NULL)
panic(C_text("invalid literal symbol destination"));
- val = C_h_intern(dest, size, *str);
+ if (**str == '\1') {
+ val = C_h_intern(dest, size, ++*str);
+ } else if (**str == '\2') {
+ val = C_h_intern_kw(dest, size, ++*str);
+ } else {
+ /* Backwards compatibility */
+ val = C_h_intern(dest, size, *str);
+ }
*str += size;
break;
@@ -12747,7 +12855,10 @@ error:
C_regparm C_word C_fcall
C_i_getprop(C_word sym, C_word prop, C_word def)
{
- C_word pl = C_block_item(sym, 2);
+ C_word pl = C_symbol_plist(sym);
+
+ if (pl == C_SCHEME_FALSE)
+ barf(C_BAD_ARGUMENT_TYPE_SYMBOL_IS_KEYWORD_ERROR, "get", sym);
while(pl != C_SCHEME_END_OF_LIST) {
if(C_block_item(pl, 0) == prop)
@@ -12764,6 +12875,9 @@ C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)
{
C_word pl = C_symbol_plist(sym);
+ if (pl == C_SCHEME_FALSE)
+ barf(C_BAD_ARGUMENT_TYPE_SYMBOL_IS_KEYWORD_ERROR, "put", sym);
+
/* Newly added plist? Ensure the symbol stays! */
if (pl == C_SCHEME_END_OF_LIST) C_i_persist_symbol(sym);
Trap