From: Guillermo J. Rozas Date: Tue, 3 Apr 1990 04:51:16 +0000 (+0000) Subject: Make top level declarations propagate when compile-by-procedures is X-Git-Tag: 20090517-FFI~11467 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=79ba8231f51f2e1a5f3c251033e0c79f50d7f869;p=mit-scheme.git 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 ef5f2abe3..9eb27cf59 100644 --- 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*))) -(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 225e9e03e..2921da7ac 100644 --- 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))))))) ;;;; Hairier expressions diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index 94de27973..34f08dac3 100644 --- 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)) @@ -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