summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/lisp.el80
-rw-r--r--lisp/emacs-lisp/nadvice.el24
-rw-r--r--lisp/emacs-lisp/timer.el151
-rw-r--r--lisp/emacs-lisp/trace.el11
4 files changed, 161 insertions, 105 deletions
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index 22fb6ad1809..f301a1875ed 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -46,6 +46,12 @@ This affects `insert-parentheses' and `insert-pair'."
:group 'lisp)
(defvar forward-sexp-function nil
+ ;; FIXME:
+ ;; - for some uses, we may want a "sexp-only" version, which only
+ ;; jumps over a well-formed sexp, rather than some dwimish thing
+ ;; like jumping from an "else" back up to its "if".
+ ;; - for up-list, we could use the "sexp-only" behavior as well
+ ;; to treat the dwimish halfsexp as a form of "up-list" step.
"If non-nil, `forward-sexp' delegates to this function.
Should take the same arguments and behave similarly to `forward-sexp'.")
@@ -618,9 +624,10 @@ character."
;; "Unbalanced parentheses", but those may not be so
;; accurate/helpful, e.g. quotes may actually be
;; mismatched.
- (error "Unmatched bracket or quote"))))
+ (user-error "Unmatched bracket or quote"))))
(defun field-complete (table &optional predicate)
+ (declare (obsolete completion-in-region "24.4"))
(let ((minibuffer-completion-table table)
(minibuffer-completion-predicate predicate)
;; This made sense for lisp-complete-symbol, but for
@@ -645,6 +652,7 @@ considered. If the symbol starts just after an open-parenthesis, only
symbols with function definitions are considered. Otherwise, all
symbols with function definitions, values or properties are
considered."
+ (declare (obsolete completion-at-point "24.4"))
(interactive)
(let* ((data (lisp-completion-at-point predicate))
(plist (nthcdr 3 data)))
@@ -666,25 +674,6 @@ considered."
(skip-syntax-forward "'")
(point))
(scan-error pos)))
- (predicate
- (or predicate
- (save-excursion
- (goto-char beg)
- (if (not (eq (char-before) ?\())
- (lambda (sym) ;why not just nil ? -sm
- (or (boundp sym) (fboundp sym)
- (symbol-plist sym)))
- ;; Looks like a funcall position. Let's double check.
- (if (condition-case nil
- (progn (up-list -2) (forward-char 1)
- (eq (char-after) ?\())
- (error nil))
- ;; If the first element of the parent list is an open
- ;; paren we are probably not in a funcall position.
- ;; Maybe a `let' varlist or something.
- nil
- ;; Else, we assume that a function name is expected.
- 'fboundp)))))
(end
(unless (or (eq beg (point-max))
(member (char-syntax (char-after beg)) '(?\" ?\( ?\))))
@@ -694,12 +683,51 @@ considered."
(forward-sexp 1)
(when (>= (point) pos)
(point)))
- (scan-error pos)))))
+ (scan-error pos))))
+ (funpos (eq (char-before beg) ?\()) ;t if in function position.
+ (table-etc
+ (if (not funpos)
+ ;; FIXME: We could look at the first element of the list and
+ ;; use it to provide a more specific completion table in some
+ ;; cases. E.g. filter out keywords that are not understood by
+ ;; the macro/function being called.
+ (list nil obarray ;Could be anything.
+ :annotation-function
+ (lambda (str) (if (fboundp (intern-soft str)) " <f>")))
+ ;; Looks like a funcall position. Let's double check.
+ (save-excursion
+ (goto-char (1- beg))
+ (let ((parent
+ (condition-case nil
+ (progn (up-list -1) (forward-char 1)
+ (let ((c (char-after)))
+ (if (eq c ?\() ?\(
+ (if (memq (char-syntax c) '(?w ?_))
+ (read (current-buffer))))))
+ (error nil))))
+ (pcase parent
+ ;; FIXME: Rather than hardcode special cases here,
+ ;; we should use something like a symbol-property.
+ (`declare
+ (list t (mapcar (lambda (x) (symbol-name (car x)))
+ (delete-dups
+ (append
+ macro-declarations-alist
+ defun-declarations-alist)))))
+ ((or `condition-case `condition-case-unless-debug)
+ (list t obarray
+ :predicate (lambda (sym) (get sym 'error-conditions))))
+ (_ (list nil obarray #'fboundp))))))))
(when end
- (list beg end obarray
- :predicate predicate
- :annotation-function
- (unless (eq predicate 'fboundp)
- (lambda (str) (if (fboundp (intern-soft str)) " <f>"))))))))
+ (let ((tail (if (null (car table-etc))
+ (cdr table-etc)
+ (cons
+ (if (memq (char-syntax (char-after end))
+ '(?\s ?>))
+ (cadr table-etc)
+ (apply-partially 'completion-table-with-terminator
+ " " (cadr table-etc)))
+ (cddr table-etc)))))
+ `(,beg ,end ,@tail))))))
;;; lisp.el ends here
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 0632c7d2fc0..a3dfb0326e6 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -44,7 +44,9 @@
(:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4)
(:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4)
(:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4)
- (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4))
+ (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)
+ (:filter-args "\300\302\301!\"\207" 5)
+ (:filter-return "\301\300\302\"!\207" 5))
"List of descriptions of how to add a function.
Each element has the form (WHERE BYTECODE STACK) where:
WHERE is a keyword indicating where the function is added.
@@ -158,11 +160,12 @@ WHERE is a symbol to select an entry in `advice--where-alist'."
(advice--make-1 (nth 1 desc) (nth 2 desc)
function main props)))
-(defun advice--member-p (function definition)
+(defun advice--member-p (function name definition)
(let ((found nil))
(while (and (not found) (advice--p definition))
(if (or (equal function (advice--car definition))
- (equal function (cdr (assq 'name (advice--props definition)))))
+ (when name
+ (equal name (cdr (assq 'name (advice--props definition))))))
(setq found t)
(setq definition (advice--cdr definition))))
found))
@@ -207,7 +210,6 @@ WHERE is a symbol to select an entry in `advice--where-alist'."
;;;###autoload
(defmacro add-function (where place function &optional props)
;; TODO:
- ;; - obsolete with-wrapper-hook (mostly requires buffer-local support).
;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP
;; and tracing want to stay first.
;; - maybe let `where' specify some kind of predicate and use it
@@ -230,14 +232,15 @@ call OLDFUN here:
`:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r)))
`:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r)))
`:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r)))
+`:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r)))
+`:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r)))
If FUNCTION was already added, do nothing.
PROPS is an alist of additional properties, among which the following have
a special meaning:
- `name': a string or symbol. It can be used to refer to this piece of advice.
-PLACE cannot be a simple variable. Instead it should either be
-\(default-value 'VAR) or (local 'VAR) depending on whether FUNCTION
-should be applied to VAR buffer-locally or globally.
+If PLACE is a simple variable, only its global value will be affected.
+Use (local 'VAR) if you want to apply FUNCTION to VAR buffer-locally.
If one of FUNCTION or OLDFUN is interactive, then the resulting function
is also interactive. There are 3 cases:
@@ -250,12 +253,13 @@ is also interactive. There are 3 cases:
(cond ((eq 'local (car-safe place))
(setq place `(advice--buffer-local ,@(cdr place))))
((symbolp place)
- (error "Use (default-value '%S) or (local '%S)" place place)))
+ (setq place `(default-value ',place))))
`(advice--add-function ,where (gv-ref ,place) ,function ,props))
;;;###autoload
(defun advice--add-function (where ref function props)
- (unless (advice--member-p function (gv-deref ref))
+ (unless (advice--member-p function (cdr (assq 'name props))
+ (gv-deref ref))
(setf (gv-deref ref)
(advice--make where function (gv-deref ref) props))))
@@ -396,7 +400,7 @@ of the piece of advice."
"Return non-nil if ADVICE has been added to FUNCTION-NAME.
Instead of ADVICE being the actual function, it can also be the `name'
of the piece of advice."
- (advice--member-p advice
+ (advice--member-p advice advice
(or (get function-name 'advice--pending)
(advice--strip-macro
(if (fboundp function-name)
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index 8b1dca8cb78..a1bba2ddb6e 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -27,27 +27,34 @@
;;; Code:
-;; Layout of a timer vector:
-;; [triggered-p high-seconds low-seconds usecs repeat-delay
-;; function args idle-delay psecs]
-;; triggered-p is nil if the timer is active (waiting to be triggered),
-;; t if it is inactive ("already triggered", in theory)
-
(eval-when-compile (require 'cl-lib))
(cl-defstruct (timer
- (:constructor nil)
- (:copier nil)
- (:constructor timer-create ())
- (:type vector)
- (:conc-name timer--))
+ (:constructor nil)
+ (:copier nil)
+ (:constructor timer-create ())
+ (:type vector)
+ (:conc-name timer--))
+ ;; nil if the timer is active (waiting to be triggered),
+ ;; non-nil if it is inactive ("already triggered", in theory).
(triggered t)
- high-seconds low-seconds usecs repeat-delay function args idle-delay psecs)
+ ;; Time of next trigger: for normal timers, absolute time, for idle timers,
+ ;; time relative to idle-start.
+ high-seconds low-seconds usecs
+ ;; For normal timers, time between repetitions, or nil. For idle timers,
+ ;; non-nil iff repeated.
+ repeat-delay
+ function args ;What to do when triggered.
+ idle-delay ;If non-nil, this is an idle-timer.
+ psecs)
(defun timerp (object)
"Return t if OBJECT is a timer."
(and (vectorp object) (= (length object) 9)))
+(defsubst timer--check (timer)
+ (or (timerp timer) (signal 'wrong-type-argument (list #'timerp timer))))
+
;; Pseudo field `time'.
(defun timer--time (timer)
(list (timer--high-seconds timer)
@@ -57,17 +64,17 @@
(gv-define-simple-setter timer--time
(lambda (timer time)
- (or (timerp timer) (error "Invalid timer"))
+ (timer--check timer)
(setf (timer--high-seconds timer) (pop time))
(let ((low time) (usecs 0) (psecs 0))
(if (consp time)
- (progn
- (setq low (pop time))
- (if time
- (progn
- (setq usecs (pop time))
- (if time
- (setq psecs (car time)))))))
+ (progn
+ (setq low (pop time))
+ (if time
+ (progn
+ (setq usecs (pop time))
+ (if time
+ (setq psecs (car time)))))))
(setf (timer--low-seconds timer) low)
(setf (timer--usecs timer) usecs)
(setf (timer--psecs timer) psecs))))
@@ -83,15 +90,13 @@ fire repeatedly that many seconds apart."
timer)
(defun timer-set-idle-time (timer secs &optional repeat)
+ ;; FIXME: Merge with timer-set-time.
"Set the trigger idle time of TIMER to SECS.
SECS may be an integer, floating point number, or the internal
time format 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."
- (if (consp secs)
- (setf (timer--time timer) secs)
- (setf (timer--time timer) '(0 0 0))
- (timer-inc-time timer secs))
+ (setf (timer--time timer) (if (consp secs) secs (seconds-to-time secs)))
(setf (timer--repeat-delay timer) repeat)
timer)
@@ -156,8 +161,7 @@ fire repeatedly that many seconds apart."
(defun timer-set-function (timer function &optional args)
"Make TIMER call FUNCTION with optional ARGS when triggering."
- (or (timerp timer)
- (error "Invalid timer"))
+ (timer--check timer)
(setf (timer--function timer) function)
(setf (timer--args timer) args)
timer)
@@ -181,9 +185,10 @@ fire repeatedly that many seconds apart."
(setcdr reuse-cell timers))
(setq reuse-cell (cons timer timers)))
;; Insert new timer after last which possibly means in front of queue.
- (cond (last (setcdr last reuse-cell))
- (idle (setq timer-idle-list reuse-cell))
- (t (setq timer-list reuse-cell)))
+ (setf (cond (last (cdr last))
+ (idle timer-idle-list)
+ (t timer-list))
+ reuse-cell)
(setf (timer--triggered timer) triggered-p)
(setf (timer--idle-delay timer) idle)
nil)
@@ -223,8 +228,7 @@ timer will fire right away."
(defun cancel-timer (timer)
"Remove TIMER from the list of active timers."
- (or (timerp timer)
- (error "Invalid timer"))
+ (timer--check timer)
(setq timer-list (delq timer timer-list))
(setq timer-idle-list (delq timer timer-idle-list))
nil)
@@ -283,44 +287,47 @@ This function is called, by name, directly by the C code."
(setq timer-event-last-1 timer-event-last)
(setq timer-event-last timer)
(let ((inhibit-quit t))
- (if (timerp timer)
- (let (retrigger cell)
- ;; Delete from queue. Record the cons cell that was used.
- (setq cell (cancel-timer-internal timer))
- ;; Re-schedule if requested.
- (if (timer--repeat-delay timer)
- (if (timer--idle-delay timer)
- (timer-activate-when-idle timer nil cell)
- (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))
- (timer--repeat-delay timer))))
- (if (> repeats timer-max-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-unless-debug err
- ;; Timer functions should not change the current buffer.
- ;; If they do, all kinds of nasty surprises can happen,
- ;; and it can be hellish to track down their source.
- (save-current-buffer
- (apply (timer--function timer) (timer--args timer)))
- (error (message "Error in timer: %S" err)))
- (when (and retrigger
- ;; If the timer's been canceled, don't "retrigger" it
- ;; since it might still be in the copy of timer-list kept
- ;; by keyboard.c:timer_check (bug#14156).
- (memq timer timer-list))
- (setf (timer--triggered timer) nil)))
- (error "Bogus timer event"))))
+ (timer--check timer)
+ (let ((retrigger nil)
+ (cell
+ ;; Delete from queue. Record the cons cell that was used.
+ (cancel-timer-internal timer)))
+ ;; Re-schedule if requested.
+ (if (timer--repeat-delay timer)
+ (if (timer--idle-delay timer)
+ (timer-activate-when-idle timer nil cell)
+ (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))
+ (timer--repeat-delay timer))))
+ (if (> repeats timer-max-repeats)
+ (timer-inc-time timer (* (timer--repeat-delay timer)
+ repeats)))))
+ ;; Place it back on the timer-list before running
+ ;; timer--function, so it can cancel-timer itself.
+ (timer-activate timer t cell)
+ (setq retrigger t)))
+ ;; Run handler.
+ (condition-case-unless-debug err
+ ;; Timer functions should not change the current buffer.
+ ;; If they do, all kinds of nasty surprises can happen,
+ ;; and it can be hellish to track down their source.
+ (save-current-buffer
+ (apply (timer--function timer) (timer--args timer)))
+ (error (message "Error running timer%s: %S"
+ (if (symbolp (timer--function timer))
+ (format " `%s'" (timer--function timer)) "")
+ err)))
+ (when (and retrigger
+ ;; If the timer's been canceled, don't "retrigger" it
+ ;; since it might still be in the copy of timer-list kept
+ ;; by keyboard.c:timer_check (bug#14156).
+ (memq timer timer-list))
+ (setf (timer--triggered timer) nil)))))
;; This function is incompatible with the one in levents.el.
(defun timeout-event-p (event)
@@ -531,6 +538,12 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE."
secs
(if (string-match-p "\\`[0-9.]+\\'" string)
(string-to-number string)))))
+
+(defun internal-timer-start-idle ()
+ "Mark all idle-time timers as once again candidates for running."
+ (dolist (timer timer-idle-list)
+ (if (timerp timer) ;; FIXME: Why test?
+ (setf (timer--triggered timer) nil))))
(provide 'timer)
diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el
index 09c4969cf18..fce8643923f 100644
--- a/lisp/emacs-lisp/trace.el
+++ b/lisp/emacs-lisp/trace.el
@@ -157,6 +157,17 @@
(defvar inhibit-trace nil
"If non-nil, all tracing is temporarily inhibited.")
+;;;###autoload
+(defun trace-values (&rest values)
+ "Helper function to get internal values.
+You can call this function to add internal values in the trace buffer."
+ (unless inhibit-trace
+ (with-current-buffer trace-buffer
+ (goto-char (point-max))
+ (insert
+ (trace-entry-message
+ 'trace-values trace-level values "")))))
+
(defun trace-entry-message (function level args context)
"Generate a string that describes that FUNCTION has been entered.
LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION,
generated by cgit v1.2.3 (git 2.39.1) at 2025-07-01 09:02:47 +0000