Use notifications for noise.

diff --git a/src/sf/object.scm b/src/sf/object.scm
index c6e0c7fab7663c7e930cf16601633c0b03016d95..85ada7a0deaaf689d12fd9b1082c9ceae3517b8a 100644 (file)
--- 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 80eae51482b98d05de8d526dbd21ae5167089ddc..68ad5bbb6201f7cc92ec428c3d9049d1c2d08c2c 100644 (file)
--- 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)))
 \f
 (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)))))))
 \f
 (define-method/integrate 'COMBINATION
   (lambda (operations environment combination)