Make top level declarations propagate when compile-by-procedures is

turned on.

diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm
index ef5f2abe366bdf11575e979370f1af3e1071927a..9eb27cf59926913ba1d36959d8c1d8e92034a05b 100644 (file)
--- a/v7/src/compiler/base/toplev.scm
+++ b/v7/src/compiler/base/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.26 1990/03/26 23:45:38 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.27 1990/04/03 04:50:30 jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -210,7 +210,7 @@ MIT in each case. |#
      (phase/link)
      *result*)))
 \f
-(define (compile-recursively scode procedure-result?)
+(define (compile-recursively scode procedure-result? procedure-name)
   ;; Used by the compiler when it wants to compile subexpressions as
   ;; separate code-blocks.
   ;; The rtl output should be fixed.
@@ -250,7 +250,7 @@ MIT in each case. |#
                          (compiler-phase/visible
                           (string-append
                            "Compiling procedure: "
-                           (write-to-string (lambda-name scode)))
+                           (write-to-string procedure-name))
                           do-it))
                        do-it))
                  (lambda ()

diff --git a/v7/src/compiler/fggen/canon.scm b/v7/src/compiler/fggen/canon.scm
index 225e9e03e3800a5f381d3f5b8a6890f4fffdd5ac..2921da7acacf565fb74f2264c1e137356abb4a21 100644 (file)
--- a/v7/src/compiler/fggen/canon.scm
+++ b/v7/src/compiler/fggen/canon.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.7 1989/09/13 20:44:17 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.8 1990/04/03 04:50:50 jinx Rel $
 
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; Scode canonicalization.
+;;; package: (compiler fg-generator)
 
 ;;; canonicalize/top-level translates scode expressions into
 ;;; equivalent scode expressions where all implicit first class
@@ -97,21 +98,24 @@ ARBITRARY:  The expression may be executed more than once.  It
   needs?                               ; requires environment binding
   splice?)                             ; top level can be moved
 
+(define *top-level-declarations*)
+
 (define (canonicalize/top-level expression)
   (if (eq? compiler:package-optimization-level 'NONE)
       expression
-      (let ((result
-            (canonicalize/expression
-             expression '()
-             (if (and compiler:cache-free-variables?
-                      (not (eq? compiler:package-optimization-level 'LOW)))
-                 'TOP-LEVEL
-                 'FIRST-CLASS))))
-       (if (canout-needs? result)
-           (canonicalize/bind-environment (canout-expr result)
-                                          (scode/make-the-environment)
-                                          expression)
-           (canout-expr result)))))
+      (fluid-let ((*top-level-declarations* '()))
+       (let ((result
+              (canonicalize/expression
+               expression '()
+               (if (and compiler:cache-free-variables?
+                        (not (eq? compiler:package-optimization-level 'LOW)))
+                   'TOP-LEVEL
+                   'FIRST-CLASS))))
+         (if (canout-needs? result)
+             (canonicalize/bind-environment (canout-expr result)
+                                            (scode/make-the-environment)
+                                            expression)
+             (canout-expr result))))))
 
 (define (canonicalize/optimization-low? context)
   (or (eq? context 'FIRST-CLASS)
@@ -331,7 +335,9 @@ ARBITRARY:  The expression may be executed more than once.  It
             compiler:compile-by-procedures?)
        (make-canout
         (scode/make-directive
-         (canout-expr canout)
+         (if (null? *top-level-declarations*)
+             (canout-expr canout)
+             (make-open-block '() *top-level-declarations* (canout-expr canout)))
          '(COMPILE-PROCEDURE)
          expr)
         true
@@ -359,10 +365,12 @@ ARBITRARY:        The expression may be executed more than once.  It
         (scode/open-block-components
          expr
          (lambda (names decls body)
-           (canonicalize/expression
-            (unscan-defines names decls body)
-            bound
-            context))))))
+           (fluid-let ((*top-level-declarations*
+                        (append decls *top-level-declarations*)))
+             (canonicalize/expression
+              (unscan-defines names decls body)
+              bound
+              context)))))))
 \f
 ;;;; Hairier expressions
 

diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm
index 94de27973ff39c1821f81d73270c4a87ec592bf3..34f08dac3c2196d6afd70517d92a1538098e01c1 100644 (file)
--- a/v7/src/compiler/fggen/fggen.scm
+++ b/v7/src/compiler/fggen/fggen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.24 1990/02/02 18:38:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.25 1990/04/03 04:51:16 jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; Flow Graph Generation
+;;; package: (compiler fg-generator)
 
 (declare (usual-integrations))
 \f
@@ -745,15 +746,32 @@ MIT in each case. |#
             (make-constant
              (compile-recursively
               (scode/quotation-expression expression)
+              false
               false))))
           ((COMPILE-PROCEDURE)
-           (if (not (scode/lambda? expression))
-               (error "Bad compile-procedure directive" comment))
-           (if compiler:compile-by-procedures?
-               (continue/rvalue-constant
-                block continuation
-                (make-constant (compile-recursively expression true)))
-               (generate/expression block continuation expression)))
+           (let ((process
+                  (lambda (name)
+                    (if compiler:compile-by-procedures?
+                        (continue/rvalue-constant
+                         block continuation
+                         (make-constant
+                          (compile-recursively expression true name)))
+                        (generate/expression block continuation expression))))
+                 (fail
+                  (lambda ()
+                    (error "Bad compile-procedure directive" comment))))
+             (cond ((scode/lambda? expression)
+                    (process (lambda-name expression)))
+                   ((scode/open-block? expression)
+                    (scode/open-block-components
+                     expression
+                     (lambda (names decls body)
+                       decls           ; ignored
+                       (if (and (null? names) (scode/lambda? body))
+                           (process (lambda-name body))
+                           (fail)))))
+                   (else
+                    (fail)))))
           ((ENCLOSE)
            (generate/enclose block continuation expression))
           (else