diff options
-rw-r--r-- | libguile/load.c | 6 | ||||
-rw-r--r-- | module/system/base/compile.scm | 26 | ||||
-rw-r--r-- | module/system/repl/common.scm | 5 | ||||
-rw-r--r-- | test-suite/tests/bytevectors.test | 5 | ||||
-rw-r--r-- | test-suite/tests/compiler.test | 31 |
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))))) |