From: jrm <jmarshall@alum.mit.edu>
Date: Tue, 9 Feb 2010 15:56:51 +0000 (-0800)
Subject: Add SF:DISPLAY-TOP-LEVEL-PROCEDURE-NAMES?
X-Git-Tag: 20100708-Gtk~168^2~25
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3181395bdb0a2d766af0e9df60529f7744a91542;p=mit-scheme.git

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

diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index 6d1a460e3..ca1e19b50 100644
--- 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 5d018e6a6..70ff16421 100644
--- 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.
 
 (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