Add SF:DISPLAY-TOP-LEVEL-PROCEDURE-NAMES?

diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index 6d1a460e3c89361ff118842be5a2bc28edaf60b1..ca1e19b509ec6af4dc7b57d36f69a85b01f05298 100644 (file)
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -76,6 +76,8 @@ USA.
 (define-package (scode-optimizer integrate)
   (files "subst")
   (parent (scode-optimizer))
+  (export ()
+         sf:display-top-level-procedure-names?)
   (export (scode-optimizer)
          integrate/top-level
          integrate/get-top-level-block

diff --git a/src/sf/subst.scm b/src/sf/subst.scm
index 5d018e6a64c4b8c5de4a1eac8ad4622948fd13d3..70ff16421ba00054f2fea7976cc7e3cc406a98ba 100644 (file)
--- a/src/sf/subst.scm
+++ b/src/sf/subst.scm
@@ -341,6 +341,18 @@ USA.
                         (simulate-unknown-application environment procedure)
                         procedure)))
 
+;;; If not #f, display the top-level procedure names as they are
+;;; processed.  Useful for debugging.
+(define sf:display-top-level-procedure-names? #f)
+
+(define (maybe-display-name name)
+  (if (and sf:display-top-level-procedure-names?
+          (null? *current-block-names*))
+      (begin
+       (newline)
+       (display ";;   ")
+       (display name))))
+
 ;; Cannot optimize (lambda () (bar)) => bar (eta substitution) because
 ;; BAR may be a procedure with different arity than the lambda
 
@@ -371,12 +383,12 @@ you ask for.
 \f
 (define (integrate/procedure operations environment procedure)
   (let ((block (procedure/block procedure))
+       (name  (procedure/name procedure))
        (required (procedure/required procedure))
        (optional (procedure/optional procedure))
        (rest (procedure/rest procedure)))
-    (fluid-let ((*current-block-names*
-                (cons (procedure/name procedure)
-                      *current-block-names*)))
+    (maybe-display-name name)
+    (fluid-let ((*current-block-names* (cons name *current-block-names*)))
       (process-block-flags (block/flags block)
        (lambda ()
          (let ((body
@@ -412,7 +424,7 @@ you ask for.
                (combination/operator body)
                (procedure/make (procedure/scode procedure)
                                block
-                               (procedure/name procedure)
+                               name
                                required
                                optional
                                rest