From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 31 May 2001 19:57:40 +0000 (+0000)
Subject: Implement START-STANDARD-POLLING-THREAD and
X-Git-Tag: 20090517-FFI~2759
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3f4156fbdd6d3a67ccee5ce3690dabf595002984;p=mit-scheme.git

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 55b45a21c..304638d81 100644
--- 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))))
+
 (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 a39a988a4..7381c25dd 100644
--- 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)
 
 (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 63fe53426..b498e382d 100644
--- 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)))))))
 
 ;;;; Message insertion procedures