From eb958b904e9ae4d3430fa1f6026d463051870ad6 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 1 Aug 1988 23:10:12 +0000 Subject: [PATCH] Change `environment?' to be true of `system-global-environment'. Add new procedures `ic-environment?' and `system-global-environment?' to distinguish the interesting cases. --- v7/src/runtime/dbgutl.scm | 4 ++-- v7/src/runtime/debug.scm | 6 +++--- v7/src/runtime/rep.scm | 5 ++--- v7/src/runtime/runtime.pkg | 6 ++++-- v7/src/runtime/scode.scm | 4 ++-- v7/src/runtime/uenvir.scm | 17 +++++++++++++---- v7/src/runtime/where.scm | 20 +++++++------------- v8/src/runtime/dbgutl.scm | 4 ++-- v8/src/runtime/runtime.pkg | 6 ++++-- v8/src/runtime/uenvir.scm | 17 +++++++++++++---- 10 files changed, 52 insertions(+), 37 deletions(-) diff --git a/v7/src/runtime/dbgutl.scm b/v7/src/runtime/dbgutl.scm index 7fb8c4fb8..834ebd429 100644 --- a/v7/src/runtime/dbgutl.scm +++ b/v7/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.2 1988/06/13 11:43:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.3 1988/08/01 23:09:37 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -68,7 +68,7 @@ MIT in each case. |# (define rename-list) (define (show-frame frame depth) - (if (eq? system-global-environment frame) + (if (system-global-environment? frame) (begin (newline) (write-string "This frame is the system global environment")) diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 0c3359366..86573c634 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.3 1988/07/14 07:39:50 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.4 1988/08/01 23:08:34 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -227,7 +227,7 @@ MIT in each case. |# ;;; procedure name (write-string (string-pad-right - (if (or (not (environment? environment)) + (if (or (not (ic-environment? environment)) (special-name? (environment-name environment))) "" (write-to-truncated-string (environment-name environment) 20)) @@ -538,7 +538,7 @@ MIT in each case. |# (define (if-valid-environment environment receiver) (cond ((debugging-info/undefined-environment? environment) (print-undefined-environment)) - ((eq? environment system-global-environment) + ((system-global-environment? environment) (newline) (write-string "System global environment at this subproblem/reduction level")) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 161251c45..24cb5a822 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.4 1988/07/14 07:40:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.5 1988/08/01 23:09:21 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -448,8 +448,7 @@ MIT in each case. |# environment)) (define (->environment object) - (cond ((or (eq? object system-global-environment) - (environment? object)) + (cond ((environment? object) object) ((compound-procedure? object) (procedure-environment object)) ((promise? object) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index efe04245e..15d9e77fd 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.16 1988/07/19 20:42:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.17 1988/08/01 23:09:01 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -407,8 +407,10 @@ MIT in each case. |# environment-parent environment-procedure environment? + ic-environment? remove-environment-parent! - set-environment-parent!)) + set-environment-parent! + system-global-environment?)) (define-package (runtime environment-inspector) (files "where") diff --git a/v7/src/runtime/scode.scm b/v7/src/runtime/scode.scm index cf4fb7346..07cbb867b 100644 --- a/v7/src/runtime/scode.scm +++ b/v7/src/runtime/scode.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.2 1988/06/16 06:29:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.3 1988/08/01 23:10:12 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -281,7 +281,7 @@ MIT in each case. |# (define (absolute-reference? object) (and (access? object) - (eq? (access-environment object) system-global-environment))) + (system-global-environment? (access-environment object)))) (define-integrable (absolute-reference-name reference) (access-name reference)) diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index 0fae1fe3d..7f1fcf9cf 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.2 1988/06/13 11:58:33 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.3 1988/08/01 23:08:20 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -39,15 +39,24 @@ MIT in each case. |# ;;;; Environment -(define-integrable (environment? object) +(define (environment? object) + (if (system-global-environment? object) + true + (ic-environment? object))) + +(define-integrable (system-global-environment? object) + (eq? system-global-environment object)) + +(define-integrable (ic-environment? object) (object-type? (ucode-type environment) object)) (define (environment-procedure environment) (select-procedure (environment->external environment))) (define (environment-has-parent? environment) - (not (eq? (select-parent (environment->external environment)) - null-environment))) + (and (ic-environment? environment) + (not (eq? (select-parent (environment->external environment)) + null-environment)))) (define (environment-parent environment) (select-parent (environment->external environment))) diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm index a0fc7a2ab..e4a87b669 100644 --- a/v7/src/runtime/where.scm +++ b/v7/src/runtime/where.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.2 1988/07/14 07:41:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.3 1988/08/01 23:09:58 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -88,23 +88,17 @@ MIT in each case. |# (show-frame current-frame current-frame-depth)) (define (show-all) - (let s1 ((env env) - (depth 0)) - (if (eq? system-global-environment env) - *the-non-printing-object* + (let s1 ((env env) (depth 0)) + (if (not (system-global-environment? env)) (begin (show-frame env depth) (if (environment-has-parent? env) - (s1 (environment-parent env) (1+ depth)) - *the-non-printing-object*))))) - + (s1 (environment-parent env) (1+ depth)))))) + *the-non-printing-object*) + ;;;; Motion Commands (define (parent) - (cond ((eq? system-global-environment current-frame) - (newline) - (write-string -"The current frame is the system global environment, it has no parent.")) - ((environment-has-parent? current-frame) + (cond ((environment-has-parent? current-frame) (set! current-frame (environment-parent current-frame)) (set! current-frame-depth (1+ current-frame-depth)) (show)) diff --git a/v8/src/runtime/dbgutl.scm b/v8/src/runtime/dbgutl.scm index 46fd1478a..6c1b8fe0e 100644 --- a/v8/src/runtime/dbgutl.scm +++ b/v8/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.2 1988/06/13 11:43:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.3 1988/08/01 23:09:37 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -68,7 +68,7 @@ MIT in each case. |# (define rename-list) (define (show-frame frame depth) - (if (eq? system-global-environment frame) + (if (system-global-environment? frame) (begin (newline) (write-string "This frame is the system global environment")) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index dba3f9b88..c30126083 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.16 1988/07/19 20:42:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.17 1988/08/01 23:09:01 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -407,8 +407,10 @@ MIT in each case. |# environment-parent environment-procedure environment? + ic-environment? remove-environment-parent! - set-environment-parent!)) + set-environment-parent! + system-global-environment?)) (define-package (runtime environment-inspector) (files "where") diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index d7ff76c1a..10ea3895e 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.2 1988/06/13 11:58:33 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.3 1988/08/01 23:08:20 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -39,15 +39,24 @@ MIT in each case. |# ;;;; Environment -(define-integrable (environment? object) +(define (environment? object) + (if (system-global-environment? object) + true + (ic-environment? object))) + +(define-integrable (system-global-environment? object) + (eq? system-global-environment object)) + +(define-integrable (ic-environment? object) (object-type? (ucode-type environment) object)) (define (environment-procedure environment) (select-procedure (environment->external environment))) (define (environment-has-parent? environment) - (not (eq? (select-parent (environment->external environment)) - null-environment))) + (and (ic-environment? environment) + (not (eq? (select-parent (environment->external environment)) + null-environment)))) (define (environment-parent environment) (select-parent (environment->external environment))) -- 2.25.1