Hi all, After a few failed attempts, I finally figured out a way to fix #1077 without breaking the world. The issue was that "qualified" symbols (i.e., things like ##core#blabla) are encoded with a length prefix byte like so: "\004coreblabla". That means all symbols that start with a byte that's lower than 41 will be treated as qualified symbols.
The only reasons for it to be like this are historical, as far as I can tell. So, I wanted to make these symbols represented like all others, as simply "##core#foo". Changing the reader to avoid encoding them in the special way is not enough, because the "internal" core language uses qualified symbols all over the place (think ##core#inline and such). The compiler would still be comparing the symbols it read against those it was compiled with, which means the reader would read "##core#inline" but the compiler's C code still had "\004coreinline" in its symbol table as a different symbol. The workaround I came up with is to simply malloc a new string whenever we try to intern a qualified symbol like "\004coreinline". This new string is then changed to read "##core#inline". That way, we'll end up with _only_ new-style qualified symbols, even if the runtime is still filled with old-style qualified symbols. Everything is normalized at the point of interning. The first attached patch takes care of this. Then, when you have compiled a compiler with the first patch and bootstrapped it with itself, it will no longer contain any old-style qualified symbols in the runtime. Then, all the special-cased code for old-style qualified symbols can be dropped. The second patch takes care of this. I think the first patch should be applied, then a new 5.0.1 snapshot should be tagged. This snapshot should then be used in bootstrap.sh so we have a version that can build new CHICKENs correctly. Then we can apply the second patch to drop all the deprecated compatibility code. The second patch also contains a regression test for #1077. Finally, keywords like foo: are still encoded as "\000foo". We might want to fix that as well, but that should be an easier fix and not as invasive. On the other hand, it will also require a binary version bump, so we could decide to tackle it right now too. I'm just not sure how to, yet. Cheers, Peter
From b1c5373682781e7e5986a40cb643835060cd3e27 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sun, 6 Jan 2019 16:36:54 +0100
Subject: [PATCH 1/2] When interning "qualified" symbols, convert them to
regular symbols
This is a preparatory step in fixing #1077. Once we have a
bootstrapping compiler that reads qualified symbols and interns them
as "##foo#bar" instead of as "\003foobar", it will also no longer emit
code with strings that are encoded in the old style.
The hack must be in the interning step so that the new runtime will
still be compatible with an old compiler: that compiler will still
generate code like "\003foobar". Without this hack, we'd get errors
like "\003syscar is unbound" if we'd only change the reading of these
symbols.
Luckily, uninterned symbols don't matter for this.
This is a total hack which is also very wasteful and dumb because it
will malloc a new string whenever it encounters a qualified symbol.
But that's only in the intermediate bootstrapping compiler: after that,
when compiling a new CHICKEN, there should be no more dequalification
happening.
---
NEWS | 4 ++++
library.scm | 39 +++++++++++-----------------------
repl.scm | 1 -
runtime.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++----------
4 files changed, 74 insertions(+), 39 deletions(-)
diff --git a/NEWS b/NEWS
index 7d5f4d19..957760ad 100644
--- a/NEWS
+++ b/NEWS
@@ -27,6 +27,10 @@
specification and also give sensible results on Windows.
- Fix get-environment from (chicken process-context) to raise an
error when passed #f instead of segfaulting.
+ - Qualified symbols (##foo#bar style) are no longer encoded by a
+ byte prefix inside the symbol name. This ensures read-write
+ invariance of symbols which start with a low-byte character
+ (fixes #1077, except for keywords, which start with NUL bytes).
5.0.0
diff --git a/library.scm b/library.scm
index 0891f6a4..d7dc35ad 100644
--- a/library.scm
+++ b/library.scm
@@ -2674,6 +2674,7 @@ EOF
(##sys#intern-symbol str) )
(define ##sys#symbol->string)
+;; DEPRECATED: Remove this once we have a new bootstrapping compiler
(define ##sys#symbol->qualified-string)
(define ##sys#qualified-symbol-prefix)
@@ -2693,6 +2694,7 @@ EOF
[i (split str len)] )
(if i (##sys#substring str i len) str) ) ) )
+ ;; DEPRECATED: Remove this once we have a new bootstrapping compiler
(set! ##sys#symbol->qualified-string
(lambda (s)
(let* ([str (##sys#slot s 1)]
@@ -2702,6 +2704,7 @@ EOF
(string-append "##" (##sys#substring str 1 i) "#" (##sys#substring str i len))
str) ) ) )
+ ;; DEPRECATED: Remove this once we have a new bootstrapping compiler
(set! ##sys#qualified-symbol-prefix
(lambda (s)
(let* ([str (##sys#slot s 1)]
@@ -2709,18 +2712,12 @@ EOF
[i (split str len)] )
(and i (##sys#substring str 0 i)) ) ) ) )
+;; DEPRECATED: Remove this once we have a new bootstrapping compiler
(define (##sys#qualified-symbol? s)
(let ((str (##sys#slot s 1)))
(and (fx> (##sys#size str) 0)
(fx<= (##sys#byte str 0) namespace-max-id-len))))
-(define ##sys#string->qualified-symbol
- (lambda (prefix str)
- (##sys#string->symbol
- (if prefix
- (##sys#string-append prefix str)
- str) ) ) )
-
(set! scheme#symbol->string
(lambda (s)
(##sys#check-symbol s 'symbol->string)
@@ -3710,7 +3707,6 @@ EOF
(define ##sys#default-read-info-hook #f)
(define ##sys#read-error-with-line-number #f)
-(define ##sys#enable-qualifiers #t)
(define (##sys#read-prompt-hook) #f) ; just here so that srfi-18 works without eval
(define (##sys#infix-list-hook lst) lst)
@@ -4152,24 +4148,8 @@ EOF
(loop i) ) ) ) ) ) )
(define (r-ext-symbol)
- (let* ([p (##sys#make-string 1)]
- [tok (r-token)]
- [toklen (##sys#size tok)] )
- (unless ##sys#enable-qualifiers
- (##sys#read-error port "qualified symbol syntax is not allowed" tok) )
- (let loop ([i 0])
- (cond [(fx>= i toklen)
- (##sys#read-error port "invalid qualified symbol syntax" tok) ]
- [(fx= (##sys#byte tok i) (char->integer #\#))
- (when (fx> i namespace-max-id-len)
- (set! tok (##sys#substring tok 0 namespace-max-id-len)) )
- (##sys#setbyte p 0 i)
- (##sys#intern-symbol
- (string-append
- p
- (##sys#substring tok 0 i)
- (##sys#substring tok (fx+ i 1) toklen)) ) ]
- [else (loop (fx+ i 1))] ) ) ) )
+ (let ((tok (r-token)))
+ (build-symbol (string-append "##" tok))))
(define (build-symbol tok)
(##sys#intern-symbol tok) )
@@ -4556,7 +4536,12 @@ EOF
(eq? c #\-) )
(not (##sys#string->number str)) )
((eq? c #\:) (not (eq? ksp #:prefix)))
- ((eq? c #\#) ;; #!rest, #!key etc
+ ((and (eq? c #\#)
+ ;; Not a qualified symbol?
+ (not (and (fx> len 2)
+ (eq? (##core#inline "C_subchar" str 1) #\#)
+ (not (eq? (##core#inline "C_subchar" str 2) #\#)))))
+ ;; #!rest, #!key etc
(eq? (##core#inline "C_subchar" str 1) #\!))
((specialchar? c) #f)
(else #t) ) )
diff --git a/repl.scm b/repl.scm
index 7d7ef771..4ec97efa 100644
--- a/repl.scm
+++ b/repl.scm
@@ -146,7 +146,6 @@
(##sys#reset-handler
(lambda ()
(set! ##sys#read-error-with-line-number #f)
- (set! ##sys#enable-qualifiers #t)
(resetports)
(c #f)))))
(##sys#read-prompt-hook)
diff --git a/runtime.c b/runtime.c
index 2a5415fa..1ac6e4f8 100644
--- a/runtime.c
+++ b/runtime.c
@@ -597,6 +597,45 @@ C_dbg(C_char *prefix, C_char *fstr, ...)
va_end(va);
}
+/*
+ * Dequalify symbol string if necessary. This is a temporary hack to
+ * ensure that all interned symbols are in the literal ##foo#bar
+ * style. This enforces compatibility between a new runtime and code
+ * compiled by an older compiler which still generates \003foobar
+ * literal symbols. This transition is needed to fix #1077. Because
+ * of its temporary nature (ideally we just build a new bootstrapping
+ * compiler with this in which the hack should have no effect), we can
+ * afford to be stupidly wasteful and just malloc a new string every
+ * time we get here.
+ *
+ * DEPRECATED: Remove this once we have a new bootstrapping compiler
+ */
+static C_char *dequalified_symbol_string(C_char *str, int *len)
+{
+ C_char *deq_str;
+ int prefix = (int)str[0];
+
+ if (prefix >= 31) return str; /* namespace-max-id-len */
+ if (prefix == 0) return str; /* keyword (TODO: change this too) */
+
+ deq_str = malloc(*len+3);
+ if (deq_str == NULL) {
+ horror(C_text("cannot dequalify string - out of memory"));
+ }
+
+ deq_str[0] = '#';
+ deq_str[1] = '#';
+ memcpy(deq_str + 2, str + 1, prefix);
+ deq_str[prefix + 2] = '#';
+ memcpy(deq_str + prefix + 3, str + 1 + prefix, *len - prefix - 1);
+ deq_str[*len+2] = '\0'; /* Not always part of original str, but if it is, we must add it */
+ *len += 2;
+ if(debug_mode) {
+ C_dbg(C_text("debug"), C_text("Dequalified [%o]%.*s into %s\n"), str[0], len-3, str+1, deq_str);
+ }
+ return deq_str;
+}
+
/* Startup code: */
@@ -1108,12 +1147,12 @@ void initialize_symbol_table(void)
for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);
/* Obtain reference to hooks for later: */
- core_provided_symbol = C_intern2(C_heaptop, C_text("\004coreprovided"));
- interrupt_hook_symbol = C_intern2(C_heaptop, C_text("\003sysinterrupt-hook"));
- error_hook_symbol = C_intern2(C_heaptop, C_text("\003syserror-hook"));
- callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("\003syscallback-continuation-stack"), C_SCHEME_END_OF_LIST);
- pending_finalizers_symbol = C_intern2(C_heaptop, C_text("\003syspending-finalizers"));
- current_thread_symbol = C_intern3(C_heaptop, C_text("\003syscurrent-thread"), C_SCHEME_FALSE);
+ core_provided_symbol = C_intern2(C_heaptop, C_text("##core#provided"));
+ interrupt_hook_symbol = C_intern2(C_heaptop, C_text("##sys#interrupt-hook"));
+ error_hook_symbol = C_intern2(C_heaptop, C_text("##sys#error-hook"));
+ callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("##sys#callback-continuation-stack"), C_SCHEME_END_OF_LIST);
+ pending_finalizers_symbol = C_intern2(C_heaptop, C_text("##sys#pending-finalizers"));
+ current_thread_symbol = C_intern3(C_heaptop, C_text("##sys#current-thread"), C_SCHEME_FALSE);
}
@@ -2278,6 +2317,8 @@ C_regparm C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBO
int key;
C_word s;
+ str = dequalified_symbol_string(str, &len);
+
if(stable == NULL) stable = symbol_table;
key = hash_string(len, str, stable->size, stable->rand, 0);
@@ -2299,6 +2340,8 @@ C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYM
int key;
C_word s;
+ str = dequalified_symbol_string(str, &len);
+
if(stable == NULL) stable = symbol_table;
key = hash_string(len, str, stable->size, stable->rand, 0);
@@ -2322,6 +2365,8 @@ C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYM
C_regparm C_word C_fcall intern0(C_char *str)
{
int len = C_strlen(str);
+ str = dequalified_symbol_string(str, &len);
+
int key = hash_string(len, str, symbol_table->size, symbol_table->rand, 0);
C_word s;
@@ -2335,10 +2380,11 @@ C_regparm C_word C_fcall C_lookup_symbol(C_word sym)
int key;
C_word str = C_block_item(sym, 1);
int len = C_header_size(str);
+ C_char *the_str = dequalified_symbol_string(C_c_string(str), &len);
- key = hash_string(len, C_c_string(str), symbol_table->size, symbol_table->rand, 0);
+ key = hash_string(len, the_str, symbol_table->size, symbol_table->rand, 0);
- return lookup(key, len, C_c_string(str), symbol_table);
+ return lookup(key, len, the_str, symbol_table);
}
@@ -5866,7 +5912,7 @@ void C_ccall C_signum(C_word c, C_word *av)
} else if (C_truep(C_bignump(x))) {
C_kontinue(k, C_bignum_negativep(x) ? C_fix(-1) : C_fix(1));
} else {
- try_extended_number("\003sysextended-signum", 2, k, x);
+ try_extended_number("##sys#extended-signum", 2, k, x);
}
}
@@ -9948,6 +9994,7 @@ 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);
+ name = dequalified_symbol_string(name, &len);
key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);
if(!C_truep(s = lookup(key, len, name, symbol_table)))
@@ -10412,7 +10459,7 @@ void C_ccall C_number_to_string(C_word c, C_word *av)
C_integer_to_string(c, av); /* reuse av */
} else {
C_word k = av[ 1 ];
- try_extended_number("\003sysextended-number->string", 3, k, num, radix);
+ try_extended_number("##sys#extended-number->string", 3, k, num, radix);
}
}
@@ -10533,7 +10580,7 @@ void C_ccall C_integer_to_string(C_word c, C_word *av)
if (len > C_RECURSIVE_TO_STRING_THRESHOLD &&
/* The power of two fast path is much faster than recursion */
((C_uword)1 << radix_shift) != radix) {
- try_extended_number("\003sysinteger->string/recursive",
+ try_extended_number("##sys#integer->string/recursive",
4, k, num, C_fix(radix), C_fix(len));
} else {
C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, kav[6];
--
2.11.0
From 1cbd6fa8b5a8ee500957e2749783a1555d730b53 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sun, 6 Jan 2019 19:48:51 +0100
Subject: [PATCH 2/2] Drop support for old-style qualified symbols (fixes
#1077)
All checks for qualified symbols are either removed or replaced with
checks for keywords as those are the only remaining things that are
still encoded in the old style.
The procedure ##sys#symbol->qualified-string is no longer necessary,
instead we can simply call ##sys#symbol->string.
This also bumps BINARYVERSION to ensure new runtimes aren't mixed with
old code.
---
NEWS | 5 +++++
c-backend.scm | 10 ++++-----
chicken-profile.scm | 2 +-
csi.scm | 10 +++------
defaults.make | 2 +-
expand.scm | 2 +-
extras.scm | 2 +-
library.scm | 54 ++++++-------------------------------------------
modules.scm | 2 +-
runtime.c | 52 ++---------------------------------------------
support.scm | 12 +++++------
tests/library-tests.scm | 11 ++++++++++
12 files changed, 43 insertions(+), 121 deletions(-)
diff --git a/NEWS b/NEWS
index 957760ad..7a2f0087 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,8 @@
+5.0.2
+
+- Runtime system
+ - Increased the "binary compatibility version" to 11.
+
5.0.1
- Type system
diff --git a/c-backend.scm b/c-backend.scm
index ac79abb5..4ad307d0 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -237,7 +237,7 @@
(if safe
(gen "lf[" index "]")
(gen "C_retrieve2(lf[" index "],C_text("
- (c-ify-string (##sys#symbol->qualified-string
+ (c-ify-string (##sys#symbol->string
(fourth params))) "))"))]
[safe (gen "*((C_word*)lf[" index "]+1)")]
[else (gen "C_fast_retrieve(lf[" index "])")] ) ) )
@@ -249,7 +249,7 @@
(if block
(gen "C_mutate(&lf[" index "]")
(gen "C_mutate((C_word*)lf[" index "]+1"))
- (gen " /* (set! " (uncommentify (##sys#symbol->qualified-string var)) " ...) */,")
+ (gen " /* (set! " (uncommentify (##sys#symbol->string var)) " ...) */,")
(expr (car subs) i)
(gen #\)) ) )
@@ -259,12 +259,12 @@
(var (third params)) )
(cond [block
(gen "lf[" index "] /* "
- (uncommentify (##sys#symbol->qualified-string var)) " */ =")
+ (uncommentify (##sys#symbol->string var)) " */ =")
(expr (car subs) i)
(gen #\;) ]
[else
(gen "C_set_block_item(lf[" index "] /* "
- (uncommentify (##sys#symbol->qualified-string var)) " */,0,")
+ (uncommentify (##sys#symbol->string var)) " */,0,")
(expr (car subs) i)
(gen #\)) ] ) ) )
@@ -349,7 +349,7 @@
(if safe
(gen "C_fast_retrieve_proc(" carg ")")
(gen "C_retrieve2_symbol_proc(" carg ",C_text("
- (c-ify-string (##sys#symbol->qualified-string (fourth gparams))) "))")))
+ (c-ify-string (##sys#symbol->string (fourth gparams))) "))")))
(safe
(set! carg
(string-append "*((C_word*)lf[" (number->string index) "]+1)"))
diff --git a/chicken-profile.scm b/chicken-profile.scm
index d5739297..06c174a4 100644
--- a/chicken-profile.scm
+++ b/chicken-profile.scm
@@ -234,7 +234,7 @@ EOF
(t (third entry)) ; total time
(a (fourth entry)) ; average time
(p (fifth entry)) ) ; % of max time
- (list (##sys#symbol->qualified-string (first entry))
+ (list (##sys#symbol->string (first entry))
(if (not c) "overflow" (number->string c))
(format-real (/ t 1000) seconds-digits)
(format-real (/ a 1000) average-digits)
diff --git a/csi.scm b/csi.scm
index 29d1b64b..cde3c019 100644
--- a/csi.scm
+++ b/csi.scm
@@ -621,13 +621,9 @@ EOF
((symbol? x)
(unless (##sys#symbol-has-toplevel-binding? x)
(display "unbound " out))
- (let ((q (##sys#qualified-symbol? x)))
- (fprintf out "~a~asymbol with name ~S~%"
- (if (##sys#interned-symbol? x) "" "uninterned ")
- (if q "qualified " "")
- (if q
- (##sys#symbol->qualified-string x)
- (##sys#symbol->string x))))
+ (fprintf out "~asymbol with name ~S~%"
+ (if (##sys#interned-symbol? x) "" "uninterned ")
+ (##sys#symbol->string x))
(let ((plist (##sys#slot x 2)))
(unless (null? plist)
(display " \nproperties:\n\n" out)
diff --git a/defaults.make b/defaults.make
index 34bd301d..4da4d633 100644
--- a/defaults.make
+++ b/defaults.make
@@ -27,7 +27,7 @@
# basic parameters
-BINARYVERSION = 9
+BINARYVERSION = 10
STACKDIRECTION ?= 1
CROSS_CHICKEN ?= 0
diff --git a/expand.scm b/expand.scm
index c228735d..ec302d48 100644
--- a/expand.scm
+++ b/expand.scm
@@ -94,7 +94,7 @@
(else #f)))
(define (macro-alias var se)
- (if (or (##sys#qualified-symbol? var) (namespaced-symbol? var))
+ (if (or (keyword? var) (namespaced-symbol? var))
var
(let* ((alias (gensym var))
(ua (or (lookup var se) var))
diff --git a/extras.scm b/extras.scm
index ec504fc6..3449294e 100644
--- a/extras.scm
+++ b/extras.scm
@@ -421,7 +421,7 @@
(let ((proc (style head)))
(if proc
(proc expr col extra)
- (if (> (string-length (##sys#symbol->qualified-string head))
+ (if (> (string-length (##sys#symbol->string head))
max-call-head-width)
(pp-general expr col extra #f #f #f pp-expr)
(pp-call expr col extra pp-expr))))
diff --git a/library.scm b/library.scm
index d7dc35ad..08c437df 100644
--- a/library.scm
+++ b/library.scm
@@ -952,7 +952,6 @@ EOF
(import chicken.base)
-(define-constant namespace-max-id-len 31)
(define-constant char-name-table-size 37)
(define-constant output-string-initial-size 256)
(define-constant read-line-buffer-initial-size 1024)
@@ -2673,50 +2672,11 @@ EOF
(##sys#check-string str)
(##sys#intern-symbol str) )
-(define ##sys#symbol->string)
-;; DEPRECATED: Remove this once we have a new bootstrapping compiler
-(define ##sys#symbol->qualified-string)
-(define ##sys#qualified-symbol-prefix)
-
-(let ([string-append string-append]
- [string-copy string-copy] )
-
- (define (split str len)
- (let ([b0 (##sys#byte str 0)]) ; we fetch the byte, wether len is 0 or not
- (if (and (fx> len 0) (fx< b0 len) (fx<= b0 namespace-max-id-len))
- (fx+ b0 1)
- #f) ) )
-
- (set! ##sys#symbol->string
- (lambda (s)
- (let* ([str (##sys#slot s 1)]
- [len (##sys#size str)]
- [i (split str len)] )
- (if i (##sys#substring str i len) str) ) ) )
-
- ;; DEPRECATED: Remove this once we have a new bootstrapping compiler
- (set! ##sys#symbol->qualified-string
- (lambda (s)
- (let* ([str (##sys#slot s 1)]
- [len (##sys#size str)]
- [i (split str len)] )
- (if i
- (string-append "##" (##sys#substring str 1 i) "#" (##sys#substring str i len))
- str) ) ) )
-
- ;; DEPRECATED: Remove this once we have a new bootstrapping compiler
- (set! ##sys#qualified-symbol-prefix
- (lambda (s)
- (let* ([str (##sys#slot s 1)]
- [len (##sys#size str)]
- [i (split str len)] )
- (and i (##sys#substring str 0 i)) ) ) ) )
-
-;; DEPRECATED: Remove this once we have a new bootstrapping compiler
-(define (##sys#qualified-symbol? s)
+(define (##sys#symbol->string s)
(let ((str (##sys#slot s 1)))
- (and (fx> (##sys#size str) 0)
- (fx<= (##sys#byte str 0) namespace-max-id-len))))
+ (if (##core#inline "C_u_i_keywordp" s) ; Keywords encoded as \000foo
+ (##sys#substring str 1 (string-length str))
+ str)))
(set! scheme#symbol->string
(lambda (s)
@@ -4588,8 +4548,6 @@ EOF
(else
(outstr port "#:")
(outsym port x))))
- ((##sys#qualified-symbol? x)
- (outstr port (##sys#symbol->qualified-string x)))
(else
(outsym port x))))
((##sys#number? x) (outstr port (##sys#number->string x)))
@@ -5191,7 +5149,7 @@ EOF
(loc (and loca (cadr loca))) )
(if (and loc (symbol? loc))
(string-append
- "(" (##sys#symbol->qualified-string loc) ") "
+ "(" (##sys#symbol->string loc) ") "
(cond ((symbol? msg) (##sys#slot msg 1))
((string? msg) msg)
(else "") ) ) ; Hm...
@@ -5338,7 +5296,7 @@ EOF
(display ": " port)
(let ((loc (errloc ex)))
(when (and loc (symbol? loc))
- (display (string-append "(" (##sys#symbol->qualified-string loc) ") ") port) ) )
+ (display (string-append "(" (##sys#symbol->string loc) ") ") port) ) )
(display msg port) ) )
(else
(let ((kinds (##sys#slot ex 1)))
diff --git a/modules.scm b/modules.scm
index b0cdce59..e018de5f 100644
--- a/modules.scm
+++ b/modules.scm
@@ -768,7 +768,7 @@
(register-undefined sym mod where))
(module-rename sym (module-name mod))))
(else sym)))
- (cond ((##sys#qualified-symbol? sym) sym)
+ (cond ((keyword? sym) sym)
((namespaced-symbol? sym) sym)
((assq sym (##sys#current-environment)) =>
(lambda (a)
diff --git a/runtime.c b/runtime.c
index 1ac6e4f8..75cc8d41 100644
--- a/runtime.c
+++ b/runtime.c
@@ -597,46 +597,6 @@ C_dbg(C_char *prefix, C_char *fstr, ...)
va_end(va);
}
-/*
- * Dequalify symbol string if necessary. This is a temporary hack to
- * ensure that all interned symbols are in the literal ##foo#bar
- * style. This enforces compatibility between a new runtime and code
- * compiled by an older compiler which still generates \003foobar
- * literal symbols. This transition is needed to fix #1077. Because
- * of its temporary nature (ideally we just build a new bootstrapping
- * compiler with this in which the hack should have no effect), we can
- * afford to be stupidly wasteful and just malloc a new string every
- * time we get here.
- *
- * DEPRECATED: Remove this once we have a new bootstrapping compiler
- */
-static C_char *dequalified_symbol_string(C_char *str, int *len)
-{
- C_char *deq_str;
- int prefix = (int)str[0];
-
- if (prefix >= 31) return str; /* namespace-max-id-len */
- if (prefix == 0) return str; /* keyword (TODO: change this too) */
-
- deq_str = malloc(*len+3);
- if (deq_str == NULL) {
- horror(C_text("cannot dequalify string - out of memory"));
- }
-
- deq_str[0] = '#';
- deq_str[1] = '#';
- memcpy(deq_str + 2, str + 1, prefix);
- deq_str[prefix + 2] = '#';
- memcpy(deq_str + prefix + 3, str + 1 + prefix, *len - prefix - 1);
- deq_str[*len+2] = '\0'; /* Not always part of original str, but if it is, we must add it */
- *len += 2;
- if(debug_mode) {
- C_dbg(C_text("debug"), C_text("Dequalified [%o]%.*s into %s\n"), str[0], len-3, str+1, deq_str);
- }
- return deq_str;
-}
-
-
/* Startup code: */
int CHICKEN_main(int argc, char *argv[], void *toplevel)
@@ -2317,8 +2277,6 @@ C_regparm C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBO
int key;
C_word s;
- str = dequalified_symbol_string(str, &len);
-
if(stable == NULL) stable = symbol_table;
key = hash_string(len, str, stable->size, stable->rand, 0);
@@ -2340,8 +2298,6 @@ C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYM
int key;
C_word s;
- str = dequalified_symbol_string(str, &len);
-
if(stable == NULL) stable = symbol_table;
key = hash_string(len, str, stable->size, stable->rand, 0);
@@ -2365,8 +2321,6 @@ C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYM
C_regparm C_word C_fcall intern0(C_char *str)
{
int len = C_strlen(str);
- str = dequalified_symbol_string(str, &len);
-
int key = hash_string(len, str, symbol_table->size, symbol_table->rand, 0);
C_word s;
@@ -2380,11 +2334,10 @@ C_regparm C_word C_fcall C_lookup_symbol(C_word sym)
int key;
C_word str = C_block_item(sym, 1);
int len = C_header_size(str);
- C_char *the_str = dequalified_symbol_string(C_c_string(str), &len);
- key = hash_string(len, the_str, symbol_table->size, symbol_table->rand, 0);
+ key = hash_string(len, C_c_string(str), symbol_table->size, symbol_table->rand, 0);
- return lookup(key, len, the_str, symbol_table);
+ return lookup(key, len, C_c_string(str), symbol_table);
}
@@ -9994,7 +9947,6 @@ 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);
- name = dequalified_symbol_string(name, &len);
key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);
if(!C_truep(s = lookup(key, len, name, symbol_table)))
diff --git a/support.scm b/support.scm
index fbf8e4f9..48616a8e 100644
--- a/support.scm
+++ b/support.scm
@@ -588,8 +588,8 @@
(if ln
(let ([rn (real-name name)])
(list ln
- (or rn (##sys#symbol->qualified-string name))) )
- (##sys#symbol->qualified-string name) ) )
+ (or rn (##sys#symbol->string name))) )
+ (##sys#symbol->string name) ) )
(map walk x) ) ) ) ) )
(else (make-node '##core#call (list #f) (map walk x))) ) )
(let ([exp2 (walk exp)])
@@ -925,7 +925,7 @@
(set! ##sys#toplevel-definition-hook
(lambda (sym renamed exported?)
- (cond ((or (##sys#qualified-symbol? sym) (namespaced-symbol? sym))
+ (cond ((namespaced-symbol? sym)
(unhide-variable sym))
((not exported?)
(debugging 'o "hiding unexported module binding" renamed)
@@ -1434,10 +1434,10 @@
n2)
n) ) )
(let ((rn (resolve var)))
- (cond ((not rn) (##sys#symbol->qualified-string var))
+ (cond ((not rn) (##sys#symbol->string var))
((pair? db)
(let ((db (car db)))
- (let loop ((nesting (list (##sys#symbol->qualified-string rn)))
+ (let loop ((nesting (list (##sys#symbol->string rn)))
(depth 0)
(container (db-get db var 'contained-in)) )
(cond
@@ -1451,7 +1451,7 @@
(fx+ depth 1)
(db-get db container 'contained-in) ) ) ))
(else (string-intersperse (reverse nesting) " in "))) ) ) )
- (else (##sys#symbol->qualified-string rn)) ) ) )
+ (else (##sys#symbol->string rn)) ) ) )
(define (real-name2 var db) ; Used only in c-backend.scm
(and-let* ((rn (hash-table-ref real-name-table var)))
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index f31e17f0..f7a1d3ff 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -321,6 +321,17 @@
;; "Unterminated string" (unterminated identifier?)
(assert-fail (with-input-from-string "a|Bc" read)))
+;;; Old style qualified low byte, see #1077
+
+(assert (string=? "##foo#bar" (symbol->string '|##foo#bar|)))
+(assert (string=? "##foo#bar" (symbol->string '##foo#bar)))
+(assert (eq? '##foo#bar '|##foo#bar|))
+
+(assert (string=? "|\\x0a|" (with-output-to-string (lambda () (write '|\n|)))))
+;; NOT YET, keywords are still prefixed with \000:
+; (assert (string=? "|\000foo|" (with-output-to-string (lambda () (write '|\000foo|)))))
+(assert (string=? "|###foo#bar|" (with-output-to-string (lambda () (write '|###foo#bar|)))))
+
;;; Paren synonyms
(parameterize ((parentheses-synonyms #f))
--
2.11.0
signature.asc
Description: PGP signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
