Mercurial > hg > xemacs-beta
diff lisp/prim/itimer.el @ 100:4be1180a9e89 r20-1b2
Import from CVS: tag r20-1b2
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:15:11 +0200 |
parents | 131b0175ea99 |
children | a145efe76779 |
line wrap: on
line diff
--- a/lisp/prim/itimer.el Mon Aug 13 09:13:58 2007 +0200 +++ b/lisp/prim/itimer.el Mon Aug 13 09:15:11 2007 +0200 @@ -1,9 +1,11 @@ -;;; Interval timers for XEmacs -;;; Copyright (C) 1988, 1991, 1993 Kyle E. Jones -;;; Modified 5 Feb 91 by Jamie Zawinski <jwz@lucid.com> for Lucid Emacs -;;; And again, 15 Dec 93. -;;; -;; This file is part of XEmacs. +;;; itimer.el -- Interval timers for XEmacs + +;; Copyright (C) 1988, 1991, 1993, 1997 Kyle E. Jones + +;; Author: Kyle Jones <kyle_jones@wonderworks.com> +;; Keywords: extensions + +;; This file is part of XEmacs ;; XEmacs is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by @@ -15,53 +17,76 @@ ;; 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; A copy of the GNU General Public License can be obtained from this +;; program's author (send electronic mail to kyle@uunet.uu.net) or +;; from the Free Software Foundation, Inc., 59 Temple Place - Suite +;; 330, Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF -;;; Synched up with: Not in FSF. +;;; Commentary: + +;; Send bug reports to kyle_jones@wonderworks.com -;;; -;;; Send bug reports to kyle@uunet.uu.net. +;;; Code: + +(provide 'itimer) -;; The original v18 version of this file worked by having an external program -;; wake up once a second to generate an interrupt for emacs; then an emacs -;; process filter was used to schedule timers. -;; -;; This version works by associating with each timer a "timeout" object, -;; since the XEmacs/Lucid Emacs event loop has the concept of timers built -;; in to it. There is no single scheduler function; instead, each timer -;; re-sets itself as it is invoked. - -;; `itimer' feature means Emacs-Lisp programers get: -;; itimerp, itimer-value, itimer-restart, itimer-function, -;; set-itimer-value, set-itimer-restart, set-itimer-function -;; get-itimer, start-itimer, read-itimer, delete-itimer +;; `itimer' feature means Emacs-Lisp programmers get: +;; itimerp +;; itimer-value +;; itimer-restart +;; itimer-function +;; itimer-function-argument +;; set-itimer-value +;; set-itimer-restart +;; set-itimer-function +;; set-itimer-uses-argument +;; set-itimer-function-argument +;; get-itimer +;; start-itimer +;; read-itimer +;; delete-itimer ;; ;; Interactive users get these commands: -;; edit-itimers, list-itimers, start-itimer +;; edit-itimers +;; list-itimers +;; start-itimer ;; ;; See the doc strings of these functions for more information. -(defvar itimer-version "1.00" +(defvar itimer-version "1.01" "Version number of the itimer package.") (defvar itimer-list nil "List of all active itimers.") -;; not needed in XEmacs -;(defvar itimer-process nil -; "Process that drives all itimers.") +(defvar itimer-process nil + "Process that drives all itimers, if a subprocess is being used.") + +(defvar itimer-timer nil + "Emacs internal timer that drives the itimer system, if a subprocess +is not being used to drive the system.") + +(defvar itimer-timer-last-wakeup nil + "The time the timer driver function last ran.") -;; This value is maintained internally; it does not determine itimer -;; granularity. Itimer granularity is 1 second, plus delays due to -;; system and Emacs internal activity that delay dealing with process -;; output. -;; not needed in XEmacs -;(defvar itimer-process-next-wakeup 1 -; "Itimer process will wakeup to service running itimers within this -;many seconds.") +(defvar itimer-short-interval (if (featurep 'lisp-float-type) 1e-3 1) + "Interval used for scheduling an event a very short time in the future. +Used internally to make the scheduler wake up early. +Unit is seconds.") + +;; This value is maintained internally; it does not determine +;; itimer granularity. Itimer granularity is 1 second if your +;; Emacs doens't support floats or your system doesn't have a +;; clock with microsecond granularity. Otherwise granularity is +;; to the microsend, although you can't possibly get timers to be +;; executed with this kind of accuracy in practice. There will +;; be delays due to system and Emacs internal activity that delay +;; dealing with syunchronous events and process output. +(defvar itimer-next-wakeup itimer-short-interval + "Itimer process will wakeup to service running itimers within this +many seconds.") (defvar itimer-edit-map nil "Keymap used when in Itimer Edit mode.") @@ -85,10 +110,10 @@ ;; macros must come first... or byte-compile'd code will throw back its ;; head and scream. -(defmacro itimer-decf (variable) +(defmacro itimer-decrement (variable) (list 'setq variable (list '1- variable))) -(defmacro itimer-incf (variable) +(defmacro itimer-increment (variable) (list 'setq variable (list '1+ variable))) (defmacro itimer-signum (n) @@ -118,15 +143,19 @@ (list t (list 'signal ''wrong-type-argument (list 'list ''string-or-itimer-p var)))))) -(defmacro itimer-check-natnum (var) - "If VAR is not bound to a non-negative number, signal wrong-type-argument. +(defmacro check-nonnegative-number (var) + "If VAR is not bound to a number, signal wrong-type-argument. +If VAR is not bound to a positive number, signal args-out-of-range. This is a macro." (list 'setq var - (list 'if (list 'natnump var) var + (list 'if (list 'not (list 'numberp var)) (list 'signal ''wrong-type-argument - (list 'list ''natnump var))))) + (list 'list ''natnump var)) + (list 'if (list '< var 0) + (list 'signal ''args-out-of-range (list 'list var)) + var)))) -(defmacro itimer-check-string (var) +(defmacro check-string (var) "If VAR is not bound to a string, signal wrong-type-argument. This is a macro." (list 'setq var @@ -138,10 +167,7 @@ (defun itimerp (obj) "Returns non-nil iff OBJ is an itimer." - (and (consp obj) (stringp (car obj)) (eq (length obj) - 5 ; for XEmacs - ;4 ; original version - ))) + (and (consp obj) (stringp (car obj)) (eq (length obj) 6))) (defun itimer-name (itimer) "Returns the name of ITIMER." @@ -165,66 +191,57 @@ (check-itimer itimer) (nth 3 itimer)) -;; XEmacs-specific -(defun itimer-id (itimer) - "Returns the timeout-id of ITIMER." +(defun itimer-uses-argument (itimer) + "Returns non-nil if the function of ITIMER will be called with an argment. +ITIMER's function is called with this argument each timer ITIMER expires." (check-itimer itimer) (nth 4 itimer)) -(defun set-itimer-value (itimer value - ;; XEmacs doesn't need this - ;; &optional nowakeup - ) +(defun itimer-function-argument (itimer) + "Returns the function argument of ITIMER. +ITIMER's function is called with this argument each timer ITIMER expires." + (check-itimer itimer) + (nth 5 itimer)) + +(defun set-itimer-value (itimer value) "Set the timeout value of ITIMER to be VALUE. Itimer will expire is this many seconds. +If your version of Emacs supports floating point numbers then +VALUE can be a floating point number. Otherwise it +must be an integer. Returns VALUE." -;; Optional third arg NOWAKEUP non-nil means do not wakeup the itimer -;; process to recompute a correct wakeup time, even if it means this -;; itimer will expire late. itimer-process-filter uses this option. -;; This is not meant for ordinary usage, which is why it is not -;; mentioned in the doc string. (check-itimer itimer) - (itimer-check-natnum value) + (check-nonnegative-number value) (let ((inhibit-quit t)) + ;; If the itimer is in the active list, and under the new + ;; timeout value would expire before we would normally + ;; wakeup, wakeup now and recompute a new wakeup time. + (or (and (< value itimer-next-wakeup) + (get-itimer (itimer-name itimer)) + (progn (itimer-driver-wakeup) + (setcar (cdr itimer) value) + (itimer-driver-wakeup) + t )) + (setcar (cdr itimer) value)) + value)) -; ;; If we're allowed to wakeup the itimer process, -; ;; and the itimer process's next wakeup needs to be recomputed, -; ;; and the itimer is running, then we wakeup the itimer process. -; (or (and (not nowakeup) (< value itimer-process-next-wakeup) -; (get-itimer (itimer-name itimer)) -; (progn (itimer-process-wakeup) -; (setcar (cdr itimer) value) -; (itimer-process-wakeup))) -; (setcar (cdr itimer) value)) - - ;; the XEmacs way: - (if (itimer-id itimer) - (deactivate-itimer itimer)) - (setcar (cdr itimer) value) - (activate-itimer itimer) - - value)) +;; Same as set-itimer-value but does not wakeup the driver. +;; Only should be used by the drivers when processing expired timers. +(defun set-itimer-value-internal (itimer value) + (check-itimer itimer) + (check-nonnegative-number value) + (setcar (cdr itimer) value)) (defun set-itimer-restart (itimer restart) "Set the restart value of ITIMER to be RESTART. If RESTART is nil, ITIMER will not restart when it expires. +If your version of Emacs supports floating point numbers then +RESTART can be a floating point number. Otherwise it +must be an integer. Returns RESTART." (check-itimer itimer) - (if restart (itimer-check-natnum restart)) - (and restart (< restart 1) (signal 'args-out-of-range (list restart))) -;; (setcar (cdr (cdr itimer)) restart) - ;; the XEmacs way - (let ((was-active (itimer-id itimer)) - (inhibit-quit t)) - (if was-active - (deactivate-itimer itimer)) - (setcar (cdr (cdr itimer)) restart) - (if was-active - (progn - (setcar (cdr itimer) restart) - (if restart - (activate-itimer itimer))))) - restart) + (if restart (check-nonnegative-number restart)) + (setcar (cdr (cdr itimer)) restart)) (defun set-itimer-function (itimer function) "Set the function of ITIMER to be FUNCTION. @@ -233,14 +250,25 @@ (check-itimer itimer) (setcar (cdr (cdr (cdr itimer))) function)) -;; XEmacs-specific -(defun set-itimer-id (itimer id) +(defun set-itimer-uses-argument (itimer flag) + "Sets when the function of ITIMER is called with an argument. +If FLAG is non-nil, then the function will be called with one argument, +otherwise the function will be called with no arguments. +Returns FLAG." (check-itimer itimer) - (setcar (cdr (cdr (cdr (cdr itimer)))) id)) + (setcar (nthcdr 4 itimer) flag)) + +(defun set-itimer-function-argument (itimer argument) + "Set the function of ITIMER to be ARGUMENT. +The function of ITIMER will be called with ARGUMENT as its solt argument +when itimer expires. +Returns ARGUMENT." + (check-itimer itimer) + (setcar (nthcdr 5 itimer) argument)) (defun get-itimer (name) "Return itimer named NAME, or nil if there is none." - (itimer-check-string name) + (check-string name) (assoc name itimer-list)) (defun read-itimer (prompt &optional initial-input) @@ -253,20 +281,26 @@ (defun delete-itimer (itimer) "Deletes ITIMER. ITIMER may be an itimer or the name of one." (check-itimer-coerce-string itimer) - (deactivate-itimer itimer) ;; for XEmacs (setq itimer-list (delq itimer itimer-list))) -;jwz: this is preloaded so don't ;;;###autoload -(defun start-itimer (name function value &optional restart) +(defun start-itimer (name function value &optional restart + with-arg function-argument) "Start an itimer. -Args are NAME, FUNCTION, VALUE &optional RESTART. +Args are NAME, FUNCTION, VALUE &optional RESTART, WITH-ARG, FUNCTION-ARGUMENT. NAME is an identifier for the itimer. It must be a string. If an itimer already exists with this name, NAME will be modified slightly to until it is unique. -FUNCTION should be a function (or symbol naming one) of no arguments. It - will be called each time the itimer expires. The function can access - itimer that invoked it through the variable `current-itimer'. +FUNCTION should be a function (or symbol naming one) of one argument. It + will be called each time the itimer expires with an argument of + FUNCTION-ARGUMENT. The function can access the itimer that + invoked it through the variable `current-itimer'. If WITH-ARG + is nil then FUNCTION is called with no arguments. This is for + backward compatibility with older versions of the itimer + package which always called FUNCTION with no arguments. VALUE is the number of seconds until this itimer expires. + If your version of Emacs supports floating point numbers then + you can VALUE can be a floating point number. Otherwise it + must be an integer. Optional fourth arg RESTART non-nil means that this itimer should be restarted automatically after its function is called. Normally an itimer is deleted at expiration after its function has returned. @@ -277,41 +311,42 @@ (list (completing-read "Start itimer: " itimer-list) (read (completing-read "Itimer function: " obarray 'fboundp)) (let (value) - (while (not (natnump value)) + (while (or (not (numberp value)) (< value 0)) (setq value (read-from-minibuffer "Itimer value: " nil nil t))) value) (let ((restart t)) - (while (and restart (not (natnump restart))) - (setq restart (read-from-minibuffer "Itimer restart: " nil nil t))) - restart))) - (itimer-check-string name) - (itimer-check-natnum value) - (if restart (itimer-check-natnum restart)) + (while (and restart (or (not (numberp restart)) (< restart 0))) + (setq restart (read-from-minibuffer "Itimer restart: " + nil nil t))) + restart) + ;; hard to imagine the user specifying these interactively + nil + nil )) + (check-string name) + (check-nonnegative-number value) + (if restart (check-nonnegative-number restart)) ;; Make proposed itimer name unique if it's not already. (let ((oname name) (num 2)) (while (get-itimer name) (setq name (concat oname "<" num ">")) - (itimer-incf num))) -; ;; If there's no itimer process, start one now. -; ;; Otherwise wake up the itimer process so that seconds slept before -; ;; the new itimer is created won't be counted against it. -; (if itimer-process -; (itimer-process-wakeup) -; (itimer-process-start)) + (itimer-increment num))) + ;; If there's no itimer process, start one now. + ;; Otherwise wake up the itimer process so that seconds slept before + ;; the new itimer is created won't be counted against it. + (if (or itimer-process itimer-timer) + (itimer-driver-wakeup) + (itimer-driver-start)) (let ((inhibit-quit t)) ;; add the itimer to the global list (setq itimer-list - (cons (list name value restart function nil) ; extra slot for XEmacs + (cons (list name value restart function with-arg function-argument) itimer-list)) -; ;; If the itimer process is scheduled to wake up too late for the itimer -; ;; we wake it up to calculate a correct wakeup value giving consideration -; ;; to the newly added itimer. -; (if (< value itimer-process-next-wakeup) -; (itimer-process-wakeup))) - ;; for XEmacs - (activate-itimer (car itimer-list)) - ) + ;; If the itimer process is scheduled to wake up too late for the itimer + ;; we wake it up to calculate a correct wakeup value giving consideration + ;; to the newly added itimer. + (if (< value itimer-next-wakeup) + (itimer-driver-wakeup))) (car itimer-list)) ;; User level functions to list and modify existing itimers. @@ -331,19 +366,27 @@ (itimer-edit-mode) (setq buffer-read-only nil) (erase-buffer) - (insert "Name Value Restart Function\n" - "---- ----- ------- --------") + (insert +"Name Value Restart Function Argument\n" +"---- ----- ------- -------- --------") (if (null itimer-edit-start-marker) (setq itimer-edit-start-marker (point))) (while itimers (newline 1) (prin1 (itimer-name (car itimers))) (tab-to-tab-stop) - (prin1 (itimer-value (car itimers))) + (insert (itimer-truncate-string + (format "%5.5s" (itimer-value (car itimers))) 5)) + (tab-to-tab-stop) + (insert (itimer-truncate-string + (format "%5.5s" (itimer-restart (car itimers))) 5)) (tab-to-tab-stop) - (prin1 (itimer-restart (car itimers))) + (insert (itimer-truncate-string + (format "%.26s" (itimer-function (car itimers))) 26)) (tab-to-tab-stop) - (prin1 (itimer-function (car itimers))) + (if (itimer-uses-argument (car itimers)) + (prin1 (itimer-function-argument (car itimers))) + (prin1 'NONE)) (setq itimers (cdr itimers))) ;; restore point (goto-char opoint) @@ -359,8 +402,8 @@ for `itimer-edit-mode' for more information." (interactive) ;; since user is editing, make sure displayed data is reasonably up-to-date -; (if itimer-process -; (itimer-process-wakeup)) + (if (or itimer-process itimer-timer) + (itimer-driver-wakeup)) (list-itimers) (select-window (get-buffer-window "*Itimer List*")) (goto-char itimer-edit-start-marker) @@ -389,12 +432,12 @@ (setq major-mode 'itimer-edit-mode mode-name "Itimer Edit" truncate-lines t - tab-stop-list '(22 32 42)) + tab-stop-list '(22 32 40 67)) (abbrev-mode 0) (auto-fill-mode 0) - (buffer-disable-undo (current-buffer)) + (buffer-flush-undo (current-buffer)) (use-local-map itimer-edit-map) - (and lisp-mode-syntax-table (set-syntax-table lisp-mode-syntax-table))) + (set-syntax-table emacs-lisp-mode-syntax-table)) (put 'itimer-edit-mode 'mode-class 'special) @@ -435,30 +478,34 @@ ;; and use this info to determine which field the user ;; wants to modify. (beginning-of-line) - (while (and (>= opoint (point)) (< n 4)) + (while (and (>= opoint (point)) (< n 5)) (forward-sexp 2) (backward-sexp) - (itimer-incf n)) + (itimer-increment n)) (cond ((eq n 1) (error "Cannot change itimer name.")) ((eq n 2) 'value) ((eq n 3) 'restart) - ((eq n 4) 'function))))) + ((eq n 4) 'function) + (t 'function-argument))))) (cond ((eq field 'value) - ;; XEmacs: rewritten for I18N3 snarfing - (while (not (natnump field-value)) - (setq field-value (read-from-minibuffer "Set itimer value: " - nil nil t)))) + (let ((prompt "Set itimer value: ")) + (while (not (natnump field-value)) + (setq field-value (read-from-minibuffer prompt nil nil t))))) ((eq field 'restart) - (while (and field-value (not (natnump field-value))) - (setq field-value (read-from-minibuffer "Set itimer restart: " - nil nil t)))) + (let ((prompt "Set itimer restart: ")) + (while (and field-value (not (natnump field-value))) + (setq field-value (read-from-minibuffer prompt nil nil t))))) ((eq field 'function) - (while (not (or (and (symbolp field-value) (fboundp field-value)) - (and (consp field-value) - (memq (car field-value) '(lambda macro))))) - (setq field-value - (read (completing-read "Set itimer function: " - obarray 'fboundp nil)))))) + (let ((prompt "Set itimer function: ")) + (while (not (or (and (symbolp field-value) (fboundp field-value)) + (and (consp field-value) + (memq (car field-value) '(lambda macro))))) + (setq field-value + (read (completing-read prompt obarray 'fboundp nil)))))) + ((eq field 'function-argument) + (let ((prompt "Set itimer function argument: ")) + (setq field-value (read-expression prompt)) + (set-itimer-uses-argument itimer t)))) ;; set the itimer field (funcall (intern (concat "set-itimer-" (symbol-name field))) itimer field-value) @@ -503,7 +550,7 @@ (progn (forward-sexp 2) (backward-sexp))) - (itimer-decf count))) + (itimer-decrement count))) ((< (itimer-signum count) 0) (while (not (zerop count)) (backward-sexp) @@ -515,7 +562,7 @@ (progn (goto-char (point-max)) (backward-sexp))) - (itimer-incf count))))) + (itimer-increment count))))) (defun itimer-edit-previous-field (count) (interactive "p") @@ -528,210 +575,166 @@ ((eq forw-back (point)) t) (t (backward-sexp))))) +(defun itimer-truncate-string (str len) + (if (<= (length str) len) + str + (substring str 0 len))) ;; internals of the itimer implementation. +(defun itimer-run-expired-timers (time-elapsed) + (let ((itimers (copy-sequence itimer-list)) + (itimer) + (next-wakeup 600) + ;; process filters can be hit by stray C-g's from the user, + ;; so we must protect this stuff appropriately. + ;; Quit's are allowed from within itimer functions, but we + ;; catch them and print a message. + (inhibit-quit t)) + (setq next-wakeup 600) + (while itimers + (setq itimer (car itimers)) + (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer) + time-elapsed))) + (if (> (itimer-value itimer) 0) + (setq next-wakeup + (min next-wakeup (itimer-value itimer))) + ;; itimer has expired, we must call its function. + ;; protect our local vars from the itimer function. + ;; allow keyboard quit to occur, but catch and report it. + ;; provide the variable `current-itimer' in case the function + ;; is interested. + (condition-case condition-data + (save-match-data + (let* ((current-itimer itimer) + (quit-flag nil) + (inhibit-quit nil) + itimer itimers time-elapsed) + (if (itimer-uses-argument current-itimer) + (funcall (itimer-function current-itimer) + (itimer-function-argument current-itimer)) + (funcall (itimer-function current-itimer))))) + (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer) + (prin1-to-string condition-data))) + (quit (message "itimer \"%s\" quit" (itimer-name itimer)))) + ;; restart the itimer if we should, otherwise delete it. + (if (null (itimer-restart itimer)) + (delete-itimer itimer) + (set-itimer-value-internal itimer (itimer-restart itimer)) + (setq next-wakeup (min next-wakeup (itimer-value itimer))))) + (setq itimers (cdr itimers))) + ;; if user is editing itimers, update displayed info + (if (eq major-mode 'itimer-edit-mode) + (list-itimers)) + next-wakeup )) + (defun itimer-process-filter (process string) - (error "itimer-process-filter is not used in XEmacs") -; ;; If the itimer process dies and generates output while doing -; ;; so, we may be called before the process-sentinel. Sanity -; ;; check the output just in case... -; (if (not (string-match "^[0-9]" string)) -; (progn (message "itimer process gave odd output: %s" string) -; ;; it may be still alive and waiting for input -; (process-send-string itimer-process "3\n")) -; ;; if there are no active itimers, return quickly. -; (if itimer-list -; (let ((time-elapsed (string-to-int string)) -; (itimers itimer-list) -; (itimer) -; ;; process filters can be hit by stray C-g's from the user, -; ;; so we must protect this stuff appropriately. -; ;; Quit's are allowed from within itimer functions, but we -; ;; catch them. -; (inhibit-quit t)) -; (setq itimer-process-next-wakeup 600) -; (while itimers -; (setq itimer (car itimers)) -; (set-itimer-value itimer (max 0 (- (itimer-value itimer) time-elapsed)) t) -; (if (> (itimer-value itimer) 0) -; (setq itimer-process-next-wakeup -; (min itimer-process-next-wakeup (itimer-value itimer))) -; ;; itimer has expired, we must call its function. -; ;; protect our local vars from the itimer function. -; ;; allow keyboard quit to occur, but catch and report it. -; ;; provide the variable `current-itimer' in case the function -; ;; is interested. -; (condition-case condition-data -; (let* ((current-itimer itimer) -; itimer itimers time-elapsed -; quit-flag inhibit-quit) -; (funcall (itimer-function current-itimer))) -; (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer) -; (prin1-to-string condition-data))) -; (quit (message "itimer \"%s\" quit" (itimer-name itimer)))) -; ;; restart the itimer if we should, otherwise delete it. -; (if (null (itimer-restart itimer)) -; (delete-itimer itimer) -; (set-itimer-value itimer (itimer-restart itimer) t) -; (setq itimer-process-next-wakeup -; (min itimer-process-next-wakeup (itimer-value itimer))))) -; (setq itimers (cdr itimers))) -; ;; if user is editing itimers, update displayed info -; (if (eq major-mode 'itimer-edit-mode) -; (list-itimers))) -; (setq itimer-process-next-wakeup 600)) -; ;; tell itimer-process when to wakeup again -; (process-send-string itimer-process -; (concat (int-to-string itimer-process-next-wakeup) -; "\n"))) - ) + ;; If the itimer process dies and generates output while doing + ;; so, we may be called before the process-sentinel. Sanity + ;; check the output just in case... + (if (not (string-match "^[0-9]" string)) + (progn (message "itimer process gave odd output: %s" string) + ;; it may be still alive and waiting for input + (process-send-string itimer-process "3\n")) + ;; if there are no active itimers, return quickly. + (if itimer-list + (setq itimer-next-wakeup + (itimer-run-expired-timers (string-to-int string))) + (setq itimer-next-wakeup 600)) + ;; tell itimer-process when to wakeup again + (process-send-string itimer-process + (concat (int-to-string itimer-next-wakeup) + "\n")))) (defun itimer-process-sentinel (process message) - (error "itimer-process-sentinel is not used in XEmacs") -; (let ((inhibit-quit t)) -; (if (eq (process-status process) 'stop) -; (continue-process process) -; ;; not stopped, so it must have died. -; ;; cleanup first... -; (delete-process process) -; (setq itimer-process nil) -; ;; now, if there are any active itimers then we need to immediately -; ;; start another itimer process, otherwise we can wait until the next -; ;; start-itimer call, which will start one automatically. -; (if (null itimer-list) -; () -; ;; there may have been an error message in the echo area; -; ;; give the user at least a little time to read it. -; (sit-for 2) -; (message "itimer process %s... respawning." (substring message 0 -1)) -; (itimer-process-start)))) - ) + (let ((inhibit-quit t)) + (if (eq (process-status process) 'stop) + (continue-process process) + ;; not stopped, so it must have died. + ;; cleanup first... + (delete-process process) + (setq itimer-process nil) + ;; now, if there are any active itimers then we need to immediately + ;; start another itimer process, otherwise we can wait until the next + ;; start-itimer call, which will start one automatically. + (if (null itimer-list) + () + ;; there may have been an error message in the echo area; + ;; give the user at least a little time to read it. + (sit-for 2) + (message "itimer process %s... respawning." (substring message 0 -1)) + (itimer-process-start))))) (defun itimer-process-start () - (error "itimer-process-start is not used in XEmacs") -; (let ((inhibit-quit t) -; (process-connection-type nil)) -; (setq itimer-process (start-process "itimer" nil "itimer")) -; (process-kill-without-query itimer-process) -; (set-process-filter itimer-process 'itimer-process-filter) -; (set-process-sentinel itimer-process 'itimer-process-sentinel) -; ;; Tell itimer process to wake up quickly, so that a correct wakeup -; ;; time can be computed. Zero instead of one here loses because of -; ;; underlying itimer implementations that use 0 to mean `disable the -; ;; itimer'. -; (setq itimer-process-next-wakeup 1) -; (process-send-string itimer-process "1\n")) - ) + (let ((inhibit-quit t) + (process-connection-type nil)) + (setq itimer-process (start-process "itimer" nil "itimer")) + (process-kill-without-query itimer-process) + (set-process-filter itimer-process 'itimer-process-filter) + (set-process-sentinel itimer-process 'itimer-process-sentinel) + ;; Tell itimer process to wake up quickly, so that a correct + ;; wakeup time can be computed. Zero loses because of + ;; underlying itimer implementations that use 0 to mean + ;; `disable the itimer'. + (setq itimer-next-wakeup itimer-short-interval) + (process-send-string itimer-process + (format "%s\n" itimer-next-wakeup)))) (defun itimer-process-wakeup () - (error "itimer-process-wakeup is not used in XEmacs") -; (interrupt-process itimer-process) -; (accept-process-output) - ) - - -;; XEmacs-specific code - -(defun activate-itimer (itimer) - (let ((inhibit-quit t)) - (set-itimer-id itimer - (add-timeout (itimer-value itimer) - 'itimer-callback - itimer - (itimer-restart itimer)))) - itimer) - -(defun deactivate-itimer (itimer) - (let ((inhibit-quit t) - (id (itimer-id itimer))) - (and id (disable-timeout id)) - (set-itimer-id itimer nil)) - itimer) + (interrupt-process itimer-process) + (accept-process-output)) -(defun itimer-callback (current-itimer) - (funcall (itimer-function current-itimer))) - - -;;; itimer-driven auto-saves - -;jwz: this is preloaded so don't ;;;###autoload -(defvar auto-save-timeout 30 - "*Number of seconds idle time before auto-save. -Zero or nil means disable auto-saving due to idleness. +(defun itimer-timer-start () + (let ((inhibit-quit t)) + (setq itimer-next-wakeup itimer-short-interval + itimer-timer-last-wakeup (current-time) + itimer-timer (add-timeout itimer-short-interval + 'itimer-timer-driver nil nil)))) -The actual amount of idle time between auto-saves is logarithmically related -to the size of the current buffer. This variable is the number of seconds -after which an auto-save will happen when the current buffer is 50k or less; -the timeout will be 2 1/4 times this in a 200k buffer, 3 3/4 times this in a -1000k buffer, and 4 1/2 times this in a 2000k buffer. - -See also the variable `auto-save-interval', which controls auto-saving based -on the number of characters typed.") - -;jwz: this is preloaded so don't ;;;###autoload -(defvar auto-gc-threshold (/ gc-cons-threshold 3) - "*GC when this many bytes have been consed since the last GC, -and the user has been idle for `auto-save-timeout' seconds.") +(defun itimer-timer-wakeup () + (let ((inhibit-quit t)) + (cond ((fboundp 'cancel-timer) + (cancel-timer itimer-timer)) + ((fboundp 'disable-timeout) + (disable-timeout itimer-timer))) + (setq itimer-timer (add-timeout itimer-short-interval + 'itimer-timer-driver nil nil)))) -(defun auto-save-itimer () - "For use as a itimer callback function. -Auto-saves and garbage-collects based on the size of the current buffer -and the value of `auto-save-timeout', `auto-gc-threshold', and the current -keyboard idle-time." - (if (or (null auto-save-timeout) - (<= auto-save-timeout 0) - (eq (minibuffer-window) (selected-window))) - nil - (let ((buf-size (1+ (ash (buffer-size) -8))) - (delay-level 0) - (now (current-time)) - delay) - (while (> buf-size 64) - (setq delay-level (1+ delay-level) - buf-size (- buf-size (ash buf-size -2)))) - (if (< delay-level 4) - (setq delay-level 4)) - ;; delay_level is 4 for files under around 50k, 7 at 100k, 9 at 200k, - ;; 11 at 300k, and 12 at 500k, 15 at 1 meg, and 17 at 2 meg. - (setq delay (/ (* delay-level auto-save-timeout) 4)) - (let ((idle-time (if (or (not (consp last-input-time)) - (/= (car now) (car last-input-time))) - (1+ delay) - (- (car (cdr now)) (cdr last-input-time))))) - (and (> idle-time delay) - (do-auto-save)) - (and (> idle-time auto-save-timeout) - (> (consing-since-gc) auto-gc-threshold) - (garbage-collect))))) - ;; Look at the itimer that's currently running; if the user has changed - ;; the value of auto-save-timeout, modify this itimer to have the correct - ;; restart time. There will be some latency between when the user changes - ;; this variable and when it takes effect, but it will happen eventually. - (let ((self (get-itimer "auto-save"))) - (or self (error "auto-save-itimer can't find itself")) - (if (and auto-save-timeout (> auto-save-timeout 4)) - (or (= (itimer-restart self) (/ auto-save-timeout 4)) - (set-itimer-restart self (/ auto-save-timeout 4))))) - nil) +(defun itimer-time-difference (t1 t2) + ;; ignore high 16 bits since we will never be dealing with + ;; times that long. + (setq t1 (cdr t1) + t2 (cdr t2)) + (let ((usecs (- (nth 1 t1) (nth 1 t2))) + (secs (- (car t1) (car t2)))) + (if (< usecs 0) + (setq secs (1- secs) + usecs (+ usecs 1000000))) + (+ secs (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000))))) -(defun itimer-init-auto-gc () - (or noninteractive ; may be being run from after-init-hook in -batch mode. - (get-itimer "auto-save") - ;; the time here is just the first interval; if the user changes it - ;; later, it will adjust. - (let ((time (max 2 (/ (or auto-save-timeout 30) 4)))) - (start-itimer "auto-save" 'auto-save-itimer time time)))) +(defun itimer-timer-driver (&rest ignored) + ;; inhibit quit because if the user quits at an inopportune + ;; time, the timer process won't bne launched again and the + ;; system stops working. itimer-run-expired-timers allows + ;; individual timer function to be aborted, so the user can + ;; escape a feral timer function. + (let* ((inhibit-quit t) + (now (current-time)) + (elapsed (itimer-time-difference now itimer-timer-last-wakeup)) + sleep) + (setq itimer-timer-last-wakeup now + sleep (itimer-run-expired-timers elapsed) + itimer-next-wakeup sleep + itimer-timer (add-timeout sleep 'itimer-timer-driver nil nil)))) -(cond (purify-flag - ;; This file is being preloaded into an emacs about to be dumped. - ;; So arrange for the auto-save itimer to be started once emacs - ;; is launched. - (add-hook 'after-init-hook 'itimer-init-auto-gc)) - (t - ;; Otherwise, this file is being loaded into a normal, interactive - ;; emacs. Start the auto-save timer now. - (itimer-init-auto-gc))) +(defun itimer-driver-start () + (if (fboundp 'add-timeout) + (itimer-timer-start) + (itimer-process-start))) - -(provide 'itimer) +(defun itimer-driver-wakeup () + (if (fboundp 'add-timeout) + (itimer-timer-wakeup) + (itimer-process-wakeup))) + +;;; itimer.el ends here