dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Compile in a fresh module by default.

Browse source 
* 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)'.

* module/system/repl/common.scm (repl-compile): Explicitly compile in
  the current module so that macro definitions are visible.

* libguile/load.c (kw_env): New variable.
  (do_try_autocompile): Call `compile-file' with `#:env (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.
This commit is contained in:
Ludovic Courtès 2009-08-14 19:30:14 +02:00
commit 87c595c757
5 changed files with 56 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

6
libguile/load.c
View file

@ -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 ());

26
module/system/base/compile.scm
View file

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

5
module/system/repl/common.scm
View file

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

5
test-suite/tests/bytevectors.test
View file

@ -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 ()

31
test-suite/tests/compiler.test
View file

@ -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 round round))
(compile '(eq? round (@@ (guile) round)))))
(compile '(define + -))
(eq? (compile '+) +)))
(pass-if "compile-time definitions are isolated"
(begin
(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)))))