~ chicken-core (chicken-5) afd7867444fa5f378a241296b1d43479e98fc37a
commit afd7867444fa5f378a241296b1d43479e98fc37a
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sun May 14 18:25:49 2017 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Mon May 15 20:20:11 2017 +0200
Exempt explicitly-namespaced symbols from module aliasing
This adds an "escape hatch" to variable resolution for namespaced
symbols (e.g. `foo#bar`), allowing them to be used across module
boundaries just like qualified symbols.
This is done by simple string scanning of the identifier's name, which
is emphatically not ideal as it means the compiler has to do more work
as it checks whether a symbol is "namespaced" or not. The performance of
generated programs isn't affected (besides `eval` of course), but we
will still want to fix this before too long, probably when fixing #1077.
To help mitigate the problem in the meantime, the patch makes sure the
scanning procedure is always inlined.
The one test case that checked for the inverse behaviour (no visibility
of unimported namespaced symbols) has been removed.
This change also avoids unnecessarily hiding identifiers when qualified
symbols are bound to a value within a module. Previously, things like
'|foo#\x03sysbar| would be marked hidden despite never being bound,
since ##sys#toplevel-definition-hook wouldn't considering whether or not
the symbol would really be aliased by ##sys#alias-global-hook. This
didn't cause any problems, but it was inaccurate.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/chicken.h b/chicken.h
index d03109ac..d9bcfab7 100644
--- a/chicken.h
+++ b/chicken.h
@@ -899,6 +899,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
# define C_strcmp strcmp
# define C_strncmp strncmp
# define C_strlen strlen
+# define C_memchr memchr
# define C_memset memset
# define C_memmove memmove
# define C_strncasecmp strncasecmp
@@ -1022,6 +1023,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_bignum_size(b) (C_bytestowords(C_header_size(C_internal_bignum_vector(b)))-1)
#define C_make_header(type, size) ((C_header)(((type) & C_HEADER_BITS_MASK) | ((size) & C_HEADER_SIZE_MASK)))
#define C_symbol_value(x) (C_block_item(x, 0))
+#define C_symbol_name(x) (C_block_item(x, 1))
#define C_symbol_plist(x) (C_block_item(x, 2))
#define C_save(x) (*(--C_temporary_stack) = (C_word)(x))
#define C_rescue(x, i) (C_temporary_stack[ i ] = (x))
@@ -2247,6 +2249,11 @@ inline static C_word C_permanentp(C_word x)
!C_in_scratchspacep(x));
}
+inline static C_word C_u_i_namespaced_symbolp(C_word x)
+{
+ C_word s = C_symbol_name(x);
+ return C_mk_bool(C_memchr(C_data_pointer(s), '#', C_header_size(s)));
+}
inline static C_word C_flonum(C_word **ptr, double n)
{
diff --git a/expand.scm b/expand.scm
index 4397d22a..c471d351 100644
--- a/expand.scm
+++ b/expand.scm
@@ -33,8 +33,7 @@
(disable-interrupts)
(fixnum)
(hide check-for-multiple-bindings)
- (not inline ##sys#syntax-error-hook ##sys#compiler-syntax-hook
- ##sys#toplevel-definition-hook))
+ (not inline ##sys#syntax-error-hook ##sys#compiler-syntax-hook))
(module chicken.expand
(expand
@@ -83,6 +82,9 @@
(define-inline (putp sym prop val)
(##core#inline_allocate ("C_a_i_putprop" 8) sym prop val))
+(define-inline (namespaced-symbol? sym)
+ (##core#inline "C_u_i_namespaced_symbolp" sym))
+
;;; Source file tracking
(define ##sys#current-source-filename #f)
@@ -107,11 +109,7 @@
(else #f)))
(define (macro-alias var se)
- (if (or (##sys#qualified-symbol? var)
- (let* ((str (##sys#slot var 1))
- (len (##sys#size str)))
- (and (fx> len 0)
- (char=? #\# (##core#inline "C_subchar" str 0)))))
+ (if (or (##sys#qualified-symbol? var) (namespaced-symbol? var))
var
(let* ((alias (gensym var))
(ua (or (lookup var se) var))
diff --git a/modules.scm b/modules.scm
index 2bf32c6c..15635ca7 100644
--- a/modules.scm
+++ b/modules.scm
@@ -61,6 +61,8 @@
(define-inline (putp sym prop val)
(##core#inline_allocate ("C_a_i_putprop" 8) sym prop val))
+(define-inline (namespaced-symbol? sym)
+ (##core#inline "C_u_i_namespaced_symbolp" sym))
;;; Support definitions
@@ -173,7 +175,7 @@
(set-module-exist-list! mod (append el exps)))
(set-module-export-list! mod (append xl exps)))))
-(define (##sys#toplevel-definition-hook sym mod exp val) #f)
+(define (##sys#toplevel-definition-hook sym renamed exported?) #f)
(define (##sys#register-meta-expression exp)
(and-let* ((mod (##sys#current-module)))
@@ -191,8 +193,7 @@
(find-export sym mod #t)))
(ulist (module-undefined-list mod)))
(##sys#toplevel-definition-hook ; in compiler, hides unexported bindings
- (module-rename sym (module-name mod))
- mod exp #f)
+ sym (module-rename sym (module-name mod)) exp)
(and-let* ((a (assq sym ulist)))
(set-module-undefined-list! mod (delete a ulist eq?)))
(check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
@@ -778,6 +779,7 @@
((getp sym '##core#aliased)
(dm "(ALIAS) marked: " sym)
sym)
+ ((namespaced-symbol? sym) sym)
((assq sym ((##sys#active-eval-environment))) =>
(lambda (a)
(let ((sym2 (cdr a)))
diff --git a/runtime.c b/runtime.c
index febf4d6c..1d6dedec 100644
--- a/runtime.c
+++ b/runtime.c
@@ -4604,7 +4604,7 @@ C_word C_message(C_word msg)
* Strictly speaking this isn't necessary for the non-gui-mode,
* but let's try and keep this consistent across modes.
*/
- if (memchr(C_c_string(msg), '\0', n) != NULL)
+ if (C_memchr(C_c_string(msg), '\0', n) != NULL)
barf(C_ASCIIZ_REPRESENTATION_ERROR, "##sys#message", msg);
if(C_gui_mode) {
diff --git a/support.scm b/support.scm
index 3d2f413b..e0402d2a 100644
--- a/support.scm
+++ b/support.scm
@@ -909,10 +909,13 @@
;;; change hook function to hide non-exported module bindings
(set! ##sys#toplevel-definition-hook
- (lambda (sym mod exp val)
- (when (and (not val) (not exp))
- (debugging 'o "hiding nonexported module bindings" sym)
- (hide-variable sym))))
+ (lambda (sym renamed exported?)
+ (cond ((or (##sys#qualified-symbol? sym) (namespaced-symbol? sym))
+ (unhide-variable sym))
+ ((not exported?)
+ (debugging 'o "hiding unexported module binding" renamed)
+ (hide-variable renamed)))))
+
;;; Foreign callback stub and type tables:
@@ -1604,6 +1607,9 @@
(define (variable-hidden? sym)
(eq? (##sys#get sym '##compiler#visibility) 'hidden))
+(define (unhide-variable sym)
+ (when (variable-hidden? sym) (remprop! sym '##compiler#visibility)))
+
(define (variable-visible? sym block-compilation)
(let ((p (##sys#get sym '##compiler#visibility)))
(case p
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 1c4941a9..3f061fbf 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -899,16 +899,6 @@
(import (prefix rfoo f:))
(f:rbar 1)
-;;; Internal hash-prefixed names shouldn't work within modules
-
-(module one (always-one)
- (import scheme)
- (define (always-one) 1))
-
-(f (eval '(module two ()
- (import scheme)
- (define (always-two) (+ (one#always-one) 1)))))
-
;;; SRFI-2 (and-let*)
(t 1 (and-let* ((a 1)) a))
diff --git a/tweaks.scm b/tweaks.scm
index b1d3dfd3..d473dcfe 100644
--- a/tweaks.scm
+++ b/tweaks.scm
@@ -50,6 +50,9 @@
(define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic))
+(define-inline (namespaced-symbol? sym)
+ (##core#inline "C_u_i_namespaced_symbolp" sym))
+
(define-inline (mark-variable var mark #!optional (val #t))
(##sys#put! var mark val) )
Trap