From 8879fa894377fc062f30358eb428c5ec757c43ab Mon Sep 17 00:00:00 2001
From: =?utf-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 14 Aug 2009 19:30:14 +0200
Subject: [PATCH 1/2] Compile in a fresh module by default.

* module/system/base/compile.scm (make-compilation-module,
  language-default-environment): New procedures.
  (read-and-compile, compile): Have ENV default to
  `(language-default-environment from)'.
  (compile-and-load): Compile in `(current-module)'.

* test-suite/tests/compiler.test ("psyntax")["compile uses a fresh module by
  default", "compile-time definitions are isolated"]: New tests.
  ["compile in current module"]: Specify `#:env (current-module)'.
  ["redefinition"]: Adjust.

* test-suite/tests/bytevectors.test (c&e): Explicitly compile in the
  current module so that its imports are visible.
---
 module/system/base/compile.scm    |   26 +++++++++++++++++++++++---
 test-suite/tests/bytevectors.test |    5 +++--
 test-suite/tests/compiler.test    |   31 ++++++++++++++++++++++---------
 3 files changed, 48 insertions(+), 14 deletions(-)

diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 8470f39..f3557cb 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -158,7 +158,8 @@
 
 (define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
   (read-and-compile (open-input-file file)
-                    #:from from #:to to #:opts opts))
+                    #:from from #:to to #:opts opts
+                    #:env (current-module)))
 
 
 ;;;
@@ -187,6 +188,23 @@
           (else
            (lp (cdr in) (caar in))))))
 
+(define (make-compilation-module)
+  "Return a fresh module to be used as the compilation environment."
+
+  ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
+  ;; `fluid-set!', etc. don't have any effect in the current environment.
+
+  (let ((m (make-module)))
+    (beautify-user-module! m)
+    m))
+
+(define (language-default-environment lang)
+  "Return the default compilation environment for source language LANG."
+  (if (or (eq? lang 'scheme)
+          (eq? lang (lookup-language 'scheme)))
+      (make-compilation-module)
+      #f))
+
 (define* (read-and-compile port #:key
                            (env #f)
                            (from (current-language))
@@ -196,7 +214,8 @@
         (to (ensure-language to)))
     (let ((joint (find-language-joint from to)))
       (with-fluids ((*current-language* from))
-        (let lp ((exps '()) (env #f) (cenv env))
+        (let lp ((exps '()) (env #f)
+                 (cenv (or env (language-default-environment from))))
           (let ((x ((language-reader (current-language)) port)))
             (cond
              ((eof-object? x)
@@ -225,7 +244,8 @@
                     warnings))))
 
   (receive (exp env cenv)
-      (compile-fold (compile-passes from to opts) x env opts)
+      (let ((env (or env (language-default-environment from))))
+        (compile-fold (compile-passes from to opts) x env opts))
     exp))
 
 
diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test
index 8b336bb..c0f5196 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -31,12 +31,13 @@
      (begin (pass-if (string-append test-name " (eval)")
                      (primitive-eval 'exp))
             (pass-if (string-append test-name " (compile)")
-                     (compile 'exp #:to 'value))))
+                     (compile 'exp #:to 'value #:env (current-module)))))
     ((_ (pass-if-exception test-name exc exp))
      (begin (pass-if-exception (string-append test-name " (eval)")
                                exc (primitive-eval 'exp))
             (pass-if-exception (string-append test-name " (compile)")
-                               exc (compile 'exp #:to 'value))))))
+                               exc (compile 'exp #:to 'value
+                                            #:env (current-module)))))))
 
 (define-syntax with-test-prefix/c&e
   (syntax-rules ()
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index f9fabd7..2eb0e78 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -30,18 +30,23 @@
 
 (with-test-prefix "psyntax"
 
-  (pass-if "redefinition"
-    ;; In this case the locally-bound `round' must have the same value as the
-    ;; imported `round'.  See the same test in `syntax.test' for details.
+  (pass-if "compile uses a fresh module by default"
+    (begin
+      (compile '(define + -))
+      (eq? (compile '+) +)))
+
+  (pass-if "compile-time definitions are isolated"
     (begin
-      (compile '(define round round))
-      (compile '(eq? round (@@ (guile) round)))))
+      (compile '(define foo-bar #t))
+      (not (module-variable (current-module) 'foo-bar))))
 
   (pass-if "compile in current module"
     (let ((o (begin
-               (compile '(define-macro (foo) 'bar))
-               (compile '(let ((bar 'ok)) (foo))))))
-      (and (module-ref (current-module) 'foo)
+               (compile '(define-macro (foo) 'bar)
+                        #:env (current-module))
+               (compile '(let ((bar 'ok)) (foo))
+                        #:env (current-module)))))
+      (and (macro? (module-ref (current-module) 'foo))
            (eq? o 'ok))))
 
   (pass-if "compile in fresh module"
@@ -52,4 +57,12 @@
                  (compile '(define-macro (foo) 'bar) #:env m)
                  (compile '(let ((bar 'ok)) (foo)) #:env m))))
       (and (module-ref m 'foo)
-           (eq? o 'ok)))))
+           (eq? o 'ok))))
+
+  (pass-if "redefinition"
+    ;; In this case the locally-bound `round' must have the same value as the
+    ;; imported `round'.  See the same test in `syntax.test' for details.
+    (let ((m (make-module)))
+      (beautify-user-module! m)
+      (compile '(define round round) #:env m)
+      (eq? round (module-ref m 'round)))))
-- 
1.6.1.3