From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Wed, 10 Feb 2010 21:22:02 +0000 (-0800)
Subject: Use notifications for noise.
X-Git-Tag: 20100708-Gtk~168^2~7
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=75658de1096d4be5cd68cff6d43a3447095ee00a;p=mit-scheme.git

Use notifications for noise.
---

diff --git a/src/sf/object.scm b/src/sf/object.scm
index c6e0c7fab..85ada7a0d 100644
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -273,7 +273,7 @@ USA.
 
 (define (combination/make expression block operator operands)
   (cond ((and (foldable-combination? operator operands)
-	      (noisy-test sf:enable-constant-folding? "fold constants"))
+	      (noisy-test sf:enable-constant-folding? "Folding constants"))
 	 (combination/fold-constant expression
 				    (constant/value operator)
 				    (map constant/value operands)))
@@ -333,18 +333,16 @@ USA.
 	 (combination/%make (and expression (object/scode expression)) block operator operands))))
 
 (define (combination/fold-constant expression operator operands)
-  (if (not (eq? sf:enable-constant-folding? #t))
-      (begin
-	(newline)
-	(display "; Folding (")
-	(display operator)
-	(for-each (lambda (operand) (display " ") (write operand)) operands)))
   (let ((result (apply operator operands)))
-    (if (not (eq? sf:enable-constant-folding? #t))
-	(begin
-	  (display ") => ")
-	  (write result)))
-    (constant/make (and expression (object/scode expression)) result)))
+  (if (not (eq? sf:enable-constant-folding? #t))
+      (with-notification
+       (lambda (port)
+	 (display "Folding (" port)
+	 (display operator port)
+	 (for-each (lambda (operand) (display " " port) (write operand port)) operands)
+	 (display ") => " port)
+	 (write result port))))
+  (constant/make (and expression (object/scode expression)) result)))
 
 (define-integrable (partition-operands operator operands)
   (let ((free-in-body (free/expression (procedure/body operator))))
@@ -597,8 +595,7 @@ USA.
 	      (warn "Not performing possible action:" text)
 	      #f)
 	     ((not (eq? switch #t))
-	      (newline)
-	      (write-string "; ")
-	      (write-string text)
+	      (with-notification
+	       (lambda (port) (write-string text port)))
 	      #t)
 	     (else #t))))
diff --git a/src/sf/subst.scm b/src/sf/subst.scm
index 80eae5148..68ad5bbb6 100644
--- a/src/sf/subst.scm
+++ b/src/sf/subst.scm
@@ -232,13 +232,15 @@ USA.
 ;;; processed.  Useful for debugging.
 (define sf:display-top-level-procedure-names? #f)
 
-(define (maybe-display-name name)
+(define (maybe-displaying-name name thunk)
   (if (and sf:display-top-level-procedure-names?
 	   (null? *current-block-names*))
-      (begin
-	(newline)
-	(display ";;   ")
-	(display name))))
+      (with-notification
+       (lambda (port)
+	 (write-string "Integrating procedure " port)
+	 (write name port))
+       thunk)
+      (thunk)))
 
 (define (integrate/procedure operations environment procedure)
   (let ((block (procedure/block procedure))
@@ -246,36 +248,37 @@ USA.
 	(required (procedure/required procedure))
 	(optional (procedure/optional procedure))
 	(rest (procedure/rest procedure)))
-    (maybe-display-name name)
-    (fluid-let ((*current-block-names* (cons name *current-block-names*)))
-      (let ((body
-	     (integrate/expression
-	      (declarations/bind
-	       (operations/shadow
-		operations
-		(append required optional (if rest (list rest) '())))
-	       (block/declarations block))
-	      environment
-	      (procedure/body procedure))))
-	;; Possibly complain about variables bound and not
-	;; referenced.
-	(if (block/safe? block)
-	    (for-each (lambda (variable)
-			(if (variable/unreferenced? variable)
-			    (warn "Unreferenced bound variable:"
-				  (variable/name variable)
-				  *current-block-names*)))
-		      (if rest
-			  (append required optional (list rest))
-			  (append required optional))))
-	(procedure/make (procedure/scode procedure)
-			block
-			name
-			required
-			optional
-			rest
-			body)))))
-
+    (maybe-displaying-name
+     name
+     (lambda ()
+       (fluid-let ((*current-block-names* (cons name *current-block-names*)))
+	 (let ((body
+		(integrate/expression
+		 (declarations/bind
+		  (operations/shadow
+		   operations
+		   (append required optional (if rest (list rest) '())))
+		  (block/declarations block))
+		 environment
+		 (procedure/body procedure))))
+	   ;; Possibly complain about variables bound and not
+	   ;; referenced.
+	   (if (block/safe? block)
+	       (for-each (lambda (variable)
+			   (if (variable/unreferenced? variable)
+			       (warn "Unreferenced bound variable:"
+				     (variable/name variable)
+				     *current-block-names*)))
+			 (if rest
+			     (append required optional (list rest))
+			     (append required optional))))
+	   (procedure/make (procedure/scode procedure)
+			   block
+			   name
+			   required
+			   optional
+			   rest
+			   body)))))))
 
 (define-method/integrate 'COMBINATION
   (lambda (operations environment combination)