~ chicken-core (chicken-5) f43fb51ea3838cccd62b613cf82b3625809a9f93
commit f43fb51ea3838cccd62b613cf82b3625809a9f93
Author: felix <felix@p.callcc.org>
AuthorDate: Sun Aug 25 15:13:57 2019 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Aug 25 15:17:00 2019 +0200
Preserve global environment when executing module-registration code
Factors out preservation of the current environment into internal
procedure "##sys#with-environment" and use it in generated module-
registration code to avoid polluting the global namespace.
See also: #1548
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/modules.scm b/modules.scm
index a7fb3f18..6bbae798 100644
--- a/modules.scm
+++ b/modules.scm
@@ -317,45 +317,47 @@
(ifs (module-import-forms mod))
(sexports (module-sexports mod))
(mifs (module-meta-import-forms mod)))
- `(,@(if (and (pair? ifs) (pair? sexports))
- `((scheme#eval '(import-syntax ,@(strip-syntax ifs))))
- '())
- ,@(if (and (pair? mifs) (pair? sexports))
- `((import-syntax ,@(strip-syntax mifs)))
- '())
- ,@(if (or (getp mname '##core#functor) (pair? sexports))
- (##sys#fast-reverse (strip-syntax (module-meta-expressions mod)))
- '())
- (##sys#register-compiled-module
- ',(module-name mod)
- ',(module-library mod)
- (scheme#list ; iexports
- ,@(map (lambda (ie)
- (if (symbol? (cdr ie))
- `'(,(car ie) . ,(cdr ie))
- `(scheme#list ',(car ie) '() ,(cdr ie))))
- (module-iexports mod)))
- ',(module-vexports mod) ; vexports
- (scheme#list ; sexports
- ,@(map (lambda (sexport)
- (let* ((name (car sexport))
- (a (assq name dlist)))
- (cond ((pair? a)
- `(scheme#cons ',(car sexport) ,(strip-syntax (cdr a))))
- (else
- (dm "re-exported syntax" name mname)
+ `((##sys#with-environment
+ (lambda ()
+ ,@(if (and (pair? ifs) (pair? sexports))
+ `((scheme#eval '(import-syntax ,@(strip-syntax ifs))))
+ '())
+ ,@(if (and (pair? mifs) (pair? sexports))
+ `((import-syntax ,@(strip-syntax mifs)))
+ '())
+ ,@(if (or (getp mname '##core#functor) (pair? sexports))
+ (##sys#fast-reverse (strip-syntax (module-meta-expressions mod)))
+ '())
+ (##sys#register-compiled-module
+ ',(module-name mod)
+ ',(module-library mod)
+ (scheme#list ; iexports
+ ,@(map (lambda (ie)
+ (if (symbol? (cdr ie))
+ `'(,(car ie) . ,(cdr ie))
+ `(scheme#list ',(car ie) '() ,(cdr ie))))
+ (module-iexports mod)))
+ ',(module-vexports mod) ; vexports
+ (scheme#list ; sexports
+ ,@(map (lambda (sexport)
+ (let* ((name (car sexport))
+ (a (assq name dlist)))
+ (cond ((pair? a)
+ `(scheme#cons ',(car sexport) ,(strip-syntax (cdr a))))
+ (else
+ (dm "re-exported syntax" name mname)
`',name))))
- sexports))
- (scheme#list ; sdefs
- ,@(if (null? sexports)
- '() ; no syntax exported - no more info needed
- (let loop ((sd (module-defined-syntax-list mod)))
- (cond ((null? sd) '())
- ((assq (caar sd) sexports) (loop (cdr sd)))
- (else
- (let ((name (caar sd)))
- (cons `(scheme#cons ',(caar sd) ,(strip-syntax (cdar sd)))
- (loop (cdr sd)))))))))))))
+ sexports))
+ (scheme#list ; sdefs
+ ,@(if (null? sexports)
+ '() ; no syntax exported - no more info needed
+ (let loop ((sd (module-defined-syntax-list mod)))
+ (cond ((null? sd) '())
+ ((assq (caar sd) sexports) (loop (cdr sd)))
+ (else
+ (let ((name (caar sd)))
+ (cons `(scheme#cons ',(caar sd) ,(strip-syntax (cdar sd)))
+ (loop (cdr sd)))))))))))))))
;; iexports = indirect exports (syntax dependencies on value idents, explicitly included in module export list)
;; vexports = value (non-syntax) exports
@@ -561,19 +563,24 @@
;;; Import-expansion
+(define (##sys#with-environment thunk)
+ (parameterize ((##sys#current-module #f)
+ (##sys#current-environment '())
+ (##sys#current-meta-environment
+ (##sys#current-meta-environment))
+ (##sys#macro-environment
+ (##sys#meta-macro-environment)))
+ (thunk)))
+
(define (##sys#import-library-hook mname)
(and-let* ((il (chicken.load#find-dynamic-extension
(string-append (symbol->string mname) ".import")
#t)))
- (parameterize ((##sys#current-module #f)
- (##sys#current-environment '())
- (##sys#current-meta-environment
- (##sys#current-meta-environment))
- (##sys#macro-environment
- (##sys#meta-macro-environment)))
- (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
- (load il)
- (##sys#find-module mname 'import)))))
+ (##sys#with-environment
+ (lambda ()
+ (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
+ (load il)
+ (##sys#find-module mname 'import))))))
(define (find-module/import-library lib loc)
(let ((mname (##sys#resolve-module-name lib loc)))
Trap