summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/load.c6
-rw-r--r--module/system/base/compile.scm26
-rw-r--r--module/system/repl/common.scm5
-rw-r--r--test-suite/tests/bytevectors.test5
-rw-r--r--test-suite/tests/compiler.test31
5 files changed, 56 insertions, 17 deletions
diff --git a/libguile/load.c b/libguile/load.c
index 246cf8977..10cbdb255 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -601,6 +601,8 @@ compiled_is_fresh (SCM full_filename, SCM compiled_filename)
return res;
}
+SCM_KEYWORD (kw_env, "env");
+
static SCM
do_try_autocompile (void *data)
{
@@ -617,7 +619,9 @@ do_try_autocompile (void *data)
if (scm_is_true (compile_file))
{
- SCM res = scm_call_1 (scm_variable_ref (compile_file), source);
+ /* Auto-compile in the context of the current module. */
+ SCM res = scm_call_3 (scm_variable_ref (compile_file), source,
+ kw_env, scm_current_module ());
scm_puts (";;; compiled ", scm_current_error_port ());
scm_display (res, scm_current_error_port ());
scm_newline (scm_current_error_port ());
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 26dd29e20..ea1e3f203 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -161,7 +161,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)))
;;;
@@ -190,6 +191,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))
@@ -199,7 +217,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)
@@ -228,7 +247,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/module/system/repl/common.scm b/module/system/repl/common.scm
index 2db4518ad..c9106e1ac 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -1,6 +1,6 @@
;;; Repl common routines
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 2009 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -68,7 +68,8 @@
((memq #:t opts) 'ghil)
((memq #:c opts) 'glil)
(else 'objcode)))))
- (compile form #:from (repl-language repl) #:to to #:opts opts)))
+ (compile form #:from (repl-language repl) #:to to #:opts opts
+ #:env (current-module))))
(define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl))))
diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test
index 1009fb051..26d7cf655 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 f9fabd7bc..2eb0e788f 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)))))