From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 12 Oct 2007 01:08:03 +0000 (+0000)
Subject: Implement CURRENT-LOAD-ENVIRONMENT.
X-Git-Tag: 20090517-FFI~425
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=40d38f1c0b8ca6a0b56904def02ffe05fbb4fc2d;p=mit-scheme.git

Implement CURRENT-LOAD-ENVIRONMENT.
---

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 6c06995ae..8b0d420b2 100644
--- 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 35a02383e..a20dc8430 100644
--- 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 48ed51d0b..134c1874e 100644
--- 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)