Add MONITOR-WORLD Edwin command displaying an animated world-report.

diff --git a/src/edwin/decls.scm b/src/edwin/decls.scm
index acf41a14f1bd50df4f447f649cad774993ff290b..bbf5e70793c8b178ddfd2beae821924905aeb422 100644 (file)
--- a/src/edwin/decls.scm
+++ b/src/edwin/decls.scm
@@ -236,6 +236,7 @@ USA.
                "winout"
                "xcom"
                "win32com"
+               "world-monitor"
                "xmodef")))
   (for-each sf-class
            '("comwin"

diff --git a/src/edwin/edwin.ldr b/src/edwin/edwin.ldr
index 49d3a14932f696398fec48a5d1a550b1c4d4e4b4..dd4f32fcfc5b2e23df399a60ff461135757db876 100644 (file)
--- a/src/edwin/edwin.ldr
+++ b/src/edwin/edwin.ldr
@@ -268,6 +268,7 @@ USA.
                                  (->environment '(EDWIN BOCHSER)))
        |#
        (load "notify" environment)
+       (load "world-monitor" environment)
        (if (access *external-doc-strings?* environment)
            (begin
              (set! (access *external-doc-strings?* environment) false)

diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg
index 60e77d33ceb129015634ef4b6fe179a7fe4ca2f8..711d69f3e0eefec442a8c6ddd48bd8964bfa2f9d 100644 (file)
--- a/src/edwin/edwin.pkg
+++ b/src/edwin/edwin.pkg
@@ -99,6 +99,7 @@ USA.
         "outline"                      ; outline minor mode
         "sort"                         ; sorting commands
         "webster"                      ; access a Webster server
+        "world-monitor"
         )
 
   (parent ())

diff --git a/src/edwin/world-monitor.scm b/src/edwin/world-monitor.scm
new file mode 100644 (file)
index 0000000..dac34ed
--- /dev/null
+++ b/src/edwin/world-monitor.scm
@@ -0,0 +1,118 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016
+    Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Create a *World* buffer containing the world report.
+
+(declare (usual-integrations))
+\f
+(define-command monitor-world
+  "Find or create a buffer named *World*, insert a world report into
+it, and spawn a thread to update it after every
+\\[world-monitor-sleep] seconds."
+  ()
+  (lambda ()
+    (let* ((buffer (find-or-create-buffer "*World*"))
+          (thread (buffer-get buffer 'WORLD-MONITOR #f)))
+      (if (not thread)
+         (start-world-monitor buffer))
+      (pop-up-buffer buffer #f))))
+
+(define-variable world-monitor-sleep
+  "Number of seconds the world monitor should sleep between reports."
+  1.
+  (lambda (object)
+    (and (flo:flonum? object)
+        (flo:< .09 object))))
+
+(define (start-world-monitor buffer)
+  (set-buffer-major-mode! buffer (ref-mode-object read-only))
+  (let ((registration #f)
+       (report #f)
+       (thread-flags (list (cons (current-thread) "Edwin"))))
+
+    (define (new-report)
+      (with-output-to-string
+       (lambda () (world-report (current-output-port) thread-flags))))
+
+    (define (sleep)
+      (sleep-current-thread
+       (flo:round->exact
+       (flo:* 1000. (ref-variable world-monitor-sleep)))))
+
+    (let ((monitor
+          (create-thread editor-thread-root-continuation
+            (named-lambda (monitor-world)
+              (let loop ()
+                (sleep)
+                (if (buffer-alive? buffer)
+                    (begin
+                      (if registration
+                          (begin
+                            (set! report (new-report))
+                            (inferior-thread-output! registration)))
+                      (loop))
+                    (begin
+                      (if registration
+                          (deregister-inferior-thread! registration))
+                      (set! registration #f)
+                      (exit-current-thread #t))))))))
+
+      (buffer-put! buffer 'WORLD-MONITOR monitor)
+      (update-world-monitor! buffer (new-report))
+      (set! registration
+           (register-inferior-thread!
+            monitor (named-lambda (world-monitor-output!)
+                      (update-world-monitor! buffer report)))))))
+
+(define (update-world-monitor! buffer report)
+  (let ((saved-windows
+        (map (lambda (window)
+               (cons window
+                     (cons (mark-temporary-copy (window-point window))
+                           (window-start-mark window) ;already temporary
+                           )))
+             (buffer-windows buffer)))
+       (saved-mark (let ((ring (buffer-mark-ring buffer)))
+                     (if (ring-empty? ring)
+                         #f
+                         (mark-temporary-copy (ring-ref ring 0))))))
+    (with-read-only-defeated
+     buffer (lambda ()
+             (with-group-undo-disabled
+              (buffer-group buffer)
+              (lambda ()
+                (buffer-widen! buffer)
+                (region-delete! (buffer-region buffer))
+                (insert-string report (buffer-start buffer))
+                (buffer-not-modified! buffer)))))
+    (for-each (lambda (item)
+               (let ((window (car item))
+                     (point (cadr item))
+                     (start (cddr item)))
+                 (set-window-point! window point)
+                 (set-window-start-mark! window start 0)))
+             saved-windows)
+    (if saved-mark (set-buffer-mark! buffer saved-mark))))
\ No newline at end of file