From 3f4156fbdd6d3a67ccee5ce3690dabf595002984 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 31 May 2001 19:57:40 +0000 Subject: [PATCH] Implement START-STANDARD-POLLING-THREAD and STOP-STANDARD-POLLING-THREAD to capture standard method of using background thread to poll for output or events. --- v7/src/edwin/editor.scm | 29 +++++++++++++++++++++++- v7/src/edwin/notify.scm | 36 +++++++++--------------------- v7/src/imail/imail-top.scm | 45 ++++++++++++-------------------------- 3 files changed, 52 insertions(+), 58 deletions(-) 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 -- 2.25.1