Implement MAKE-TOP-LEVEL-ENVIRONMENT.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 661422398f98b749742d30be5089895c22aa6fbf..44349dfb3133dc2f918af7db930453a05cbecdca 100644 (file)
--- 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 35086b0434006e688a23d3e5ee32d6e2abae45f8..0099cb38a4ef735fb2bcc5129b38d0e737d32d0b 100644 (file)
--- 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?))