diff options
Diffstat (limited to 'lisp/emacs-lisp/timer.el')
| -rw-r--r-- | lisp/emacs-lisp/timer.el | 236 |
1 files changed, 103 insertions, 133 deletions
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index a6d6e4e9a37..9f5f72d81fe 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -7,10 +7,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs 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 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -18,9 +18,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -35,29 +33,45 @@ ;; triggered-p is nil if the timer is active (waiting to be triggered), ;; t if it is inactive ("already triggered", in theory) -(defun timer-create () - "Create a timer object which can be passed to `timer-activate'." - (let ((timer (make-vector 8 nil))) - (aset timer 0 t) - timer)) +(eval-when-compile (require 'cl)) + +(defstruct (timer + (:constructor nil) + (:copier nil) + (:constructor timer-create ()) + (:type vector) + (:conc-name timer--)) + (triggered t) + high-seconds low-seconds usecs repeat-delay function args idle-delay) (defun timerp (object) "Return t if OBJECT is a timer." (and (vectorp object) (= (length object) 8))) +;; Pseudo field `time'. +(defun timer--time (timer) + (list (timer--high-seconds timer) + (timer--low-seconds timer) + (timer--usecs timer))) + +(defsetf timer--time + (lambda (timer time) + (or (timerp timer) (error "Invalid timer")) + (setf (timer--high-seconds timer) (pop time)) + (setf (timer--low-seconds timer) + (if (consp time) (car time) time)) + (setf (timer--usecs timer) (or (and (consp time) (consp (cdr time)) + (cadr time)) + 0)))) + + (defun timer-set-time (timer time &optional delta) "Set the trigger time of TIMER to TIME. TIME must be in the internal format returned by, e.g., `current-time'. If optional third argument DELTA is a positive number, make the timer fire repeatedly that many seconds apart." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 1 (car time)) - (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time))) - (aset timer 3 (or (and (consp (cdr time)) (consp (cdr (cdr time))) - (nth 2 time)) - 0)) - (aset timer 4 (and (numberp delta) (> delta 0) delta)) + (setf (timer--time timer) time) + (setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta)) timer) (defun timer-set-idle-time (timer secs &optional repeat) @@ -66,19 +80,11 @@ SECS may be an integer, floating point number, or the internal time format (HIGH LOW USECS) returned by, e.g., `current-idle-time'. If optional third argument REPEAT is non-nil, make the timer fire each time Emacs is idle for that many seconds." - (or (timerp timer) - (error "Invalid timer")) (if (consp secs) - (progn (aset timer 1 (car secs)) - (aset timer 2 (if (consp (cdr secs)) (car (cdr secs)) (cdr secs))) - (aset timer 3 (or (and (consp (cdr secs)) (consp (cdr (cdr secs))) - (nth 2 secs)) - 0))) - (aset timer 1 0) - (aset timer 2 0) - (aset timer 3 0) + (setf (timer--time timer) secs) + (setf (timer--time timer) '(0 0 0)) (timer-inc-time timer secs)) - (aset timer 4 repeat) + (setf (timer--repeat-delay timer) repeat) timer) (defun timer-next-integral-multiple-of-time (time secs) @@ -115,6 +121,7 @@ of SECS seconds since the epoch. SECS may be a fraction." (defun timer-relative-time (time secs &optional usecs) "Advance TIME by SECS seconds and optionally USECS microseconds. SECS may be either an integer or a floating point number." + ;; FIXME: we should just use (time-add time (list 0 secs usecs)) (let ((high (car time)) (low (if (consp (cdr time)) (nth 1 time) (cdr time))) (micro (if (numberp (car-safe (cdr-safe (cdr time)))) @@ -136,16 +143,22 @@ SECS may be either an integer or a floating point number." (list high low (and (/= micro 0) micro)))) +(defun timer--time-less-p (t1 t2) + "Say whether time value T1 is less than time value T2." + ;; FIXME just use time-less-p. + (destructuring-bind (high1 low1 micro1) (timer--time t1) + (destructuring-bind (high2 low2 micro2) (timer--time t2) + (or (< high1 high2) + (and (= high1 high2) + (or (< low1 low2) + (and (= low1 low2) + (< micro1 micro2)))))))) + (defun timer-inc-time (timer secs &optional usecs) "Increment the time set in TIMER by SECS seconds and USECS microseconds. SECS may be a fraction. If USECS is omitted, that means it is zero." - (let ((time (timer-relative-time - (list (aref timer 1) (aref timer 2) (aref timer 3)) - secs - usecs))) - (aset timer 1 (nth 0 time)) - (aset timer 2 (nth 1 time)) - (aset timer 3 (or (nth 2 time) 0)))) + (setf (timer--time timer) + (timer-relative-time (timer--time timer) secs usecs))) (defun timer-set-time-with-usecs (timer time usecs &optional delta) "Set the trigger time of TIMER to TIME plus USECS. @@ -153,12 +166,9 @@ TIME must be in the internal format returned by, e.g., `current-time'. The microsecond count from TIME is ignored, and USECS is used instead. If optional fourth argument DELTA is a positive number, make the timer fire repeatedly that many seconds apart." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 1 (nth 0 time)) - (aset timer 2 (nth 1 time)) - (aset timer 3 usecs) - (aset timer 4 (and (numberp delta) (> delta 0) delta)) + (setf (timer--time timer) time) + (setf (timer--usecs timer) usecs) + (setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta)) timer) (make-obsolete 'timer-set-time-with-usecs "use `timer-set-time' and `timer-inc-time' instead." @@ -168,34 +178,20 @@ fire repeatedly that many seconds apart." "Make TIMER call FUNCTION with optional ARGS when triggering." (or (timerp timer) (error "Invalid timer")) - (aset timer 5 function) - (aset timer 6 args) + (setf (timer--function timer) function) + (setf (timer--args timer) args) timer) -(defun timer-activate (timer &optional triggered-p reuse-cell) - "Put TIMER on the list of active timers. - -If TRIGGERED-P is t, that means to make the timer inactive -\(put it on the list, but mark it as already triggered). -To remove from the list, use `cancel-timer'. - -REUSE-CELL, if non-nil, is a cons cell to reuse instead -of allocating a new one." +(defun timer--activate (timer &optional triggered-p reuse-cell idle) (if (and (timerp timer) - (integerp (aref timer 1)) - (integerp (aref timer 2)) - (integerp (aref timer 3)) - (aref timer 5)) - (let ((timers timer-list) + (integerp (timer--high-seconds timer)) + (integerp (timer--low-seconds timer)) + (integerp (timer--usecs timer)) + (timer--function timer)) + (let ((timers (if idle timer-idle-list timer-list)) last) ;; Skip all timers to trigger before the new one. - (while (and timers - (or (> (aref timer 1) (aref (car timers) 1)) - (and (= (aref timer 1) (aref (car timers) 1)) - (> (aref timer 2) (aref (car timers) 2))) - (and (= (aref timer 1) (aref (car timers) 1)) - (= (aref timer 2) (aref (car timers) 2)) - (> (aref timer 3) (aref (car timers) 3))))) + (while (and timers (timer--time-less-p (car timers) timer)) (setq last timers timers (cdr timers))) (if reuse-cell @@ -206,12 +202,25 @@ of allocating a new one." ;; Insert new timer after last which possibly means in front of queue. (if last (setcdr last reuse-cell) - (setq timer-list reuse-cell)) - (aset timer 0 triggered-p) - (aset timer 7 nil) + (if idle + (setq timer-idle-list reuse-cell) + (setq timer-list reuse-cell))) + (setf (timer--triggered timer) triggered-p) + (setf (timer--idle-delay timer) idle) nil) (error "Invalid or uninitialized timer"))) +(defun timer-activate (timer &optional triggered-p reuse-cell idle) + "Put TIMER on the list of active timers. + +If TRIGGERED-P is t, that means to make the timer inactive +\(put it on the list, but mark it as already triggered). +To remove from the list, use `cancel-timer'. + +REUSE-CELL, if non-nil, is a cons cell to reuse instead +of allocating a new one." + (timer--activate timer triggered-p reuse-cell nil)) + (defun timer-activate-when-idle (timer &optional dont-wait reuse-cell) "Arrange to activate TIMER whenever Emacs is next idle. If optional argument DONT-WAIT is non-nil, then enable the @@ -220,40 +229,10 @@ is already idle. REUSE-CELL, if non-nil, is a cons cell to reuse instead of allocating a new one." - (if (and (timerp timer) - (integerp (aref timer 1)) - (integerp (aref timer 2)) - (integerp (aref timer 3)) - (aref timer 5)) - (let ((timers timer-idle-list) - last) - ;; Skip all timers to trigger before the new one. - (while (and timers - (or (> (aref timer 1) (aref (car timers) 1)) - (and (= (aref timer 1) (aref (car timers) 1)) - (> (aref timer 2) (aref (car timers) 2))) - (and (= (aref timer 1) (aref (car timers) 1)) - (= (aref timer 2) (aref (car timers) 2)) - (> (aref timer 3) (aref (car timers) 3))))) - (setq last timers - timers (cdr timers))) - (if reuse-cell - (progn - (setcar reuse-cell timer) - (setcdr reuse-cell timers)) - (setq reuse-cell (cons timer timers))) - ;; Insert new timer after last which possibly means in front of queue. - (if last - (setcdr last reuse-cell) - (setq timer-idle-list reuse-cell)) - (aset timer 0 (not dont-wait)) - (aset timer 7 t) - nil) - (error "Invalid or uninitialized timer"))) + (timer--activate timer (not dont-wait) reuse-cell 'idle)) -;;;###autoload (defalias 'disable-timeout 'cancel-timer) -;;;###autoload + (defun cancel-timer (timer) "Remove TIMER from the list of active timers." (or (timerp timer) @@ -274,22 +253,17 @@ that was removed from the timer list." (setq timer-idle-list (delq timer timer-idle-list))) (or cell1 cell2))) -;;;###autoload (defun cancel-function-timers (function) "Cancel all timers which would run FUNCTION. This affects ordinary timers such as are scheduled by `run-at-time', and idle timers such as are scheduled by `run-with-idle-timer'." (interactive "aCancel timers of function: ") - (let ((tail timer-list)) - (while tail - (if (eq (aref (car tail) 5) function) - (setq timer-list (delq (car tail) timer-list))) - (setq tail (cdr tail)))) - (let ((tail timer-idle-list)) - (while tail - (if (eq (aref (car tail) 5) function) - (setq timer-idle-list (delq (car tail) timer-idle-list))) - (setq tail (cdr tail))))) + (dolist (timer timer-list) + (if (eq (timer--function timer) function) + (setq timer-list (delq timer timer-list)))) + (dolist (timer timer-idle-list) + (if (eq (timer--function timer) function) + (setq timer-idle-list (delq timer timer-idle-list))))) ;; Record the last few events, for debugging. (defvar timer-event-last nil @@ -310,8 +284,9 @@ how many will really happen.") "Calculate number of seconds from when TIMER will run, until TIME. TIMER is a timer, and stands for the time when its next repeat is scheduled. TIME is a time-list." - (let ((high (- (car time) (aref timer 1))) - (low (- (nth 1 time) (aref timer 2)))) + ;; FIXME: (time-to-seconds (time-subtract (timer--time timer) time)) + (let ((high (- (car time) (timer--high-seconds timer))) + (low (- (nth 1 time) (timer--low-seconds timer)))) (+ low (* high 65536)))) (defun timer-event-handler (timer) @@ -326,29 +301,30 @@ This function is called, by name, directly by the C code." ;; Delete from queue. Record the cons cell that was used. (setq cell (cancel-timer-internal timer)) ;; Re-schedule if requested. - (if (aref timer 4) - (if (aref timer 7) + (if (timer--repeat-delay timer) + (if (timer--idle-delay timer) (timer-activate-when-idle timer nil cell) - (timer-inc-time timer (aref timer 4) 0) + (timer-inc-time timer (timer--repeat-delay timer) 0) ;; If real time has jumped forward, ;; perhaps because Emacs was suspended for a long time, ;; limit how many times things get repeated. (if (and (numberp timer-max-repeats) (< 0 (timer-until timer (current-time)))) (let ((repeats (/ (timer-until timer (current-time)) - (aref timer 4)))) + (timer--repeat-delay timer)))) (if (> repeats timer-max-repeats) - (timer-inc-time timer (* (aref timer 4) repeats))))) + (timer-inc-time timer (* (timer--repeat-delay timer) + repeats))))) (timer-activate timer t cell) (setq retrigger t))) ;; Run handler. ;; We do this after rescheduling so that the handler function ;; can cancel its own timer successfully with cancel-timer. (condition-case nil - (apply (aref timer 5) (aref timer 6)) + (apply (timer--function timer) (timer--args timer)) (error nil)) (if retrigger - (aset timer 0 nil))) + (setf (timer--triggered timer) nil))) (error "Bogus timer event")))) ;; This function is incompatible with the one in levents.el. @@ -356,7 +332,9 @@ This function is called, by name, directly by the C code." "Non-nil if EVENT is a timeout event." (and (listp event) (eq (car event) 'timer-event))) -;;;###autoload + +(declare-function diary-entry-time "diary-lib" (s)) + (defun run-at-time (time repeat function &rest args) "Perform an action at time TIME. Repeat the action every REPEAT seconds, if REPEAT is non-nil. @@ -418,7 +396,6 @@ This function returns a timer object which you can use in `cancel-timer'." (timer-activate timer) timer)) -;;;###autoload (defun run-with-timer (secs repeat function &rest args) "Perform an action after a delay of SECS seconds. Repeat the action every REPEAT seconds, if REPEAT is non-nil. @@ -429,14 +406,12 @@ This function returns a timer object which you can use in `cancel-timer'." (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ") (apply 'run-at-time secs repeat function args)) -;;;###autoload (defun add-timeout (secs function object &optional repeat) "Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT. If REPEAT is non-nil, repeat the timer every REPEAT seconds. This function is for compatibility; see also `run-with-timer'." (run-with-timer secs repeat function object)) -;;;###autoload (defun run-with-idle-timer (secs repeat function &rest args) "Perform an action the next time Emacs is idle for SECS seconds. The action is to call FUNCTION with arguments ARGS. @@ -463,12 +438,11 @@ This function returns a timer object which you can use in `cancel-timer'." "This is the timer function used for the timer made by `with-timeout'." (throw tag 'timeout)) -;;;###autoload (put 'with-timeout 'lisp-indent-function 1) +(put 'with-timeout 'lisp-indent-function 1) (defvar with-timeout-timers nil "List of all timers used by currently pending `with-timeout' calls.") -;;;###autoload (defmacro with-timeout (list &rest body) "Run BODY, but if it doesn't finish in SECONDS seconds, give up. If we give up, we run the TIMEOUT-FORMS and return the value of the last one. @@ -504,11 +478,7 @@ The value is a list that the debugger can pass to `with-timeout-unsuspend' when it exits, to make these timers start counting again." (mapcar (lambda (timer) (cancel-timer timer) - (list timer - (time-subtract - ;; The time that this timer will go off. - (list (aref timer 1) (aref timer 2) (aref timer 3)) - (current-time)))) + (list timer (time-subtract (timer--time timer) (current-time)))) with-timeout-timers)) (defun with-timeout-unsuspend (timer-spec-list) @@ -569,5 +539,5 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." (provide 'timer) -;;; arch-tag: b1a9237b-7787-4382-9e46-8f2c3b3273e0 +;; arch-tag: b1a9237b-7787-4382-9e46-8f2c3b3273e0 ;;; timer.el ends here |