From 743be862e89375e46fa69b244d4dea4495fa5591 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Sun, 25 Aug 2019 15:13:57 +0200
Subject: [PATCH] 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
---
 modules.scm | 101 ++++++++++++++++++++++++++++++++----------------------------
 1 file changed, 54 insertions(+), 47 deletions(-)

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)))
-- 
2.11.0