Change WITH-NOTIFICATION so that the port it passes to the MESSAGE is

smart about newlines and writes the prefix correctly.  Also, make the
THUNK optional, and consequently WRITE-NOTIFICATION-LINE is an alias
for WITH-NOTIFICATION.

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 737aa93b5dbc3981dd7186911b51b139d864c215..3981a694673d5087024c61a6662a892d93da9392 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.112 2008/01/30 20:02:32 cph Exp $
+$Id: make.scm,v 14.113 2008/02/02 05:35:30 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -481,6 +481,7 @@ USA.
    (RUNTIME STRING-INPUT)
    (RUNTIME STRING-OUTPUT)
    (RUNTIME TRUNCATED-STRING-OUTPUT)
+   (RUNTIME USER-INTERFACE)
    ;; These MUST be done before (RUNTIME PATHNAME) 
    ;; Typically only one of them is loaded.
    (RUNTIME PATHNAME UNIX)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 41d11566249fef46f57de7eb058099c2cb52d9c0..9367d1f3fa70e3f4d5f1131c674cccc809bb068f 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.636 2008/02/02 04:28:45 cph Exp $
+$Id: runtime.pkg,v 14.637 2008/02/02 05:35:32 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -4312,7 +4312,8 @@ USA.
          port/gc-start)
   (export (runtime emacs-interface)
          port/read-finish
-         port/read-start))
+         port/read-start)
+  (initialization (initialize-package!)))
 
 (define-package (runtime thread)
   (files "thread")

diff --git a/v7/src/runtime/usrint.scm b/v7/src/runtime/usrint.scm
index 632d588b23090e4700b67f6ad73e43e5003c79af..337c74065f0ecf9c7091adcd7ec32f95c96cb6a7 100644 (file)
--- a/v7/src/runtime/usrint.scm
+++ b/v7/src/runtime/usrint.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usrint.scm,v 1.28 2008/01/30 20:02:37 cph Exp $
+$Id: usrint.scm,v 1.29 2008/02/02 05:35:33 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -292,46 +292,102 @@ USA.
 \f
 ;;;; Activity notification
 
-(define *notification-depth* 0)
-
-(define (with-notification message thunk)
-  (let ((port (notification-output-port))
-       (done? #f)
-       (n))
-    (dynamic-wind
-     (lambda ()
-       (start-notification-line)
-       (message port)
-       (write-string "... " port)
-       (set! n (output-port/bytes-written port))
-       unspecific)
-     (lambda ()
-       (let ((v
-             (fluid-let ((*notification-depth* (+ *notification-depth* 1)))
-               (thunk))))
-        (set! done? #t)
-        v))
-     (lambda ()
-       (if done?
-          (begin
-            (if (if n
-                    (> (output-port/bytes-written port) n)
-                    (output-port/line-start? port))
-                (begin
-                  (start-notification-line)
-                  (write-string "... " port)))
-            (set! n)
-            (write-string "done" port)
-            (newline port)))))))
-
-(define (write-notification-line message)
-  (start-notification-line)
-  (message (notification-output-port)))
-
-(define (start-notification-line)
+(define (with-notification message #!optional thunk)
+  (if (or (default-object? thunk) (not thunk))
+      (message (wrapped-notification-port))
+      (let ((done? #f)
+           (port)
+           (n))
+       (dynamic-wind
+        (lambda ()
+          (set! port (wrapped-notification-port))
+          (message port)
+          (write-string "... " port)
+          (set! n (output-port/bytes-written port))
+          unspecific)
+        (lambda ()
+          (let ((v
+                 (fluid-let ((*notification-depth*
+                              (+ *notification-depth* 1)))
+                   (thunk))))
+            (set! done? #t)
+            v))
+        (lambda ()
+          (if done?
+              (begin
+                (if (if n
+                        (> (output-port/bytes-written port) n)
+                        (output-port/line-start? port))
+                    (begin
+                      (newline port)
+                      (write-string "... " port)))
+                (write-string "done" port)
+                (newline port)))
+          (set! port)
+          (set! n)
+          unspecific)))))
+
+(define (wrapped-notification-port)
   (let ((port (notification-output-port)))
     (fresh-line port)
-    (write-string ";" port)
-    (do ((i 0 (+ i 1)))
-       ((not (< i *notification-depth*)))
-      (write-string "  " port))))
\ No newline at end of file
+    (write-notification-prefix port)
+    (make-port wrapped-notification-port-type port)))
+\f
+(define (make-wrapped-notification-port-type)
+  (make-port-type `((WRITE-CHAR ,operation/write-char)
+                   (X-SIZE ,operation/x-size)
+                   (COLUMN ,operation/column)
+                   (BYTES-WRITTEN ,operation/bytes-written))
+                 #f))
+
+(define (operation/write-char port char)
+  (let ((port* (port/state port)))
+    (let ((n (output-port/write-char port* char)))
+      (if (char=? char #\newline)
+         (write-notification-prefix port*))
+      n)))
+
+(define (operation/x-size port)
+  (let ((port* (port/state port)))
+    (let ((op (port/operation port* 'X-SIZE)))
+      (and op
+          (let ((n (op port*)))
+            (and n
+                 (max (- n (notification-prefix-length))
+                      0)))))))
+
+(define (operation/column port)
+  (let ((port* (port/state port)))
+    (let ((op (port/operation port* 'COLUMN)))
+      (and op
+          (let ((n (op port*)))
+            (and n
+                 (max (- n (notification-prefix-length))
+                      0)))))))
+
+(define (operation/bytes-written port)
+  (let ((port* (port/state port)))
+    (let ((op (port/operation port* 'BYTES-WRITTEN)))
+      (and op
+          (op port*)))))
+
+(define (write-notification-prefix port)
+  (write-string ";" port)
+  (do ((i 0 (+ i 1)))
+      ((not (< i *notification-depth*)))
+    (write-string indentation-atom port)))
+
+(define (notification-prefix-length)
+  (+ 1
+     (* (string-length indentation-atom)
+       *notification-depth*)))
+
+(define *notification-depth*)
+(define indentation-atom)
+(define wrapped-notification-port-type)
+
+(define (initialize-package!)
+  (set! *notification-depth* 0)
+  (set! indentation-atom "  ")
+  (set! wrapped-notification-port-type (make-wrapped-notification-port-type))
+  unspecific)
\ No newline at end of file