summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/ice-9/boot-9.scm5
-rw-r--r--module/language/objcode/spec.scm22
-rw-r--r--module/language/scheme/compile-tree-il.scm35
-rw-r--r--module/language/scheme/spec.scm17
-rw-r--r--module/language/tree-il/analyze.scm119
-rw-r--r--module/language/tree-il/compile-glil.scm4
-rw-r--r--module/language/tree-il/optimize.scm5
-rw-r--r--module/system/base/compile.scm41
-rw-r--r--module/system/base/language.scm12
-rw-r--r--module/system/repl/common.scm8
10 files changed, 104 insertions, 164 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 6060f9ff1..140a761e7 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2008,6 +2008,11 @@
;; Import the default set of bindings (from the SCM module) in MODULE.
(module-use! module the-scm-module)))
+(define (make-fresh-user-module)
+ (let ((m (make-module)))
+ (beautify-user-module! m)
+ m))
+
;; NOTE: This binding is used in libguile/modules.c.
;;
(define resolve-module
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index 42110271d..9837c5c1c 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -22,25 +22,17 @@
#:use-module (system base language)
#:use-module (system vm objcode)
#:use-module (system vm program)
- #:export (objcode make-objcode-env))
-
-(define (make-objcode-env module externals)
- (cons module externals))
-
-(define (objcode-env-module env)
- (if env (car env) (current-module)))
-
-(define (objcode-env-externals env)
- (and env (vector? (cdr env)) (cdr env)))
+ #:export (objcode))
(define (objcode->value x e opts)
- (let ((thunk (make-program x #f (objcode-env-externals e))))
- (if e
+ (let ((thunk (make-program x #f #f)))
+ (if (eq? e (current-module))
+ ;; save a cons in this case
+ (values (thunk) e e)
(save-module-excursion
(lambda ()
- (set-current-module (objcode-env-module e))
- (values (thunk) #f e)))
- (values (thunk) #f e))))
+ (set-current-module e)
+ (values (thunk) e e))))))
;; since locals are allocated on the stack and can have limited scope,
;; in many cases we use one local for more than one lexical variable. so
diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm
index 4ac33d77e..5d01a2651 100644
--- a/module/language/scheme/compile-tree-il.scm
+++ b/module/language/scheme/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile Scheme specification
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
@@ -24,40 +24,11 @@
;;; environment := #f
;;; | MODULE
-;;; | COMPILE-ENV
-;;; compile-env := (MODULE LEXICALS . EXTERNALS)
-(define (cenv-module env)
- (cond ((not env) #f)
- ((module? env) env)
- ((and (pair? env) (module? (car env))) (car env))
- (else (error "bad environment" env))))
-
-(define (cenv-lexicals env)
- (cond ((not env) '())
- ((module? env) '())
- ((pair? env) (cadr env))
- (else (error "bad environment" env))))
-
-(define (cenv-externals env)
- (cond ((not env) '())
- ((module? env) '())
- ((pair? env) (cddr env))
- (else (error "bad environment" env))))
-
-(define (make-cenv module lexicals externals)
- (cons module (cons lexicals externals)))
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- props))))
(define (compile-tree-il x e opts)
(save-module-excursion
(lambda ()
- (and=> (cenv-module e) set-current-module)
+ (set-current-module e)
(let* ((x (sc-expand x 'c '(compile load eval)))
- (cenv (make-cenv (current-module)
- (cenv-lexicals e) (cenv-externals e))))
+ (cenv (current-module)))
(values x cenv cenv)))))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index c05236126..6cfbc422f 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -41,11 +41,7 @@
#:reader (lambda (port env)
;; Use the binding of current-reader from the environment.
;; FIXME: Handle `read-options' as well?
- ((or (and=> (and=> (module-variable
- (cond ((pair? env) (car env))
- (env)
- (else (current-module)))
- 'current-reader)
+ ((or (and=> (and=> (module-variable env 'current-reader)
variable-ref)
fluid-ref)
read)
@@ -55,4 +51,13 @@
#:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
- )
+ #:make-default-environment
+ (lambda ()
+ ;; 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-fresh-user-module)))
+ ;; Provide a separate `current-reader' fluid so that
+ ;; compile-time changes to `current-reader' are
+ ;; limited to the current compilation unit.
+ (module-define! m 'current-reader (make-fluid))
+ m)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 46e467791..42ad74d7d 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -633,76 +633,67 @@
(defs toplevel-info-defs) ;; (VARIABLE-NAME ...)
(locs toplevel-info-locs)) ;; (LOCATION ...)
-(define (env-module e)
- "Return the module corresponding to E."
- ;; XXX: This is a bit of a hack since since representation of compile-time
- ;; environments is hidden in `(language scheme compile-tree-il)'.
- (cond ((pair? e) (car e))
- ((module? e) e)
- (else (current-module))))
-
;; TODO: Combine with `report-unused-variables' so we don't traverse the tree
;; once for each warning type.
(define (report-possibly-unbound-variables tree env)
"Return possibly unbound variables in TREE. Return TREE."
(define toplevel
- (let ((env (env-module env)))
- (tree-il-fold (lambda (x info)
- ;; X is a leaf: extend INFO's refs accordingly.
- (let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (locs (toplevel-info-locs info)))
- (define (bound? name)
- (or (and (module? env)
- (module-variable env name))
- (memq name defs)))
-
- (record-case x
- ((<toplevel-ref> name src)
- (if (bound? name)
- info
- (let ((src (or src (find pair? locs))))
- (make-toplevel-info (alist-cons name src refs)
- defs
- locs))))
- (else info))))
-
- (lambda (x info)
- ;; Going down into X.
- (let* ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (src (tree-il-src x))
- (locs (cons src (toplevel-info-locs info))))
- (define (bound? name)
- (or (and (module? env)
- (module-variable env name))
- (memq name defs)))
-
- (record-case x
- ((<toplevel-set> name src)
- (if (bound? name)
- (make-toplevel-info refs defs locs)
- (let ((src (find pair? locs)))
- (make-toplevel-info (alist-cons name src refs)
- defs
- locs))))
- ((<toplevel-define> name)
- (make-toplevel-info (alist-delete name refs eq?)
- (cons name defs)
- locs))
- (else
- (make-toplevel-info refs defs locs)))))
-
- (lambda (x info)
- ;; Leaving X's scope.
- (let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (locs (toplevel-info-locs info)))
- (make-toplevel-info refs defs (cdr locs))))
-
- (make-toplevel-info '() '() '())
- tree)))
+ (tree-il-fold (lambda (x info)
+ ;; X is a leaf: extend INFO's refs accordingly.
+ (let ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (locs (toplevel-info-locs info)))
+ (define (bound? name)
+ (or (and (module? env)
+ (module-variable env name))
+ (memq name defs)))
+
+ (record-case x
+ ((<toplevel-ref> name src)
+ (if (bound? name)
+ info
+ (let ((src (or src (find pair? locs))))
+ (make-toplevel-info (alist-cons name src refs)
+ defs
+ locs))))
+ (else info))))
+
+ (lambda (x info)
+ ;; Going down into X.
+ (let* ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (src (tree-il-src x))
+ (locs (cons src (toplevel-info-locs info))))
+ (define (bound? name)
+ (or (and (module? env)
+ (module-variable env name))
+ (memq name defs)))
+
+ (record-case x
+ ((<toplevel-set> name src)
+ (if (bound? name)
+ (make-toplevel-info refs defs locs)
+ (let ((src (find pair? locs)))
+ (make-toplevel-info (alist-cons name src refs)
+ defs
+ locs))))
+ ((<toplevel-define> name)
+ (make-toplevel-info (alist-delete name refs eq?)
+ (cons name defs)
+ locs))
+ (else
+ (make-toplevel-info refs defs locs)))))
+
+ (lambda (x info)
+ ;; Leaving X's scope.
+ (let ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (locs (toplevel-info-locs info)))
+ (make-toplevel-info refs defs (cdr locs))))
+
+ (make-toplevel-info '() '() '())
+ tree))
(for-each (lambda (name+loc)
(let ((name (car name+loc))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index e8b699eb5..4ab03bf25 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -65,10 +65,10 @@
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
- (with-fluid* *comp-module* (or (and e (car e)) (current-module))
+ (with-fluid* *comp-module* e
(lambda ()
(values (flatten-lambda x #f allocation)
- (and e (cons (car e) (cddr e)))
+ e
e)))))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 0e490a636..dbbc21655 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -25,11 +25,8 @@
#:use-module (language tree-il fix-letrec)
#:export (optimize!))
-(define (env-module e)
- (if e (car e) (current-module)))
-
(define (optimize! x env opts)
(inline!
(fix-letrec!
(expand-primitives!
- (resolve-primitives! x (env-module env))))))
+ (resolve-primitives! x env)))))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index a90f31ef2..4d1c92fd8 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -141,9 +141,9 @@
(define* (compile-file file #:key
(output-file #f)
- (env #f)
(from (current-language))
(to 'objcode)
+ (env (default-environment from))
(opts '()))
(let* ((comp (or output-file (compiled-file-name file)))
(in (open-input-file file))
@@ -159,10 +159,11 @@
file)
comp))
-(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
+(define* (compile-and-load file #:key (from 'scheme) (to 'value)
+ (env (current-module)) (opts '()))
(read-and-compile (open-input-file file)
#:from from #:to to #:opts opts
- #:env (current-module)))
+ #:env env))
;;;
@@ -191,33 +192,10 @@
(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)
-
- ;; Provide a separate `current-reader' fluid so that the Scheme language
- ;; reader doesn't get to see the REPL's settings for `current-reader',
- ;; which would lead to an infinite loop.
- (module-define! m 'current-reader (make-fluid))
-
- 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
(from (current-language))
(to 'objcode)
- (env (language-default-environment from))
+ (env (default-environment from))
(opts '()))
(let ((from (ensure-language from))
(to (ensure-language to)))
@@ -227,10 +205,11 @@
(let ((x ((language-reader (current-language)) port cenv)))
(cond
((eof-object? x)
- ;; FIXME: what if there are no expressions to be read?
- ;; then env is #f. Here default to cenv in that case.
(compile ((language-joiner joint) (reverse exps) env)
- #:from joint #:to to #:env (or env cenv) #:opts opts))
+ #:from joint #:to to
+ ;; env can be false if no expressions were read.
+ #:env (or env (default-environment joint))
+ #:opts opts))
(else
;; compile-fold instead of compile so we get the env too
(receive (jexp jenv jcenv)
@@ -241,7 +220,7 @@
(define* (compile x #:key
(from (current-language))
(to 'value)
- (env (language-default-environment from))
+ (env (default-environment from))
(opts '()))
(let ((warnings (memq #:warnings opts)))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 3670c53d9..046e11dbe 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -25,10 +25,10 @@
language-name language-title language-version language-reader
language-printer language-parser
language-compilers language-decompilers language-evaluator
- language-joiner
+ language-joiner language-make-default-environment
lookup-compilation-order lookup-decompilation-order
- invalidate-compilation-cache!))
+ invalidate-compilation-cache! default-environment))
;;;
@@ -45,7 +45,8 @@
(compilers '())
(decompilers '())
(evaluator #f)
- (joiner #f))
+ (joiner #f)
+ (make-default-environment make-fresh-user-module))
(define-macro (define-language name . spec)
`(begin
@@ -97,3 +98,8 @@
reverse!)))
(set! *decompilation-cache* (acons key order *decompilation-cache*))
order))))
+
+(define (default-environment lang)
+ "Return the default compilation environment for source language LANG."
+ ((language-make-default-environment
+ (if (language? lang) lang (lookup-language lang)))))
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 8ea1c0bf6..ba18e2ea0 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -70,13 +70,7 @@
((memq #:c opts) 'glil)
(else 'objcode))))
(from (repl-language repl)))
- (compile form #:from from #:to to #:opts opts
- ;; XXX: Languages other than Scheme may not support having
- ;; a module as the environment, so work around that. See
- ;; also `language-default-environment'.
- #:env (if (eq? from (lookup-language 'scheme))
- (current-module)
- #f))))
+ (compile form #:from from #:to to #:opts opts #:env (current-module))))
(define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl))))