Implement START-STANDARD-POLLING-THREAD and

STOP-STANDARD-POLLING-THREAD to capture standard method of using
background thread to poll for output or events.

diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm
index 55b45a21c2527c4bbea27ca4b8a10193346db071..304638d8121975e107ee61736f41fcdf7852a266 100644 (file)
--- a/v7/src/edwin/editor.scm
+++ b/v7/src/edwin/editor.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: editor.scm,v 1.250 2001/05/31 19:41:53 cph Exp $
+;;; $Id: editor.scm,v 1.251 2001/05/31 19:56:37 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
 ;;;
@@ -537,6 +537,33 @@ TRANSCRIPT    messages appear in transcript buffer, if it is enabled;
                 (weak-set-cdr! (car threads) #f))
               (loop (cdr threads) threads)))))))
 
+(define (start-standard-polling-thread interval output-processor)
+  (let ((holder (list #f)))
+    (set-car! holder
+             (register-inferior-thread!
+              (let ((thread
+                     (create-thread editor-thread-root-continuation
+                       (lambda ()
+                         (do () (#f)
+                           (let ((registration (car holder)))
+                             (cond ((eq? registration 'KILL-THREAD)
+                                    (exit-current-thread unspecific))
+                                   (registration
+                                    (inferior-thread-output! registration))))
+                           (sleep-current-thread interval))))))
+                (detach-thread thread)
+                thread)
+              output-processor))
+    holder))
+
+(define (stop-standard-polling-thread holder)
+  (without-interrupts
+   (lambda ()
+     (let ((registration (car holder)))
+       (if (and registration (not (eq? registration 'KILL-THREAD)))
+          (deregister-inferior-thread! registration)))
+     (set-car! holder 'KILL-THREAD))))
+\f
 (define (inferior-thread-output! flags)
   (without-interrupts (lambda () (inferior-thread-output!/unsafe flags))))
 

diff --git a/v7/src/edwin/notify.scm b/v7/src/edwin/notify.scm
index a39a988a4c1740dc6f5fe20ee9c24a5412d9c318..7381c25dd8469bb7201dfb39d2a70b0eedb5e4bd 100644 (file)
--- a/v7/src/edwin/notify.scm
+++ b/v7/src/edwin/notify.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: notify.scm,v 1.19 2001/01/06 02:36:20 cph Exp $
+;;; $Id: notify.scm,v 1.20 2001/05/31 19:57:23 cph Exp $
 ;;;
 ;;; Copyright (c) 1992-2001 Massachusetts Institute of Technology
 ;;;
@@ -16,7 +16,8 @@
 ;;;
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
 
 ;;;; Mode-line notifications (e.g. presence of mail, load average)
 
@@ -149,7 +150,6 @@ Ignored if notify-show-mail is false."
 (define notifier-mail-string "")
 (define override-notifier-mail-string #f)
 (define mail-notify-hook-installed? #f)
-(define current-notifier-thread #f)
 (define notifier-thread-registration #f)
 \f
 (define-command run-notifier
@@ -173,19 +173,10 @@ which can show various things including time, load average, and mail status."
          unspecific))
     ((ref-command kill-notifier))
     (set-variable! global-mode-string `("" ,notifier:get-string))
-    (let ((thread
-          (create-thread
-           editor-thread-root-continuation
-           (lambda ()
-             (do () (#f)
-               (if notifier-thread-registration
-                   (inferior-thread-output! notifier-thread-registration))
-               (sleep-current-thread
-                (* 1000 (ref-variable notify-interval))))))))
-      (detach-thread thread)
-      (set! current-notifier-thread thread)
-      (set! notifier-thread-registration
-           (register-inferior-thread! thread notifier)))
+    (set! notifier-thread-registration
+         (start-standard-polling-thread (* (ref-variable notify-interval #f)
+                                           1000)
+                                        notifier))
     unspecific))
 
 (define (notifier)
@@ -210,17 +201,10 @@ which can show various things including time, load average, and mail status."
   (lambda ()
     (without-interrupts
      (lambda ()
-       (if current-notifier-thread
-          (begin
-            (if (not (thread-dead? current-notifier-thread))
-                (signal-thread-event current-notifier-thread
-                  (lambda ()
-                    (exit-current-thread unspecific))))
-            (set! current-notifier-thread #f)))
        (if notifier-thread-registration
           (begin
-            (deregister-inferior-thread! notifier-thread-registration)
-            (set! notifier-thread-registration #f)))
-       unspecific))
+            (stop-standard-polling-thread notifier-thread-registration)
+            (set! notifier-thread-registration #f)
+            unspecific))))
     (update-notifier-strings! "" "")
     (set-variable! global-mode-string override-notifier-mail-string #f)))
\ No newline at end of file

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 63fe53426e9136d1ffea4fb8598f5bf0c5a59e2f..b498e382dcdcf4671ba06b0f832e9160140628d9 100644 (file)
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.257 2001/05/29 19:32:39 cph Exp $
+;;; $Id: imail-top.scm,v 1.258 2001/05/31 19:57:40 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -2096,30 +2096,18 @@ Negative argument means search in reverse."
 
 (define (start-probe-folder-thread buffer)
   (stop-probe-folder-thread buffer)
-  (let ((folder (buffer-get buffer 'IMAIL-FOLDER #f))
-       (interval (ref-variable imail-update-interval #f)))
-    (if (and folder interval
-            (not (get-property folder 'PROBE-REGISTRATION #f)))
-       (let ((holder (list #f)))
-         (set-car! holder
-                   (register-inferior-thread!
-                    (let ((thread
-                           (create-thread
-                            editor-thread-root-continuation
-                            (probe-folder-thread holder
-                                                 (* 1000 interval)))))
-                      (detach-thread thread)
-                      thread)
-                    (probe-folder-output-processor
-                     (weak-cons folder unspecific))))
-         (store-property! folder 'PROBE-REGISTRATION holder)))))
-
-(define ((probe-folder-thread holder interval))
-  (do () (#f)
-    (let ((registration (car holder)))
-      (cond ((eq? registration 'KILL-THREAD) (exit-current-thread unspecific))
-           (registration (inferior-thread-output! registration))))
-    (sleep-current-thread interval)))
+  (without-interrupts
+   (lambda ()
+     (let ((folder (buffer-get buffer 'IMAIL-FOLDER #f))
+          (interval (ref-variable imail-update-interval #f)))
+       (if (and folder interval
+               (not (get-property folder 'PROBE-REGISTRATION #f)))
+          (store-property! folder
+                           'PROBE-REGISTRATION
+                           (start-standard-output-polling-thread
+                            (* 1000 interval)
+                            (probe-folder-output-processor
+                             (weak-cons folder unspecific)))))))))
 
 (define ((probe-folder-output-processor folder))
   (let ((folder (weak-car folder)))
@@ -2137,12 +2125,7 @@ Negative argument means search in reverse."
           (begin
             (let ((holder (get-property folder 'PROBE-REGISTRATION #f)))
               (if holder
-                  (begin
-                    (let ((registration (car holder)))
-                      (if (and registration
-                               (not (eq? registration 'KILL-THREAD)))
-                          (deregister-inferior-thread! registration)))
-                    (set-car! holder 'KILL-THREAD))))
+                  (stop-standard-output-polling-thread holder)))
             (remove-property! folder 'PROBE-REGISTRATION)))))))
 \f
 ;;;; Message insertion procedures