From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 7 Dec 2002 21:37:07 +0000 (+0000)
Subject: Implement MAKE-TOP-LEVEL-ENVIRONMENT.
X-Git-Tag: 20090517-FFI~2117
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ca43155d4c010e11693147d9deec44c8bd464c52;p=mit-scheme.git

Implement MAKE-TOP-LEVEL-ENVIRONMENT.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 661422398..44349dfb3 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.415 2002/11/20 19:46:22 cph Exp $
+$Id: runtime.pkg,v 14.416 2002/12/07 21:37:07 cph Exp $
 
 Copyright (c) 1988-2002 Massachusetts Institute of Technology
 
@@ -1331,6 +1331,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  interpreter-environment?
 	  (make-null-interpreter-environment make-root-top-level-environment)
 	  make-root-top-level-environment
+	  make-top-level-environment
 	  system-global-environment?
 	  (top-level-environment? interpreter-environment?))
   (export (runtime advice)
diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm
index 35086b043..0099cb38a 100644
--- a/v7/src/runtime/uenvir.scm
+++ b/v7/src/runtime/uenvir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uenvir.scm,v 14.58 2002/11/20 19:46:23 cph Exp $
+$Id: uenvir.scm,v 14.59 2002/12/07 21:36:44 cph Exp $
 
 Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -417,18 +417,24 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (extend-top-level-environment environment #!optional names values)
   (if (not (interpreter-environment? environment))
       (illegal-environment environment 'EXTEND-TOP-LEVEL-ENVIRONMENT))
-  (%extend-top-level-environment
-   environment
-   (if (default-object? names) '() names)
-   (if (default-object? values) 'DEFAULT values)
-   'EXTEND-TOP-LEVEL-ENVIRONMENT))
+  (%extend-top-level-environment environment
+				 (if (default-object? names) '() names)
+				 (if (default-object? values) 'DEFAULT values)
+				 'EXTEND-TOP-LEVEL-ENVIRONMENT))
+
+(define (make-top-level-environment #!optional names values)
+  (%extend-top-level-environment system-global-environment
+				 (if (default-object? names) '() names)
+				 (if (default-object? values) 'DEFAULT values)
+				 'MAKE-TOP-LEVEL-ENVIRONMENT))
 
 (define (make-root-top-level-environment #!optional names values)
-  (%extend-top-level-environment
-   (object-new-type (object-type #f) (fix:xor (object-datum #f) 1))
-   (if (default-object? names) '() names)
-   (if (default-object? values) 'DEFAULT values)
-   'MAKE-ROOT-TOP-LEVEL-ENVIRONMENT))
+  (%extend-top-level-environment (object-new-type (object-type #f)
+						  (fix:xor (object-datum #f)
+							   1))
+				 (if (default-object? names) '() names)
+				 (if (default-object? values) 'DEFAULT values)
+				 'MAKE-ROOT-TOP-LEVEL-ENVIRONMENT))
 
 (define (%extend-top-level-environment environment names values procedure)
   (if (not (list-of-type? names symbol?))