Implement CURRENT-LOAD-ENVIRONMENT.

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 6c06995ae539c2b04aeaabbbe9ee365bccdd06a5..8b0d420b2dbe28629eae99ee0f2567b1e2b7328d 100644 (file)
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.97 2007/07/23 04:52:48 cph Exp $
+$Id: load.scm,v 14.98 2007/10/12 01:08:01 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -56,9 +56,7 @@ USA.
   syntax-table                         ;ignored
   (let ((environment
         (if (default-object? environment)
-            (if (eq? *current-load-environment* 'NONE)
-                (nearest-repl/environment)
-                *current-load-environment*)
+            (current-load-environment)
             (->environment environment)))
        (purify?
         (if (default-object? purify?)
@@ -265,6 +263,18 @@ USA.
   (or (uri->pathname (current-eval-unit) #f)
       (error condition-type:not-loading)))
 
+(define (current-load-environment)
+  (let ((env *current-load-environment*))
+    (if (eq? env 'NONE)
+       (nearest-repl/environment)
+       env)))
+
+(define (set-current-load-environment! env)
+  (if (not (eq? *current-load-environment* 'NONE))
+      (begin
+       (set! *current-load-environment* env)
+       unspecific)))
+
 (define (load/push-hook! hook)
   (if (not load/loading?) (error condition-type:not-loading))
   (set! load/after-load-hooks (cons hook load/after-load-hooks))

diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm
index 35a02383e81ed990a471e95ddac1c4b16b113c74..a20dc8430f1344b4f1313f710aa20b103edcdd8f 100644 (file)
--- a/v7/src/runtime/rep.scm
+++ b/v7/src/runtime/rep.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rep.scm,v 14.68 2007/01/05 21:19:28 cph Exp $
+$Id: rep.scm,v 14.69 2007/10/12 01:08:02 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -780,6 +780,7 @@ USA.
 (define (ge environment)
   (let ((environment (->environment environment 'GE)))
     (set-repl/environment! (nearest-repl) environment)
+    (set-current-load-environment! environment)
     environment))
 
 (define (->environment object #!optional caller)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 48ed51d0b50e85b7755e0578256a89caeb368fa0..134c1874e9ab7183cf71f414b2a0aebbd4e7771f 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.626 2007/09/12 23:35:01 cph Exp $
+$Id: runtime.pkg,v 14.627 2007/10/12 01:08:03 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -2411,6 +2411,7 @@ USA.
          built-in-object-file
          condition-type:not-loading
          current-eval-unit
+         current-load-environment
          current-load-pathname
          fasl-file?
          fasload
@@ -2429,6 +2430,8 @@ USA.
          system-uri
          with-eval-unit
          with-loader-base-uri)
+  (export (runtime rep)
+         set-current-load-environment!)
   (initialization (initialize-package!)))
 
 (define-package (runtime microcode-errors)