Implement WITH-NOTIFICATION to provide more uniform handling of status

notifications, such as "Loading" messages from LOAD.

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index 12d1dcefbe6a50781e598b7ce1060998951a3702..e0eb3a1c7d9a779bbc247db9610f40bd97a3b9f0 100644 (file)
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: global.scm,v 14.74 2006/09/15 01:20:04 cph Exp $
+$Id: global.scm,v 14.75 2006/10/25 04:25:17 cph Exp $
 
 Copyright 1988,1989,1991,1992,1993,1995 Massachusetts Institute of Technology
 Copyright 1998,2000,2001,2003,2004,2006 Massachusetts Institute of Technology
@@ -341,37 +341,27 @@ USA.
       ((ucode-primitive primitive-impurify) object))
   object)
 
-(define (fasdump object filename
-                #!optional suppress-messages? dump-option)
-  (let* ((filename (->namestring (merge-pathnames filename)))
-        (do-it
-         (lambda (start-message end-message)
-           (start-message)
-           (let loop ()
-             (if ((ucode-primitive primitive-fasdump)
-                  object filename
-                  (if (default-object? dump-option)
-                      #f
-                      dump-option))
-                 (end-message)
-                 (begin
-                   (with-simple-restart 'RETRY "Try again."
-                     (lambda ()
-                       (error "FASDUMP: Object is too large to be dumped:"
-                              object)))
-                   (loop))))))
-        (no-print (lambda () unspecific)))
-    (if (or (default-object? suppress-messages?)
-           (not suppress-messages?))
-       (let ((port (notification-output-port)))
-         (do-it (lambda ()
-                  (fresh-line port)
-                  (write-string ";Dumping " port)
-                  (write (enough-namestring filename) port))
-                (lambda ()
-                  (write-string " -- done" port)
-                  (newline port))))
-       (do-it no-print no-print))))
+(define (fasdump object filename #!optional quiet? dump-option)
+  (let ((filename (->namestring (merge-pathnames filename)))
+       (quiet? (if (default-object? quiet?) #f quiet?))
+       (dump-option (if (default-object? dump-option) #f dump-option)))
+    (let ((do-it
+          (lambda ()
+            (let loop ()
+              (if (not ((ucode-primitive primitive-fasdump)
+                        object filename dump-option))
+                  (begin
+                    (with-simple-restart 'RETRY "Try again."
+                      (lambda ()
+                        (error "FASDUMP: Object is too large to be dumped:"
+                               object)))
+                    (loop)))))))
+    (if quiet?
+       (do-it)
+       (with-notification (lambda (port)
+                            (write-string "Dumping " port)
+                            (write (enough-namestring filename) port))
+         do-it)))))
 \f
 ;;;; Hook lists
 

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 154e26624265cbb57c1bf17668ad0fa7bcba4de0..fe5a623e6b9c67e5f40f648f6b822fb62ef001df 100644 (file)
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.79 2006/10/16 06:23:45 savannah-arthur Exp $
+$Id: load.scm,v 14.80 2006/10/25 04:25:23 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology
@@ -375,14 +375,10 @@ USA.
 (define (loading-message suppress-loading-message? pathname do-it)
   (if suppress-loading-message?
       (do-it)
-      (let ((port (notification-output-port)))
-       (fresh-line port)
-       (write-string ";Loading " port)
-       (write (enough-namestring pathname) port)
-       (let ((value (do-it)))
-         (write-string " -- done" port)
-         (newline port)
-         value))))
+      (with-notification (lambda (port)
+                          (write-string "Loading " port)
+                          (write (enough-namestring pathname) port))
+       do-it)))
 
 (define *purification-root-marker*)
 

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 3651f35f66461eb0a1084596c98bf11d077dd3c8..8d486a7e4d097ec3b04f48c3ff38f2b72bb29efe 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.600 2006/10/25 03:15:29 cph Exp $
+$Id: runtime.pkg,v 14.601 2006/10/25 04:25:32 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -4269,7 +4269,8 @@ USA.
          prompt-for-command-expression
          prompt-for-confirmation
          prompt-for-evaluated-expression
-         prompt-for-expression)
+         prompt-for-expression
+         with-notification)
   (export (runtime rep)
          port/set-default-environment
          port/write-result)

diff --git a/v7/src/runtime/usrint.scm b/v7/src/runtime/usrint.scm
index 47e0eb28aaf685028eefde21c5dea18f229c9d0d..e4d87e813eb64fe2b2e3e690201bcdfd4715455d 100644 (file)
--- a/v7/src/runtime/usrint.scm
+++ b/v7/src/runtime/usrint.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: usrint.scm,v 1.21 2005/04/01 04:47:12 cph Exp $
+$Id: usrint.scm,v 1.22 2006/10/25 04:25:37 cph Exp $
 
 Copyright 1991,1992,1993,1994,1995,2001 Massachusetts Institute of Technology
-Copyright 2003,2005 Massachusetts Institute of Technology
+Copyright 2003,2005,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -190,7 +190,7 @@ USA.
                (write-string (cdr prompt) port))
              (write-string prompt port))
          (flush-output port)))))
-\f
+
 ;;;; Debugger Support
 
 (define (port/debugger-failure port message)
@@ -288,3 +288,40 @@ USA.
   (let ((operation (port/operation port 'READ-FINISH)))
     (if operation
        (operation port))))
+\f
+;;;; Activity notification
+
+(define *notification-depth* 0)
+
+(define (with-notification message thunk)
+  (let ((port (notification-output-port)))
+    (let ((prefix
+          (lambda ()
+            (fresh-line port)
+            (write-string ";" port)
+            (do ((i 0 (+ i 1)))
+                ((not (< i *notification-depth*)))
+              (write-string "  " port))
+            (message port)
+            (write-string "... " port))))
+      (prefix)
+      (let ((n (output-port/bytes-written port)))
+       (let ((p
+              (call-with-current-continuation
+               (lambda (k)
+                 (bind-condition-handler (list condition-type:error)
+                     (lambda (condition)
+                       (k (cons #f condition)))
+                   (lambda ()
+                     (fluid-let ((*notification-depth*
+                                  (+ *notification-depth* 1)))
+                       (cons #t (thunk)))))))))
+         (if (if n
+                 (> (output-port/bytes-written port) n)
+                 (output-port/line-start? port))
+             (prefix))
+         (write-string (if (car p) "done" "ERROR") port)
+         (newline port)
+         (if (car p)
+             (cdr p)
+             (signal-condition (cdr p))))))))
\ No newline at end of file