* Change `block' to `context' where needed.

* New abstractions support owning and disowning of block children.

diff --git a/v7/src/compiler/fgopt/envopt.scm b/v7/src/compiler/fgopt/envopt.scm
index 5868e3e8588476c736941e01af517de460d82dad..25a6be5f2092cb32d44732d4d8e8b0496b53ffc1 100644 (file)
--- a/v7/src/compiler/fgopt/envopt.scm
+++ b/v7/src/compiler/fgopt/envopt.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/envopt.scm,v 1.3 1988/12/06 18:56:41 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/envopt.scm,v 1.4 1988/12/13 13:03:50 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -165,43 +165,27 @@ MIT in each case. |#
             (enqueue-nodes! (procedure-free-callers procedure)))
            (else 'DONE)))))
 
-(define (application-is-call-to? application block)
-  (and (application/combination? application)
-       (let ((op (rvalue-known-value (application-operator application))))
-        (and op
-             (rvalue/procedure? op)
-             (eq? (application-block application) block)))))
-
 (define (choose-target-block! procedure)
   (let ((callers (procedure-free-callers procedure))
-       (closing-block (procedure-closing-block procedure)))
-    ;; The following conditional makes some cases of LET-like procedures
-    ;; track their parents in order to avoid closing over the same
-    ;; variables twice.
-    (if (or (not (null? callers))
-           (not (procedure-always-known-operator? procedure))
-           (not (for-all?
-                 (procedure-applications procedure)
-                 (lambda (app)
-                   (application-is-call-to? app closing-block)))))
-       (let ((target-block (procedure-target-block procedure)))
-         (if (and (not (eq? closing-block target-block))
-                  (block-ancestor? closing-block target-block))
-             (let ((myself (procedure-block procedure)))
-               (set-procedure-target-block! procedure closing-block)
-               (set-procedure-closing-block! procedure target-block)
-               (set-block-children!
-                closing-block
-                (delq! myself (block-children closing-block)))
-               (set-block-disowned-children!
-                closing-block
-                (cons myself (block-disowned-children closing-block)))
-               (set-block-children!
-                target-block
-                (cons myself (block-children target-block))))
-             (set-procedure-target-block! procedure closing-block)))
-       (set-procedure-target-block! procedure closing-block))
-    'DONE))
+       (parent (procedure-closing-block procedure))
+       (target-block (procedure-target-block procedure)))
+    ;; This now becomes `original-block-parent' of the procedure's
+    ;; invocation block.
+    (set-procedure-target-block! procedure parent)
+    (if (and
+        ;; The following clause makes some cases of LET-like
+        ;; procedures track their parents in order to avoid closing
+        ;; over the same variables twice.
+        (not (and (null? callers)
+                  (procedure-always-known-operator? procedure)
+                  (for-all? (procedure-applications procedure)
+                    (lambda (application)
+                      (eq? (application-block application) parent)))))
+        (block-ancestor? parent target-block))
+       (let ((myself (procedure-block procedure)))
+         (disown-block-child! parent myself)
+         (own-block-child! target-block myself)))
+    unspecific))
 \f
 ;;; Utilities