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))) + (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 - (( 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)))) + (record-case x + (( 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))) + (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 - (( 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)))) - (( name) - (make-toplevel-info (alist-delete name refs eq?) - (cons name defs) - locs)) - (else - (make-toplevel-info refs defs locs))))) + (record-case x + (( 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)))) + (( 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)))) + (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))) + (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))))