From ca43155d4c010e11693147d9deec44c8bd464c52 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 7 Dec 2002 21:37:07 +0000 Subject: [PATCH] Implement MAKE-TOP-LEVEL-ENVIRONMENT. --- v7/src/runtime/runtime.pkg | 3 ++- v7/src/runtime/uenvir.scm | 28 +++++++++++++++++----------- 2 files changed, 19 insertions(+), 12 deletions(-) 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?)) -- 2.25.1