From cb40a24fd447ca6799d7d5c19d826f26a42449a1 Mon Sep 17 00:00:00 2001 From: Peter Bex 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. Signed-off-by: felix --- 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.16.2