diff options
Diffstat (limited to 'lisp/subr.el')
| -rw-r--r-- | lisp/subr.el | 848 |
1 files changed, 625 insertions, 223 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index d9df8d1a458..90dbfc75d52 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1,7 +1,6 @@ ;;; subr.el --- basic lisp subroutines for Emacs -*- lexical-binding:t -*- -;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2024 Free Software -;; Foundation, Inc. +;; Copyright (C) 1985-2024 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal @@ -205,6 +204,7 @@ buffer-local wherever it is set." (defun buffer-local-boundp (symbol buffer) "Return non-nil if SYMBOL is bound in BUFFER. Also see `local-variable-p'." + (declare (side-effect-free t)) (condition-case nil (buffer-local-value symbol buffer) (:success t) @@ -276,25 +276,56 @@ change the list." (macroexp-let2 macroexp-copyable-p x getter `(prog1 ,x ,(funcall setter `(cdr ,x)))))))) +;; Note: `static-if' can be copied into a package to enable it to be +;; used in Emacsen older than Emacs 30.1. If the package is used in +;; very old Emacsen or XEmacs (in which `eval' takes exactly one +;; argument) the copy will need amending. +(defmacro static-if (condition then-form &rest else-forms) + "A conditional compilation macro. +Evaluate CONDITION at macro-expansion time. If it is non-nil, +expand the macro to THEN-FORM. Otherwise expand it to ELSE-FORMS +enclosed in a `progn' form. ELSE-FORMS may be empty." + (declare (indent 2) + (debug (sexp sexp &rest sexp))) + (if (eval condition lexical-binding) + then-form + (cons 'progn else-forms))) + (defmacro when (cond &rest body) "If COND yields non-nil, do BODY, else return nil. When COND yields non-nil, eval BODY forms sequentially and return value of last one, or nil if there are none." (declare (indent 1) (debug t)) - (list 'if cond (cons 'progn body))) + (if body + (list 'if cond (cons 'progn body)) + (macroexp-warn-and-return (format-message "`when' with empty body") + cond '(empty-body when) t))) (defmacro unless (cond &rest body) "If COND yields nil, do BODY, else return nil. When COND yields nil, eval BODY forms sequentially and return value of last one, or nil if there are none." (declare (indent 1) (debug t)) - (cons 'if (cons cond (cons nil body)))) + (if body + (cons 'if (cons cond (cons nil body))) + (macroexp-warn-and-return (format-message "`unless' with empty body") + cond '(empty-body unless) t))) (defsubst subr-primitive-p (object) - "Return t if OBJECT is a built-in primitive function." + "Return t if OBJECT is a built-in primitive written in C. +Such objects can be functions or special forms." + (declare (side-effect-free error-free)) (and (subrp object) (not (subr-native-elisp-p object)))) +(defsubst primitive-function-p (object) + "Return t if OBJECT is a built-in primitive function. +This excludes special forms, since they are not functions." + (declare (side-effect-free error-free)) + (and (subrp object) + (not (or (subr-native-elisp-p object) + (eq (cdr (subr-arity object)) 'unevalled))))) + (defsubst xor (cond1 cond2) "Return the boolean exclusive-or of COND1 and COND2. If only one of the arguments is non-nil, return it; otherwise @@ -381,9 +412,24 @@ without silencing all errors." "Execute BODY; if the error CONDITION occurs, return nil. Otherwise, return result of last form in BODY. -CONDITION can also be a list of error conditions." +CONDITION can also be a list of error conditions. +The CONDITION argument is not evaluated. Do not quote it." (declare (debug t) (indent 1)) - `(condition-case nil (progn ,@body) (,condition nil))) + (cond + ((and (eq (car-safe condition) 'quote) + (cdr condition) (null (cddr condition))) + (macroexp-warn-and-return + (format-message + "`ignore-error' condition argument should not be quoted: %S" + condition) + `(condition-case nil (progn ,@body) (,(cadr condition) nil)) + nil t condition)) + (body + `(condition-case nil (progn ,@body) (,condition nil))) + (t + (macroexp-warn-and-return (format-message "`ignore-error' with empty body") + nil '(empty-body ignore-error) t condition)))) + ;;;; Basic Lisp functions. @@ -394,6 +440,7 @@ CONDITION can also be a list of error conditions." "Return a new uninterned symbol. The name is made by appending `gensym-counter' to PREFIX. PREFIX is a string, and defaults to \"g\"." + (declare (important-return-value t)) (let ((num (prog1 gensym-counter (setq gensym-counter (1+ gensym-counter))))) (make-symbol (format "%s%d" (or prefix "g") num)))) @@ -402,7 +449,9 @@ PREFIX is a string, and defaults to \"g\"." "Ignore ARGUMENTS, do nothing, and return nil. This function accepts any number of arguments in ARGUMENTS. Also see `always'." - (declare (completion ignore)) + ;; Not declared `side-effect-free' because we don't want calls to it + ;; elided; see `byte-compile-ignore'. + (declare (pure t) (completion ignore)) (interactive) nil) @@ -410,6 +459,7 @@ Also see `always'." "Ignore ARGUMENTS, do nothing, and return t. This function accepts any number of arguments in ARGUMENTS. Also see `ignore'." + (declare (pure t) (side-effect-free error-free)) t) ;; Signal a compile-error if the first arg is missing. @@ -477,6 +527,7 @@ Defaults to `error'." "Return non-nil if OBJECT seems to be a frame configuration. Any list whose car is `frame-configuration' is assumed to be a frame configuration." + (declare (pure t) (side-effect-free error-free)) (and (consp object) (eq (car object) 'frame-configuration))) @@ -486,6 +537,7 @@ ARGS is a list of the first N arguments to pass to FUN. The result is a new function which does the same as FUN, except that the first N arguments are fixed at the values with which this function was called." + (declare (side-effect-free error-free)) (lambda (&rest args2) (apply fun (append args args2)))) @@ -493,16 +545,19 @@ was called." "Return t if NUMBER is zero." ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because ;; = has a byte-code. - (declare (compiler-macro (lambda (_) `(= 0 ,number)))) + (declare (pure t) (side-effect-free t) + (compiler-macro (lambda (_) `(= 0 ,number)))) (= 0 number)) (defun fixnump (object) "Return t if OBJECT is a fixnum." + (declare (side-effect-free error-free)) (and (integerp object) (<= most-negative-fixnum object most-positive-fixnum))) (defun bignump (object) "Return t if OBJECT is a bignum." + (declare (side-effect-free error-free)) (and (integerp object) (not (fixnump object)))) (defun lsh (value count) @@ -517,8 +572,10 @@ if, when COUNT is negative, your program really needs the special treatment of negative COUNT provided by this function." (declare (compiler-macro (lambda (form) - (macroexp-warn-and-return "avoid `lsh'; use `ash' instead" - form '(suspicious lsh) t form)))) + (macroexp-warn-and-return + (format-message "avoid `lsh'; use `ash' instead") + form '(suspicious lsh) t form))) + (side-effect-free t)) (when (and (< value 0) (< count 0)) (when (< value most-negative-fixnum) (signal 'args-out-of-range (list value count))) @@ -691,7 +748,7 @@ treatment of negative COUNT provided by this function." If LIST is nil, return nil. If N is non-nil, return the Nth-to-last link of LIST. If N is bigger than the length of LIST, return LIST." - (declare (side-effect-free t)) + (declare (pure t) (side-effect-free t)) ; pure up to mutation (if n (and (>= n 0) (let ((m (safe-length list))) @@ -746,7 +803,9 @@ one is kept. See `seq-uniq' for non-destructive operation." (defun delete-consecutive-dups (list &optional circular) "Destructively remove `equal' consecutive duplicates from LIST. First and last elements are considered consecutive if CIRCULAR is -non-nil." +non-nil. +Of several consecutive `equal' occurrences, the one earliest in +the list is kept." (let ((tail list) last) (while (cdr tail) (if (equal (car tail) (cadr tail)) @@ -782,6 +841,7 @@ TO as (+ FROM (* N INC)) or use a variable whose value was computed with this exact expression. Alternatively, you can, of course, also replace TO with a slightly larger value \(or a slightly more negative value if INC is negative)." + (declare (side-effect-free t)) (if (or (not to) (= from to)) (list from) (or inc (setq inc 1)) @@ -798,27 +858,34 @@ of course, also replace TO with a slightly larger value next (+ from (* n inc))))) (nreverse seq)))) -(defun copy-tree (tree &optional vecp) +(defun copy-tree (tree &optional vectors-and-records) "Make a copy of TREE. If TREE is a cons cell, this recursively copies both its car and its cdr. -Contrast to `copy-sequence', which copies only along the cdrs. With second -argument VECP, this copies vectors as well as conses." +Contrast to `copy-sequence', which copies only along the cdrs. +With the second argument VECTORS-AND-RECORDS non-nil, this +traverses and copies vectors and records as well as conses." + (declare (side-effect-free error-free)) (if (consp tree) (let (result) (while (consp tree) (let ((newcar (car tree))) - (if (or (consp (car tree)) (and vecp (vectorp (car tree)))) - (setq newcar (copy-tree (car tree) vecp))) + (if (or (consp (car tree)) + (and vectors-and-records + (or (vectorp (car tree)) (recordp (car tree))))) + (setq newcar (copy-tree (car tree) vectors-and-records))) (push newcar result)) (setq tree (cdr tree))) (nconc (nreverse result) - (if (and vecp (vectorp tree)) (copy-tree tree vecp) tree))) - (if (and vecp (vectorp tree)) + (if (and vectors-and-records (or (vectorp tree) (recordp tree))) + (copy-tree tree vectors-and-records) + tree))) + (if (and vectors-and-records (or (vectorp tree) (recordp tree))) (let ((i (length (setq tree (copy-sequence tree))))) (while (>= (setq i (1- i)) 0) - (aset tree i (copy-tree (aref tree i) vecp))) + (aset tree i (copy-tree (aref tree i) vectors-and-records))) tree) tree))) + ;;;; Various list-search functions. @@ -834,6 +901,7 @@ If that is non-nil, the element matches; then `assoc-default' If no element matches, the value is nil. If TEST is omitted or nil, `equal' is used." + (declare (important-return-value t)) (let (found (tail alist) value) (while (and tail (not found)) (let ((elt (car tail))) @@ -859,6 +927,7 @@ Non-strings in LIST are ignored." Compare keys with TEST. Defaults to `equal'. Return the modified alist. Elements of ALIST that are not conses are ignored." + (declare (important-return-value t)) (unless test (setq test #'equal)) (while (and (consp (car alist)) (funcall test (caar alist) key)) @@ -875,12 +944,14 @@ Elements of ALIST that are not conses are ignored." "Delete from ALIST all elements whose car is `eq' to KEY. Return the modified alist. Elements of ALIST that are not conses are ignored." + (declare (important-return-value t)) (assoc-delete-all key alist #'eq)) (defun rassq-delete-all (value alist) "Delete from ALIST all elements whose cdr is `eq' to VALUE. Return the modified alist. Elements of ALIST that are not conses are ignored." + (declare (important-return-value t)) (while (and (consp (car alist)) (eq (cdr (car alist)) value)) (setq alist (cdr alist))) @@ -923,6 +994,7 @@ Example: (setf (alist-get \\='b foo nil \\='remove) nil) foo => ((a . 1))" + (declare (important-return-value t)) (ignore remove) ;;Silence byte-compiler. (let ((x (if (not testfn) (assq key alist) @@ -935,11 +1007,11 @@ SEQ must be a list, vector, or string. The comparison is done with `equal'. Contrary to `delete', this does not use side-effects, and the argument SEQ is not modified." (declare (side-effect-free t)) - (if (nlistp seq) - ;; If SEQ isn't a list, there's no need to copy SEQ because - ;; `delete' will return a new object. - (delete elt seq) - (delete elt (copy-sequence seq)))) + (delete elt (if (nlistp seq) + ;; If SEQ isn't a list, there's no need to copy SEQ because + ;; `delete' will return a new object. + seq + (copy-sequence seq)))) (defun remq (elt list) "Return LIST with all occurrences of ELT removed. @@ -1038,6 +1110,7 @@ any corresponding binding in PARENT, but it does not override corresponding bindings in other keymaps of MAPS. MAPS can be a list of keymaps or a single keymap. PARENT if non-nil should be a keymap." + (declare (side-effect-free t)) `(keymap ,@(if (keymapp maps) (list maps) maps) ,@parent)) @@ -1178,6 +1251,7 @@ This resolves inheritance and redefinitions. The returned keymap should behave identically to a copy of KEYMAP w.r.t `lookup-key' and use in active keymaps and menus. Subkeymaps may be modified but are not canonicalized." + (declare (important-return-value t)) ;; FIXME: Problem with the difference between a nil binding ;; that hides a binding in an inherited map and a nil binding that's ignored ;; to let some further binding visible. Currently a nil binding hides all. @@ -1500,6 +1574,7 @@ See also `current-global-map'.") (defun listify-key-sequence (key) "Convert a key sequence to a list of events." + (declare (side-effect-free t)) (if (vectorp key) (append key nil) (mapcar (lambda (c) @@ -1510,6 +1585,7 @@ See also `current-global-map'.") (defun eventp (object) "Return non-nil if OBJECT is an input event or event object." + (declare (pure t) (side-effect-free error-free)) (or (integerp object) (and (if (consp object) (setq object (car object)) @@ -1526,6 +1602,7 @@ EVENT may be an event or an event type. If EVENT is a symbol that has never been used in an event that has been read as input in the current Emacs session, then this function may fail to include the `click' modifier." + (declare (side-effect-free t)) (unless (stringp event) (let ((type event)) (if (listp type) @@ -1559,6 +1636,7 @@ The value is a printing character (not upper case) or a symbol. EVENT may be an event or an event type. If EVENT is a symbol that has never been used in an event that has been read as input in the current Emacs session, then this function may return nil." + (declare (side-effect-free t)) (unless (stringp event) (if (consp event) (setq event (car event))) @@ -1574,10 +1652,12 @@ in the current Emacs session, then this function may return nil." (defsubst mouse-movement-p (object) "Return non-nil if OBJECT is a mouse movement event." + (declare (side-effect-free error-free)) (eq (car-safe object) 'mouse-movement)) (defun mouse-event-p (object) "Return non-nil if OBJECT is a mouse click event." + (declare (side-effect-free t)) ;; is this really correct? maybe remove mouse-movement? (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement))) @@ -1600,8 +1680,9 @@ in the current Emacs session, then this function may return nil." (defun event-start (event) "Return the starting position of EVENT. -EVENT should be a mouse click, drag, or key press event. If -EVENT is nil, the value of `posn-at-point' is used instead. +EVENT should be a mouse click, drag, touch screen, or key press +event. If EVENT is nil, the value of `posn-at-point' is used +instead. The following accessor functions are used to access the elements of the position: @@ -1623,25 +1704,46 @@ nil or (STRING . POSITION)'. `posn-timestamp': The time the event occurred, in milliseconds. For more information, see Info node `(elisp)Click Events'." - (or (and (consp event) (nth 1 event)) - (event--posn-at-point))) + (declare (side-effect-free t)) + (if (and (consp event) + (or (eq (car event) 'touchscreen-begin) + (eq (car event) 'touchscreen-end))) + ;; Touch screen begin and end events save their information in a + ;; different format, where the mouse position list is the cdr of + ;; (nth 1 event). + (cdadr event) + (or (and (consp event) + ;; Ignore touchscreen update events. They store the posn + ;; in a different format, and can have multiple posns. + (not (eq (car event) 'touchscreen-update)) + (nth 1 event)) + (event--posn-at-point)))) (defun event-end (event) "Return the ending position of EVENT. -EVENT should be a click, drag, or key press event. +EVENT should be a click, drag, touch screen, or key press event. See `event-start' for a description of the value returned." - (or (and (consp event) (nth (if (consp (nth 2 event)) 2 1) event)) - (event--posn-at-point))) + (declare (side-effect-free t)) + (if (and (consp event) + (or (eq (car event) 'touchscreen-begin) + (eq (car event) 'touchscreen-end))) + (cdadr event) + (or (and (consp event) + (not (eq (car event) 'touchscreen-update)) + (nth (if (consp (nth 2 event)) 2 1) event)) + (event--posn-at-point)))) (defsubst event-click-count (event) "Return the multi-click count of EVENT, a click or drag event. The return value is a positive integer." + (declare (side-effect-free t)) (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1)) (defsubst event-line-count (event) "Return the line count of EVENT, a mousewheel event. The return value is a positive integer." + (declare (side-effect-free t)) (if (and (consp event) (integerp (nth 3 event))) (nth 3 event) 1)) ;;;; Extracting fields of the positions in an event. @@ -1651,6 +1753,7 @@ The return value is a positive integer." A `posn' object is returned from functions such as `event-start'. If OBJ is a valid `posn' object, but specifies a frame rather than a window, return nil." + (declare (side-effect-free error-free)) ;; FIXME: Correct the behavior of this function so that all valid ;; `posn' objects are recognized, after updating other code that ;; depends on its present behavior. @@ -1664,12 +1767,14 @@ than a window, return nil." If POSITION is outside the frame where the event was initiated, return that frame instead. POSITION should be a list of the form returned by the `event-start' and `event-end' functions." + (declare (side-effect-free t)) (nth 0 position)) (defsubst posn-area (position) "Return the window area recorded in POSITION, or nil for the text area. POSITION should be a list of the form returned by the `event-start' and `event-end' functions." + (declare (side-effect-free t)) (let ((area (if (consp (nth 1 position)) (car (nth 1 position)) (nth 1 position)))) @@ -1681,6 +1786,7 @@ POSITION should be a list of the form returned by the `event-start' and `event-end' functions. Returns nil if POSITION does not correspond to any buffer location (e.g. a click on a scroll bar)." + (declare (side-effect-free t)) (or (nth 5 position) (let ((pt (nth 1 position))) (or (car-safe pt) @@ -1706,6 +1812,7 @@ Select the corresponding window as well." The return value has the form (X . Y), where X and Y are given in pixels. POSITION should be a list of the form returned by `event-start' and `event-end'." + (declare (side-effect-free t)) (nth 2 position)) (declare-function scroll-bar-scale "scroll-bar" (num-denom whole)) @@ -1725,6 +1832,7 @@ corresponds to the vertical position of the click in the scroll bar. POSITION should be a list of the form returned by the `event-start' and `event-end' functions." + (declare (side-effect-free t)) (let* ((pair (posn-x-y position)) (frame-or-window (posn-window position)) (frame (if (framep frame-or-window) @@ -1770,12 +1878,14 @@ This function does not account for the width on display, like the number of visual columns taken by a TAB or image. If you need the coordinates of POSITION in character units, you should use `posn-col-row', not this function." + (declare (side-effect-free t)) (nth 6 position)) (defsubst posn-timestamp (position) "Return the timestamp of POSITION. POSITION should be a list of the form returned by the `event-start' and `event-end' functions." + (declare (side-effect-free t)) (nth 3 position)) (defun posn-string (position) @@ -1783,6 +1893,7 @@ and `event-end' functions." Value is a cons (STRING . STRING-POS), or nil if not a string. POSITION should be a list of the form returned by the `event-start' and `event-end' functions." + (declare (side-effect-free t)) (let ((x (nth 4 position))) ;; Apparently this can also be `handle' or `below-handle' (bug#13979). (when (consp x) x))) @@ -1792,6 +1903,7 @@ and `event-end' functions." Value is a list (image ...), or nil if not an image. POSITION should be a list of the form returned by the `event-start' and `event-end' functions." + (declare (side-effect-free t)) (nth 7 position)) (defsubst posn-object (position) @@ -1800,6 +1912,7 @@ Value is a list (image ...) for an image object, a cons cell \(STRING . STRING-POS) for a string object, and nil for a buffer position. POSITION should be a list of the form returned by the `event-start' and `event-end' functions." + (declare (side-effect-free t)) (or (posn-image position) (posn-string position))) (defsubst posn-object-x-y (position) @@ -1808,12 +1921,14 @@ The return value has the form (DX . DY), where DX and DY are given in pixels, and they are relative to the top-left corner of the clicked glyph of object at POSITION. POSITION should be a list of the form returned by `event-start' and `event-end'." + (declare (side-effect-free t)) (nth 8 position)) (defsubst posn-object-width-height (position) "Return the pixel width and height of the object of POSITION. The return value has the form (WIDTH . HEIGHT). POSITION should be a list of the form returned by `event-start' and `event-end'." + (declare (side-effect-free t)) (nth 9 position)) (defun values--store-value (value) @@ -1846,7 +1961,7 @@ be a list of the form returned by `event-start' and `event-end'." (defun log10 (x) "Return (log X 10), the log base 10 of X." - (declare (obsolete log "24.4")) + (declare (side-effect-free t) (obsolete log "24.4")) (log x 10)) (set-advertised-calling-convention @@ -1856,6 +1971,7 @@ be a list of the form returned by `event-start' and `event-end'." (set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3") (set-advertised-calling-convention 'libxml-parse-xml-region '(&optional start end base-url) "27.1") (set-advertised-calling-convention 'libxml-parse-html-region '(&optional start end base-url) "27.1") +(set-advertised-calling-convention 'sleep-for '(seconds) "30.1") (set-advertised-calling-convention 'time-convert '(time form) "29.1") ;;;; Obsolescence declarations for variables, and aliases. @@ -1915,6 +2031,8 @@ instead; it will indirectly limit the specpdl stack size as well.") (defvaralias 'native-comp-deferred-compilation 'native-comp-jit-compilation) +(define-obsolete-function-alias 'fetch-bytecode #'ignore "30.1") + ;;;; Alternate names for functions - these are not being phased out. @@ -1935,6 +2053,7 @@ instead; it will indirectly limit the specpdl stack size as well.") (defalias 'store-match-data #'set-match-data) (defalias 'chmod #'set-file-modes) (defalias 'mkdir #'make-directory) +(defalias 'wholenump #'natnump) ;; These were the XEmacs names, now obsolete: (defalias 'point-at-eol #'line-end-position) @@ -2470,6 +2589,8 @@ Affects only hooks run in the current buffer." (list binding binding)) ((null (cdr binding)) (list (make-symbol "s") (car binding))) + ((eq '_ (car binding)) + (list (make-symbol "s") (cadr binding))) (t binding))) (when (> (length binding) 2) (signal 'error @@ -2510,7 +2631,7 @@ This is like `when-let' but doesn't handle a VARLIST of the form (defmacro and-let* (varlist &rest body) "Bind variables according to VARLIST and conditionally evaluate BODY. Like `when-let*', except if BODY is empty and all the bindings -are non-nil, then the result is non-nil." +are non-nil, then the result is the value of the last binding." (declare (indent 1) (debug if-let*)) (let (res) (if varlist @@ -2523,7 +2644,8 @@ are non-nil, then the result is non-nil." "Bind variables according to SPEC and evaluate THEN or ELSE. Evaluate each binding in turn, as in `let*', stopping if a binding value is nil. If all are non-nil return the value of -THEN, otherwise the last form in ELSE. +THEN, otherwise the value of the last form in ELSE, or nil if +there are none. Each element of SPEC is a list (SYMBOL VALUEFORM) that binds SYMBOL to the value of VALUEFORM. An element can additionally be @@ -2573,26 +2695,161 @@ The variable list SPEC is the same as in `if-let*'." ;; PUBLIC: find if the current mode derives from another. -(defun provided-mode-derived-p (mode &rest modes) - "Non-nil if MODE is derived from one of MODES. -Uses the `derived-mode-parent' property of the symbol to trace backwards. -If you just want to check `major-mode', use `derived-mode-p'." - ;; If MODE is an alias, then look up the real mode function first. - (when-let ((alias (symbol-function mode))) - (when (symbolp alias) - (setq mode alias))) - (while - (and - (not (memq mode modes)) - (let* ((parent (get mode 'derived-mode-parent)) - (parentfn (symbol-function parent))) - (setq mode (if (and parentfn (symbolp parentfn)) parentfn parent))))) - mode) - -(defun derived-mode-p (&rest modes) - "Non-nil if the current major mode is derived from one of MODES. -Uses the `derived-mode-parent' property of the symbol to trace backwards." - (apply #'provided-mode-derived-p major-mode modes)) +(defun merge-ordered-lists (lists &optional error-function) + "Merge LISTS in a consistent order. +LISTS is a list of lists of elements. +Merge them into a single list containing the same elements (removing +duplicates), obeying their relative positions in each list. +The order of the (sub)lists determines the final order in those cases where +the order within the sublists does not impose a unique choice. +Equality of elements is tested with `eql'. + +If a consistent order does not exist, call ERROR-FUNCTION with +a remaining list of lists that we do not know how to merge. +It should return the candidate to use to continue the merge, which +has to be the head of one of the lists. +By default we choose the head of the first list." + ;; Algorithm inspired from + ;; [C3](https://en.wikipedia.org/wiki/C3_linearization) + (let ((result '())) + (setq lists (remq nil lists)) ;Don't mutate the original `lists' argument. + (while (cdr (setq lists (delq nil lists))) + ;; Try to find the next element of the result. This + ;; is achieved by considering the first element of each + ;; (non-empty) input list and accepting a candidate if it is + ;; consistent with the rests of the input lists. + (let* ((next nil) + (tail lists)) + (while tail + (let ((candidate (caar tail)) + (other-lists lists)) + ;; Ensure CANDIDATE is not in any position but the first + ;; in any of the element lists of LISTS. + (while other-lists + (if (not (memql candidate (cdr (car other-lists)))) + (setq other-lists (cdr other-lists)) + (setq candidate nil) + (setq other-lists nil))) + (if (not candidate) + (setq tail (cdr tail)) + (setq next candidate) + (setq tail nil)))) + (unless next ;; The graph is inconsistent. + (setq next (funcall (or error-function #'caar) lists)) + (unless (assoc next lists #'eql) + (error "Invalid candidate returned by error-function: %S" next))) + ;; The graph is consistent so far, add NEXT to result and + ;; merge input lists, dropping NEXT from their heads where + ;; applicable. + (push next result) + (setq lists + (mapcar (lambda (l) (if (eql (car l) next) (cdr l) l)) + lists)))) + (if (null result) (car lists) ;; Common case. + (append (nreverse result) (car lists))))) + +(defun derived-mode-all-parents (mode &optional known-children) + "Return all the parents of MODE, starting with MODE. +This includes the parents set by `define-derived-mode' and additional +ones set by `derived-mode-add-parents'. +The returned list is not fresh, don't modify it. +\n(fn MODE)" ;`known-children' is for internal use only. + ;; Can't use `with-memoization' :-( + (let ((ps (get mode 'derived-mode--all-parents))) + (cond + (ps ps) + ((memq mode known-children) + ;; These things happen, better not get all worked up about it. + ;;(error "Cycle in the major mode hierarchy: %S" mode) + ;; But do try to return something meaningful. + (memq mode (reverse known-children))) + (t + ;; The mode hierarchy (or DAG, actually), is very static, but we + ;; need to react to changes because `parent' may not be defined + ;; yet (e.g. it's still just an autoload), so the recursive call + ;; to `derived-mode-all-parents' may return an + ;; invalid/incomplete result which we'll need to update when the + ;; mode actually gets loaded. + (let* ((new-children (cons mode known-children)) + (get-all-parents + (lambda (parent) + ;; Can't use `cl-lib' here (nor `gv') :-( + ;;(cl-assert (not (equal parent mode))) + ;;(cl-pushnew mode (get parent 'derived-mode--followers)) + (let ((followers (get parent 'derived-mode--followers))) + (unless (memq mode followers) + (put parent 'derived-mode--followers + (cons mode followers)))) + (derived-mode-all-parents parent new-children))) + (parent (or (get mode 'derived-mode-parent) + ;; If MODE is an alias, then follow the alias. + (let ((alias (symbol-function mode))) + (and (symbolp alias) alias)))) + (extras (get mode 'derived-mode-extra-parents)) + (all-parents + (merge-ordered-lists + (cons (if (and parent (not (memq parent extras))) + (funcall get-all-parents parent)) + (mapcar get-all-parents extras))))) + ;; Cache the result unless it was affected by `known-children' + ;; because of a cycle. + (if (and (memq mode all-parents) known-children) + (cons mode (remq mode all-parents)) + (put mode 'derived-mode--all-parents (cons mode all-parents)))))))) + +(defun provided-mode-derived-p (mode &optional modes &rest old-modes) + "Non-nil if MODE is derived from a mode that is a member of the list MODES. +MODES can also be a single mode instead of a list. +This examines the parent modes set by `define-derived-mode' and also +additional ones set by `derived-mode-add-parents'. +If you just want to check the current `major-mode', use `derived-mode-p'. +We also still support the deprecated calling convention: +\(provided-mode-derived-p MODE &rest MODES)." + (declare (side-effect-free t) + (advertised-calling-convention (mode modes) "30.1")) + (cond + (old-modes (setq modes (cons modes old-modes))) + ((not (listp modes)) (setq modes (list modes)))) + (let ((ps (derived-mode-all-parents mode))) + (while (and modes (not (memq (car modes) ps))) + (setq modes (cdr modes))) + (car modes))) + +(defun derived-mode-p (&optional modes &rest old-modes) + "Return non-nil if the current major mode is derived from one of MODES. +MODES should be a list of symbols or a single mode symbol instead of a list. +This examines the parent modes set by `define-derived-mode' and also +additional ones set by `derived-mode-add-parents'. +We also still support the deprecated calling convention: +\(derived-mode-p &rest MODES)." + (declare (side-effect-free t) + ;; FIXME: It's cumbersome for external packages to write code which + ;; accommodates both the old and the new calling conventions *and* + ;; doesn't cause spurious warnings. So let's be more lenient + ;; for now and maybe remove `deprecated-args' for Emacs-31. + (advertised-calling-convention (modes &rest deprecated-args) "30.1")) + (provided-mode-derived-p major-mode (if old-modes (cons modes old-modes) + modes))) + +(defun derived-mode-set-parent (mode parent) + "Declare PARENT to be the parent of MODE." + (put mode 'derived-mode-parent parent) + (derived-mode--flush mode)) + +(defun derived-mode-add-parents (mode extra-parents) + "Add EXTRA-PARENTS to the parents of MODE. +Declares the parents of MODE to be its main parent (as defined +in `define-derived-mode') plus EXTRA-PARENTS, which should be a list +of symbols." + (put mode 'derived-mode-extra-parents extra-parents) + (derived-mode--flush mode)) + +(defun derived-mode--flush (mode) + (put mode 'derived-mode--all-parents nil) + (let ((followers (get mode 'derived-mode--followers))) + (when followers ;; Common case. + (put mode 'derived-mode--followers nil) + (mapc #'derived-mode--flush followers)))) (defvar-local major-mode--suspended nil) (put 'major-mode--suspended 'permanent-local t) @@ -2715,6 +2972,7 @@ If TOGGLE has a `:menu-tag', that is used for the menu item's label." (defsubst autoloadp (object) "Non-nil if OBJECT is an autoload." + (declare (side-effect-free error-free)) (eq 'autoload (car-safe object))) ;; (defun autoload-type (object) @@ -2759,6 +3017,7 @@ This is to `put' what `defalias' is to `fset'." (defun locate-eln-file (eln-file) "Locate a natively-compiled ELN-FILE by searching its load path. This function looks in directories named by `native-comp-eln-load-path'." + (declare (important-return-value t)) (or (locate-file-internal (concat comp-native-version-dir "/" eln-file) native-comp-eln-load-path) (locate-file-internal @@ -2790,6 +3049,7 @@ instead. This function only works for symbols defined in Lisp files. For symbols that are defined in C files, use `help-C-file-name' instead." + (declare (important-return-value t)) (if (and (or (null type) (eq type 'defun)) (symbolp symbol) (autoloadp (symbol-function symbol))) @@ -2855,7 +3115,7 @@ instead." LIBRARY should be a relative file name of the library, a string. It can omit the suffix (a.k.a. file-name extension) if NOSUFFIX is nil (which is the default, see below). -This command searches the directories in `load-path' like `\\[load-library]' +This command searches the directories in `load-path' like \\[load-library] to find the file that `\\[load-library] RET LIBRARY RET' would load. Optional second arg NOSUFFIX non-nil means don't add suffixes `load-suffixes' to the specified name LIBRARY. @@ -2916,6 +3176,7 @@ argument, which will be called with the exit status of the program before the output is collected. If STATUS-HANDLER is nil, an error is signaled if the program returns with a non-zero exit status." + (declare (important-return-value t)) (with-temp-buffer (let ((status (apply #'call-process program nil (current-buffer) nil args))) (if status-handler @@ -2936,12 +3197,14 @@ exit status." "Execute PROGRAM with ARGS, returning its output as a list of lines. Signal an error if the program returns with a non-zero exit status. Also see `process-lines-ignore-status'." + (declare (important-return-value t)) (apply #'process-lines-handling-status program nil args)) (defun process-lines-ignore-status (program &rest args) "Execute PROGRAM with ARGS, returning its output as a list of lines. The exit status of the program is ignored. Also see `process-lines'." + (declare (important-return-value t)) (apply #'process-lines-handling-status program #'ignore args)) (defun process-live-p (process) @@ -2970,6 +3233,7 @@ process." (defun process-get (process propname) "Return the value of PROCESS' PROPNAME property. This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'." + (declare (side-effect-free t)) (plist-get (process-plist process) propname)) (defun process-put (process propname value) @@ -2980,6 +3244,7 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." (defun memory-limit () "Return an estimate of Emacs virtual memory usage, divided by 1024." + (declare (side-effect-free error-free)) (let ((default-directory temporary-file-directory)) (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0))) @@ -3013,6 +3278,11 @@ So escape sequences and keyboard encoding are taken into account. When there's an ambiguity because the key looks like the prefix of some sort of escape sequence, the ambiguity is resolved via `read-key-delay'. +Also in contrast to `read-event', input method text conversion +will be disabled while the key sequence is read, so that +character input events will always be generated for keyboard +input. + If the optional argument PROMPT is non-nil, display that as a prompt. @@ -3071,7 +3341,8 @@ only unbound fallback disabled is downcasing of the last event." (lookup-key global-map [tool-bar]))) map)) (let* ((keys - (catch 'read-key (read-key-sequence-vector prompt nil t))) + (catch 'read-key (read-key-sequence-vector prompt nil t + nil nil t))) (key (aref keys 0))) (if (and (> (length keys) 1) (memq key '(mode-line header-line @@ -3085,22 +3356,30 @@ only unbound fallback disabled is downcasing of the last event." (message nil) (use-global-map old-global-map)))) +(defvar touch-screen-events-received nil + "Whether a touch screen event has ever been translated. +The value of this variable governs whether +`read--potential-mouse-event' calls read-key or read-event.") + ;; FIXME: Once there's a safe way to transition away from read-event, ;; callers to this function should be updated to that way and this ;; function should be deleted. (defun read--potential-mouse-event () - "Read an event that might be a mouse event. + "Read an event that might be a mouse event. This function exists for backward compatibility in code packaged with Emacs. Do not call it directly in your own packages." - ;; `xterm-mouse-mode' events must go through `read-key' as they - ;; are decoded via `input-decode-map'. - (if xterm-mouse-mode - (read-key nil - ;; Normally `read-key' discards all mouse button - ;; down events. However, we want them here. - t) - (read-event))) + ;; `xterm-mouse-mode' events must go through `read-key' as they + ;; are decoded via `input-decode-map'. + (if (or xterm-mouse-mode + ;; If a touch screen is being employed, then mouse events + ;; are subject to translation as well. + touch-screen-events-received) + (read-key nil + ;; Normally `read-key' discards all mouse button + ;; down events. However, we want them here. + t) + (read-event))) (defvar read-passwd-map ;; BEWARE: `defconst' would purecopy it, breaking the sharing with @@ -3108,14 +3387,27 @@ with Emacs. Do not call it directly in your own packages." (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570 + (define-key map "\t" #'read-passwd-toggle-visibility) map) "Keymap used while reading passwords.") -(defun read-password--hide-password () +(defvar read-passwd--hide-password t) + +(defun read-passwd--hide-password () + "Make password in minibuffer hidden or visible." (let ((beg (minibuffer-prompt-end))) (dotimes (i (1+ (- (buffer-size) beg))) - (put-text-property (+ i beg) (+ 1 i beg) - 'display (string (or read-hide-char ?*)))))) + (if read-passwd--hide-password + (put-text-property + (+ i beg) (+ 1 i beg) 'display (string (or read-hide-char ?*))) + (remove-list-of-text-properties (+ i beg) (+ 1 i beg) '(display))) + (put-text-property + (+ i beg) (+ 1 i beg) + 'help-echo "C-u: Clear password\nTAB: Toggle password visibility")))) + +;; Actually in textconv.c. +(defvar overriding-text-conversion-style) +(declare-function set-text-conversion-style "textconv.c") (defun read-passwd (prompt &optional confirm default) "Read a password, prompting with PROMPT, and return it. @@ -3153,21 +3445,27 @@ by doing (clear-string STRING)." (setq-local inhibit-modification-hooks nil) ;bug#15501. (setq-local show-paren-mode nil) ;bug#16091. (setq-local inhibit--record-char t) - (add-hook 'post-command-hook #'read-password--hide-password nil t)) + (read-passwd-mode 1) + (add-hook 'post-command-hook #'read-passwd--hide-password nil t)) (unwind-protect (let ((enable-recursive-minibuffers t) - (read-hide-char (or read-hide-char ?*))) + (read-hide-char (or read-hide-char ?*)) + (overriding-text-conversion-style 'password)) (read-string prompt nil t default)) ; t = "no history" (when (buffer-live-p minibuf) (with-current-buffer minibuf + (read-passwd-mode -1) ;; Not sure why but it seems that there might be cases where the ;; minibuffer is not always properly reset later on, so undo ;; whatever we've done here (bug#11392). (remove-hook 'after-change-functions - #'read-password--hide-password 'local) + #'read-passwd--hide-password 'local) (kill-local-variable 'post-self-insert-hook) ;; And of course, don't keep the sensitive data around. - (erase-buffer)))))))) + (erase-buffer) + ;; Then restore the previous text conversion style. + (when (fboundp 'set-text-conversion-style) + (set-text-conversion-style text-conversion-style))))))))) (defvar read-number-history nil "The default history for the `read-number' function.") @@ -3257,6 +3555,8 @@ causes it to evaluate `help-form' and display the result." (while (not done) (unless (get-text-property 0 'face prompt) (setq prompt (propertize prompt 'face 'minibuffer-prompt))) + ;; Display the on screen keyboard if it exists. + (frame-toggle-on-screen-keyboard (selected-frame) nil) (setq char (let ((inhibit-quit inhibit-keyboard-quit)) (read-key prompt))) (and show-help (buffer-live-p (get-buffer helpbuf)) @@ -3271,11 +3571,6 @@ causes it to evaluate `help-form' and display the result." (help-form-show))) ((memq char chars) (setq done t)) - ((and executing-kbd-macro (= char -1)) - ;; read-event returns -1 if we are in a kbd macro and - ;; there are no more events in the macro. Attempt to - ;; get an event interactively. - (setq executing-kbd-macro nil)) ((not inhibit-keyboard-quit) (cond ((and (null esc-flag) (eq char ?\e)) @@ -3286,7 +3581,7 @@ causes it to evaluate `help-form' and display the result." (message "%s%s" prompt (char-to-string char)) char)) -(defun sit-for (seconds &optional nodisp obsolete) +(defun sit-for (seconds &optional nodisp) "Redisplay, then wait for SECONDS seconds. Stop when input is available. SECONDS may be a floating-point value. \(On operating systems that do not support waiting for fractions of a @@ -3295,29 +3590,11 @@ second, floating-point values are rounded down to the nearest integer.) If optional arg NODISP is t, don't redisplay, just wait for input. Redisplay does not happen if input is available before it starts. -Value is t if waited the full time with no input arriving, and nil otherwise. - -An obsolete, but still supported form is -\(sit-for SECONDS &optional MILLISECONDS NODISP) -where the optional arg MILLISECONDS specifies an additional wait period, -in milliseconds; this was useful when Emacs was built without -floating point support." - (declare (advertised-calling-convention (seconds &optional nodisp) "22.1") - (compiler-macro - (lambda (form) - (if (not (or (numberp nodisp) obsolete)) form - (macroexp-warn-and-return - "Obsolete calling convention for 'sit-for'" - `(,(car form) (+ ,seconds (/ (or ,nodisp 0) 1000.0)) ,obsolete) - '(obsolete sit-for)))))) +Value is t if waited the full time with no input arriving, and nil otherwise." ;; This used to be implemented in C until the following discussion: ;; https://lists.gnu.org/r/emacs-devel/2006-07/msg00401.html ;; Then it was moved here using an implementation based on an idle timer, ;; which was then replaced by the use of read-event. - (if (numberp nodisp) - (setq seconds (+ seconds (* 1e-3 nodisp)) - nodisp obsolete) - (if obsolete (setq nodisp obsolete))) (cond (noninteractive (sleep-for seconds) @@ -3379,7 +3656,7 @@ If there is a natural number at point, use it as default." (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) - (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char) + ;; (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char) (define-key map [remap exit-minibuffer] #'read-char-from-minibuffer-insert-other) (define-key map [remap recenter-top-bottom] #'minibuffer-recenter-top-bottom) @@ -3410,13 +3687,16 @@ allowed to type into the minibuffer. When the user types any such key, this command discard all minibuffer input and displays an error message." (interactive) - (when (minibufferp) + (when (minibufferp) ;;FIXME: Why? (delete-minibuffer-contents) (ding) (discard-input) (minibuffer-message "Wrong answer") (sit-for 2))) +;; Defined in textconv.c. +(defvar overriding-text-conversion-style) + (defun read-char-from-minibuffer (prompt &optional chars history) "Read a character from the minibuffer, prompting for it with PROMPT. Like `read-char', but uses the minibuffer to read and return a character. @@ -3431,7 +3711,15 @@ while calling this function, then pressing `help-char' causes it to evaluate `help-form' and display the result. There is no need to explicitly add `help-char' to CHARS; `help-char' is bound automatically to `help-form-show'." - (let* ((map (if (consp chars) + + ;; If text conversion is enabled in this buffer, then it will only + ;; be disabled the next time `force-mode-line-update' happens. + (when (and (bound-and-true-p overriding-text-conversion-style) + (bound-and-true-p text-conversion-style)) + (force-mode-line-update)) + + (let* ((overriding-text-conversion-style nil) + (map (if (consp chars) (or (gethash (list help-form (cons help-char chars)) read-char-from-minibuffer-map-hash) (let ((map (make-sparse-keymap)) @@ -3443,22 +3731,39 @@ There is no need to explicitly add `help-char' to CHARS; ;; being a command char. (when help-form (define-key map (vector help-char) - (lambda () - (interactive) - (let ((help-form msg)) ; lexically bound msg - (help-form-show))))) + (lambda () + (interactive) + (let ((help-form msg)) ; lexically bound msg + (help-form-show))))) + ;; FIXME: We use `read-char-from-minibuffer-insert-char' + ;; here only as a kind of alias of `self-insert-command' + ;; to prevent those keys from being remapped to + ;; `read-char-from-minibuffer-insert-other'. (dolist (char chars) (define-key map (vector char) - #'read-char-from-minibuffer-insert-char)) + #'read-char-from-minibuffer-insert-char)) (define-key map [remap self-insert-command] - #'read-char-from-minibuffer-insert-other) + #'read-char-from-minibuffer-insert-other) (puthash (list help-form (cons help-char chars)) map read-char-from-minibuffer-map-hash) map)) read-char-from-minibuffer-map)) ;; Protect this-command when called from pre-command-hook (bug#45029) (this-command this-command) - (result (read-from-minibuffer prompt nil map nil (or history t))) + (result (minibuffer-with-setup-hook + (lambda () + (setq-local post-self-insert-hook nil) + (add-hook 'post-command-hook + (lambda () + (if (<= (1+ (minibuffer-prompt-end)) + (point-max)) + (exit-minibuffer))) + nil 'local)) + ;; Disable text conversion if it is enabled. + ;; (bug#65370) + (when (fboundp 'set-text-conversion-style) + (set-text-conversion-style text-conversion-style)) + (read-from-minibuffer prompt nil map nil (or history t)))) (char (if (> (length result) 0) ;; We have a string (with one character), so return the first one. @@ -3550,21 +3855,34 @@ confusing to some users.") (defvar from--tty-menu-p nil "Non-nil means the current command was invoked from a TTY menu.") + +(declare-function android-detect-keyboard "androidfns.c") + +(defvar use-dialog-box-override nil + "Whether `use-dialog-box-p' should always return t.") + (defun use-dialog-box-p () "Return non-nil if the current command should prompt the user via a dialog box." - (and last-input-event ; not during startup - (or (consp last-nonmenu-event) ; invoked by a mouse event - (and (null last-nonmenu-event) - (consp last-input-event)) - from--tty-menu-p) ; invoked via TTY menu - use-dialog-box)) + (or use-dialog-box-override + (and last-input-event ; not during startup + (or (consp last-nonmenu-event) ; invoked by a mouse event + (and (null last-nonmenu-event) + (consp last-input-event)) + (and (featurep 'android) ; Prefer dialog boxes on + ; Android. + (not (android-detect-keyboard))) ; If no keyboard is + ; connected. + from--tty-menu-p) ; invoked via TTY menu + use-dialog-box))) (defun y-or-n-p (prompt) "Ask user a \"y or n\" question. Return t if answer is \"y\" and nil if it is \"n\". PROMPT is the string to display to ask the question; `y-or-n-p' -adds \"(y or n) \" to it. +adds \"(y or n) \" to it. If PROMPT is a non-empty string, and +it ends with a non-space character, a space character will be +appended to it. If you bind the variable `help-form' to a non-nil value while calling this function, then pressing `help-char' @@ -3666,6 +3984,9 @@ like) while `y-or-n-p' is running)." (setq prompt (funcall padded prompt)) (let* ((enable-recursive-minibuffers t) (msg help-form) + ;; Disable text conversion so that real Y or N events are + ;; sent. + (overriding-text-conversion-style nil) (keymap (let ((map (make-composed-keymap y-or-n-p-map query-replace-map))) (when help-form @@ -3679,9 +4000,15 @@ like) while `y-or-n-p' is running)." map)) ;; Protect this-command when called from pre-command-hook (bug#45029) (this-command this-command) - (str (read-from-minibuffer - prompt nil keymap nil - (or y-or-n-p-history-variable t)))) + (str (progn + ;; If the minibuffer is already active, the + ;; selected window might not change. Disable + ;; text conversion by hand. + (when (fboundp 'set-text-conversion-style) + (set-text-conversion-style text-conversion-style)) + (read-from-minibuffer + prompt nil keymap nil + (or y-or-n-p-history-variable t))))) (setq answer (if (member str '("y" "Y")) 'act 'skip))))) (let ((ret (eq answer 'act))) (unless noninteractive @@ -3697,6 +4024,9 @@ This means that if BODY exits abnormally, all of its changes to the current buffer are undone. This works regardless of whether undo is enabled in the buffer. +Do not call functions which edit the undo list within BODY; see +`prepare-change-group'. + This mechanism is transparent to ordinary use of undo; if undo is enabled in the buffer and BODY succeeds, the user can undo the change normally." @@ -3763,6 +4093,12 @@ Once you finish the group, don't use the handle again--don't try to finish the same group twice. For a simple example of correct use, see the source code of `atomic-change-group'. +As long as this handle is still in use, do not call functions +which edit the undo list: if it no longer contains its current +value, Emacs will not be able to cancel the change group. This +includes any \"amalgamating\" commands, such as `delete-char', +which call `undo-auto-amalgamate'. + The handle records only the specified buffer. To make a multibuffer change group, call this function once for each buffer you want to cover, then use `nconc' to combine the returned values, like this: @@ -3885,6 +4221,7 @@ If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." (defun copy-overlay (o) "Return a copy of overlay O." + (declare (important-return-value t)) (let ((o1 (if (overlay-buffer o) (make-overlay (overlay-start o) (overlay-end o) ;; FIXME: there's no easy way to find the @@ -3967,6 +4304,7 @@ See also `locate-user-emacs-file'.") (defsubst buffer-narrowed-p () "Return non-nil if the current buffer is narrowed." + (declare (side-effect-free t)) (/= (- (point-max) (point-min)) (buffer-size))) (defmacro with-restriction (start end &rest rest) @@ -3983,17 +4321,10 @@ buffer, use `without-restriction' with the same LABEL argument. \(fn START END [:label LABEL] BODY)" (declare (indent 2) (debug t)) (if (eq (car rest) :label) - `(internal--with-restriction ,start ,end (lambda () ,@(cddr rest)) - ,(cadr rest)) - `(internal--with-restriction ,start ,end (lambda () ,@rest)))) - -(defun internal--with-restriction (start end body &optional label) - "Helper function for `with-restriction', which see." - (save-restriction - (if label - (internal--labeled-narrow-to-region start end label) - (narrow-to-region start end)) - (funcall body))) + `(save-restriction + (internal--labeled-narrow-to-region ,start ,end ,(cadr rest)) + ,@(cddr rest)) + `(save-restriction (narrow-to-region ,start ,end) ,@rest))) (defmacro without-restriction (&rest rest) "Execute BODY without restrictions. @@ -4006,17 +4337,8 @@ by `with-restriction' with the same LABEL argument are lifted. \(fn [:label LABEL] BODY)" (declare (indent 0) (debug t)) (if (eq (car rest) :label) - `(internal--without-restriction (lambda () ,@(cddr rest)) - ,(cadr rest)) - `(internal--without-restriction (lambda () ,@rest)))) - -(defun internal--without-restriction (body &optional label) - "Helper function for `without-restriction', which see." - (save-restriction - (if label - (internal--labeled-widen label) - (widen)) - (funcall body))) + `(save-restriction (internal--labeled-widen ,(cadr rest)) ,@(cddr rest)) + `(save-restriction (widen) ,@rest))) (defun find-tag-default-bounds () "Determine the boundaries of the default tag, based on text at point. @@ -4094,7 +4416,8 @@ See Info node `(elisp)Security Considerations'. If the optional POSIX argument is non-nil, ARGUMENT is quoted according to POSIX shell quoting rules, regardless of the system's shell." -(cond + (declare (important-return-value t)) + (cond ((and (not posix) (eq system-type 'ms-dos)) ;; Quote using double quotes, but escape any existing quotes in ;; the argument with backslashes. @@ -4154,15 +4477,18 @@ system's shell." (defsubst string-to-list (string) "Return a list of characters in STRING." + (declare (side-effect-free t)) (append string nil)) (defsubst string-to-vector (string) "Return a vector of characters in STRING." + (declare (side-effect-free t)) (vconcat string)) (defun string-or-null-p (object) "Return t if OBJECT is a string or nil. Otherwise, return nil." + (declare (pure t) (side-effect-free error-free)) (or (stringp object) (null object))) (defun list-of-strings-p (object) @@ -4175,21 +4501,24 @@ Otherwise, return nil." (defun booleanp (object) "Return t if OBJECT is one of the two canonical boolean values: t or nil. Otherwise, return nil." + (declare (pure t) (side-effect-free error-free)) (and (memq object '(nil t)) t)) (defun special-form-p (object) "Non-nil if and only if OBJECT is a special form." - (if (and (symbolp object) (fboundp object)) - (setq object (indirect-function object))) + (declare (side-effect-free error-free)) + (if (symbolp object) (setq object (indirect-function object))) (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) (defun plistp (object) "Non-nil if and only if OBJECT is a valid plist." + (declare (pure t) (side-effect-free error-free)) (let ((len (proper-list-p object))) (and len (zerop (% len 2))))) (defun macrop (object) "Non-nil if and only if OBJECT is a macro." + (declare (side-effect-free t)) (let ((def (indirect-function object))) (when (consp def) (or (eq 'macro (car def)) @@ -4199,10 +4528,13 @@ Otherwise, return nil." "Return non-nil if OBJECT is a function that has been compiled. Does not distinguish between functions implemented in machine code or byte-code." - (or (subrp object) (byte-code-function-p object))) + (declare (side-effect-free error-free)) + (or (and (subrp object) (not (eq 'unevalled (cdr (subr-arity object))))) + (byte-code-function-p object))) (defun field-at-pos (pos) "Return the field at position POS, taking stickiness etc into account." + (declare (important-return-value t)) (let ((raw-field (get-char-property (field-beginning pos) 'field))) (if (eq raw-field 'boundary) (get-char-property (1- (field-end pos)) 'field) @@ -4218,6 +4550,7 @@ string; otherwise returna 40-character string. Note that SHA-1 is not collision resistant and should not be used for anything security-related. See `secure-hash' for alternatives." + (declare (side-effect-free t)) (secure-hash 'sha1 object start end binary)) (defun function-get (f prop &optional autoload) @@ -4225,6 +4558,7 @@ alternatives." If AUTOLOAD is non-nil and F is autoloaded, try to load it in the hope that it will set PROP. If AUTOLOAD is `macro', do it only if it's an autoloaded macro." + (declare (important-return-value t)) (let ((val nil)) (while (and (symbolp f) (null (setq val (get f prop))) @@ -4713,7 +5047,7 @@ read-only, and scans it for function and variable names to make them into clickable cross-references. See the related form `with-temp-buffer-window'." - (declare (debug t)) + (declare (debug t) (indent 1)) (let ((old-dir (make-symbol "old-dir")) (buf (make-symbol "buf"))) `(let* ((,old-dir default-directory) @@ -4889,9 +5223,12 @@ even if this catches the signal." `(condition-case ,var ,bodyform ,@(mapcar (lambda (handler) - `((debug ,@(if (listp (car handler)) (car handler) - (list (car handler)))) - ,@(cdr handler))) + (let ((condition (car handler))) + (if (eq condition :success) + handler + `((debug ,@(if (listp condition) condition + (list condition))) + ,@(cdr handler))))) handlers))) (defmacro with-demoted-errors (format &rest body) @@ -4905,6 +5242,7 @@ but that should be robust in the unexpected case that an error is signaled." (declare (debug t) (indent 1)) (let* ((err (make-symbol "err")) (orig-body body) + (orig-format format) (format (if (and (stringp format) body) format (prog1 "Error: %S" (if format (push format body))))) @@ -4915,7 +5253,10 @@ but that should be robust in the unexpected case that an error is signaled." (if (eq orig-body body) exp ;; The use without `format' is obsolete, let's warn when we bump ;; into any such remaining uses. - (macroexp-warn-and-return "Missing format argument" exp nil nil format)))) + (macroexp-warn-and-return + (format-message "Missing format argument in `with-demoted-errors'") + exp nil nil + orig-format)))) (defmacro combine-after-change-calls (&rest body) "Execute BODY, but don't call the after-change functions till the end. @@ -4989,31 +5330,41 @@ the function `undo--wrap-and-run-primitive-undo'." (kill-local-variable 'before-change-functions)) (if local-acf (setq after-change-functions acf) (kill-local-variable 'after-change-functions)))) - (when (not (eq buffer-undo-list t)) - (let ((ap-elt - (list 'apply - (- end end-marker) - beg - (marker-position end-marker) - #'undo--wrap-and-run-primitive-undo - beg (marker-position end-marker) buffer-undo-list)) - (ptr buffer-undo-list)) - (if (not (eq buffer-undo-list old-bul)) - (progn - (while (and (not (eq (cdr ptr) old-bul)) - ;; In case garbage collection has removed OLD-BUL. - (cdr ptr)) - (if (and (consp (cdr ptr)) - (consp (cadr ptr)) - (eq (caadr ptr) t)) - ;; Don't include a timestamp entry. - (setcdr ptr (cddr ptr)) - (setq ptr (cdr ptr)))) - (unless (or (cdr ptr) (null old-bul)) - (message "combine-change-calls: buffer-undo-list presumably truncated by GC")) - (setcdr ptr nil) - (push ap-elt buffer-undo-list) - (setcdr buffer-undo-list old-bul))))) + ;; If buffer-undo-list is neither t (in which case undo + ;; information is not recorded) nor equal to buffer-undo-list + ;; before body was funcalled (in which case (funcall body) did + ;; not add items to buffer-undo-list) ... + (unless (or (eq buffer-undo-list t) + (eq buffer-undo-list old-bul)) + (let ((ptr buffer-undo-list) body-undo-list) + ;; ... then loop over buffer-undo-list, until the head of + ;; buffer-undo-list before body was funcalled is found, or + ;; ptr is nil (which may happen if garbage-collect has + ;; been called after (funcall body) and has removed + ;; entries of buffer-undo-list that were added by (funcall + ;; body)), and add these entries to body-undo-list. + (while (and ptr (not (eq ptr old-bul))) + (push (car ptr) body-undo-list) + (setq ptr (cdr ptr))) + (setq body-undo-list (nreverse body-undo-list)) + ;; Warn if garbage-collect has truncated buffer-undo-list + ;; behind our back. + (when (and old-bul (not ptr)) + (message + "combine-change-calls: buffer-undo-list has been truncated")) + ;; Add an (apply ...) entry to buffer-undo-list, using + ;; body-undo-list ... + (push (list 'apply + (- end end-marker) + beg + (marker-position end-marker) + #'undo--wrap-and-run-primitive-undo + beg (marker-position end-marker) + body-undo-list) + buffer-undo-list) + ;; ... and set the cdr of buffer-undo-list to + ;; buffer-undo-list before body was funcalled. + (setcdr buffer-undo-list old-bul))) (if (not inhibit-modification-hooks) (run-hook-with-args 'after-change-functions beg (marker-position end-marker) @@ -5177,6 +5528,7 @@ In other words, all back-references in the form `\\&' and `\\N' are substituted with actual strings matched by the last search. Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same meaning as for `replace-match'." + (declare (side-effect-free t)) (let ((match (match-string 0 string))) (save-match-data (match-data--translate (- (match-beginning 0))) @@ -5222,11 +5574,13 @@ wherever possible, since it is slow." (defsubst looking-at-p (regexp) "\ Same as `looking-at' except this function does not change the match data." + (declare (side-effect-free t)) (looking-at regexp t)) (defsubst string-match-p (regexp string &optional start) "\ Same as `string-match' except this function does not change the match data." + (declare (side-effect-free t)) (string-match regexp string start t)) (defun subregexp-context-p (regexp pos &optional start) @@ -5236,6 +5590,7 @@ A non-subregexp context is for example within brackets, or within a repetition bounds operator `\\=\\{...\\}', or right after a `\\'. If START is non-nil, it should be a position in REGEXP, smaller than POS, and known to be in a subregexp context." + (declare (important-return-value t)) ;; Here's one possible implementation, with the great benefit that it ;; reuses the regexp-matcher's own parser, so it understands all the ;; details of the syntax. A disadvantage is that it needs to match the @@ -5317,6 +5672,7 @@ case that you wish to retain zero-length substrings when splitting on whitespace, use `(split-string STRING split-string-default-separators)'. Modifies the match data; use `save-match-data' if necessary." + (declare (important-return-value t)) (let* ((keep-nulls (not (if separators omit-nulls t))) (rexp (or separators split-string-default-separators)) (start 0) @@ -5374,6 +5730,7 @@ Only some SEPARATORs will work properly. Note that this is not intended to protect STRINGS from interpretation by shells, use `shell-quote-argument' for that." + (declare (important-return-value t)) (let* ((sep (or separator " ")) (re (concat "[\\\"]" "\\|" (regexp-quote sep)))) (mapconcat @@ -5388,6 +5745,7 @@ interpretation by shells, use `shell-quote-argument' for that." It understands Emacs Lisp quoting within STRING, such that (split-string-and-unquote (combine-and-quote-strings strs)) == strs The SEPARATOR regexp defaults to \"\\s-+\"." + (declare (important-return-value t)) (let ((sep (or separator "\\s-+")) (i (string-search "\"" string))) (if (null i) @@ -5455,6 +5813,7 @@ To replace only the first match (if any), make REGEXP match up to \\\\=' and replace a sub-expression, e.g. (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\\\='\" \"bar\" \" foo foo\" nil nil 1) => \" bar foo\"" + (declare (important-return-value t)) ;; To avoid excessive consing from multiple matches in long strings, ;; don't just call `replace-match' continually. Walk down the @@ -5497,7 +5856,7 @@ Upper-case and lower-case letters are treated as equal. Unibyte strings are converted to multibyte for comparison. See also `string-equal'." - (declare (pure t) (side-effect-free t)) + (declare (side-effect-free t)) (eq t (compare-strings string1 0 nil string2 0 nil t))) (defun string-prefix-p (prefix string &optional ignore-case) @@ -5506,7 +5865,7 @@ PREFIX should be a string; the function returns non-nil if the characters at the beginning of STRING compare equal with PREFIX. If IGNORE-CASE is non-nil, the comparison is done without paying attention to letter-case differences." - (declare (pure t) (side-effect-free t)) + (declare (side-effect-free t)) (let ((prefix-length (length prefix))) (if (> prefix-length (length string)) nil (eq t (compare-strings prefix 0 prefix-length string @@ -5518,7 +5877,7 @@ SUFFIX should be a string; the function returns non-nil if the characters at end of STRING compare equal with SUFFIX. If IGNORE-CASE is non-nil, the comparison is done without paying attention to letter-case differences." - (declare (pure t) (side-effect-free t)) + (declare (side-effect-free t)) (let ((start-pos (- (length string) (length suffix)))) (and (>= start-pos 0) (eq t (compare-strings suffix nil nil @@ -5546,6 +5905,7 @@ consisting of STR followed by an invisible left-to-right mark "Return non-nil if STRING1 is greater than STRING2 in lexicographic order. Case is significant. Symbols are also allowed; their print names are used instead." + (declare (pure t) (side-effect-free t)) (string-lessp string2 string1)) @@ -5573,8 +5933,8 @@ Return nil if there isn't one." (load-elt (and loads (car loads)))) (save-match-data (while (and loads - (or (null (car load-elt)) - (not (string-match file-regexp (car load-elt))))) + (not (and (car load-elt) + (string-match file-regexp (car load-elt))))) (setq loads (cdr loads) load-elt (and loads (car loads))))) load-elt)) @@ -5813,6 +6173,7 @@ from `standard-syntax-table' otherwise." (defun syntax-after (pos) "Return the raw syntax descriptor for the char after POS. If POS is outside the buffer's accessible portion, return nil." + (declare (important-return-value t)) (unless (or (< pos (point-min)) (>= pos (point-max))) (let ((st (if parse-sexp-lookup-properties (get-char-property pos 'syntax-table)))) @@ -5827,6 +6188,7 @@ integer that encodes the corresponding syntax class. See Info node `(elisp)Syntax Table Internals' for a list of codes. If SYNTAX is nil, return nil." + (declare (pure t) (side-effect-free t)) (and syntax (logand (car syntax) 65535))) ;; Utility motion commands @@ -6062,13 +6424,14 @@ If non-nil, BASE should be a function, and frames before its nearest activation frame are discarded." (let ((frames nil)) (mapbacktrace (lambda (&rest frame) (push frame frames)) - (or base 'backtrace-frames)) + (or base #'backtrace-frames)) (nreverse frames))) (defun backtrace-frame (nframes &optional base) "Return the function and arguments NFRAMES up from current execution point. If non-nil, BASE should be a function, and NFRAMES counts from its -nearest activation frame. +nearest activation frame. BASE can also be of the form (OFFSET . FUNCTION) +in which case OFFSET will be added to NFRAMES. If the frame has not evaluated the arguments yet (or is a special form), the value is (nil FUNCTION ARG-FORMS...). If the frame has evaluated its arguments and called its function already, @@ -6079,7 +6442,7 @@ or a lambda expression for macro calls. If NFRAMES is more than the number of frames, the value is nil." (backtrace-frame--internal (lambda (evald func args _) `(,evald ,func ,@args)) - nframes (or base 'backtrace-frame))) + nframes (or base #'backtrace-frame))) (defvar called-interactively-p-functions nil @@ -6145,14 +6508,8 @@ command is called from a keyboard macro?" ;; Skip special forms (from non-compiled code). (and frame (null (car frame))) ;; Skip also `interactive-p' (because we don't want to know if - ;; interactive-p was called interactively but if it's caller was) - ;; and `byte-code' (idem; this appears in subexpressions of things - ;; like condition-case, which are wrapped in a separate bytecode - ;; chunk). - ;; FIXME: For lexical-binding code, this is much worse, - ;; because the frames look like "byte-code -> funcall -> #[...]", - ;; which is not a reliable signature. - (memq (nth 1 frame) '(interactive-p 'byte-code)) + ;; interactive-p was called interactively but if its caller was). + (eq (nth 1 frame) 'interactive-p) ;; Skip package-specific stack-frames. (let ((skip (run-hook-with-args-until-success 'called-interactively-p-functions @@ -6195,7 +6552,8 @@ To test whether a function can be called interactively, use `commandp'." ;; Kept around for now. See discussion at: ;; https://lists.gnu.org/r/emacs-devel/2020-08/msg00564.html - (declare (obsolete called-interactively-p "23.2")) + (declare (obsolete called-interactively-p "23.2") + (side-effect-free error-free)) (called-interactively-p 'interactive)) (defun internal-push-keymap (keymap symbol) @@ -6395,7 +6753,6 @@ effectively rounded up." (unless min-time (setq min-time 0.2)) (let ((reporter - ;; Force a call to `message' now (cons (or min-value 0) (vector (if (>= min-time 0.02) (float-time) nil) @@ -6406,9 +6763,12 @@ effectively rounded up." min-time ;; SUFFIX nil)))) + ;; Force a call to `message' now. (progress-reporter-update reporter (or current-value min-value)) reporter)) +(defalias 'progress-reporter-make #'make-progress-reporter) + (defun progress-reporter-force-update (reporter &optional value new-message suffix) "Report progress of an operation in the echo area unconditionally. @@ -6631,6 +6991,7 @@ Examples of version conversion: \"22.8beta3\" (22 8 -2 3) See documentation for `version-separator' and `version-regexp-alist'." + (declare (side-effect-free t)) (unless (stringp ver) (error "Version must be a string")) ;; Change .x.y to 0.x.y @@ -6682,6 +7043,7 @@ Note that a version specified by the list (1) is equal to (1 0), \(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant. Also, a version given by the list (1) is higher than (1 -1), which in turn is higher than (1 -2), which is higher than (1 -3)." + (declare (pure t) (side-effect-free t)) (while (and l1 l2 (= (car l1) (car l2))) (setq l1 (cdr l1) l2 (cdr l2))) @@ -6703,6 +7065,7 @@ Note that a version specified by the list (1) is equal to (1 0), \(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant. Also, a version given by the list (1) is higher than (1 -1), which in turn is higher than (1 -2), which is higher than (1 -3)." + (declare (pure t) (side-effect-free t)) (while (and l1 l2 (= (car l1) (car l2))) (setq l1 (cdr l1) l2 (cdr l2))) @@ -6724,6 +7087,7 @@ Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0), etc. That is, the trailing zeroes are insignificant. Also, integer list (1) is greater than (1 -1) which is greater than (1 -2) which is greater than (1 -3)." + (declare (pure t) (side-effect-free t)) (while (and l1 l2 (= (car l1) (car l2))) (setq l1 (cdr l1) l2 (cdr l2))) @@ -6741,6 +7105,7 @@ which is greater than (1 -3)." "Return the first non-zero element of LST, which is a list of integers. If all LST elements are zeros or LST is nil, return zero." + (declare (pure t) (side-effect-free t)) (while (and lst (zerop (car lst))) (setq lst (cdr lst))) (if lst @@ -6757,6 +7122,7 @@ etc. That is, the trailing \".0\"s are insignificant. Also, version string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\", which is higher than \"1alpha\", which is higher than \"1snapshot\". Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." + (declare (side-effect-free t)) (version-list-< (version-to-list v1) (version-to-list v2))) (defun version<= (v1 v2) @@ -6767,6 +7133,7 @@ etc. That is, the trailing \".0\"s are insignificant. Also, version string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\", which is higher than \"1alpha\", which is higher than \"1snapshot\". Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." + (declare (side-effect-free t)) (version-list-<= (version-to-list v1) (version-to-list v2))) (defun version= (v1 v2) @@ -6777,6 +7144,7 @@ etc. That is, the trailing \".0\"s are insignificant. Also, version string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\", which is higher than \"1alpha\", which is higher than \"1snapshot\". Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." + (declare (side-effect-free t)) (version-list-= (version-to-list v1) (version-to-list v2))) (defvar package--builtin-versions @@ -6880,6 +7248,7 @@ returned list are in the same order as in TREE. \(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7)) => (1 2 3 4 5 6 7)" + (declare (side-effect-free error-free)) (let (elems) (while (consp tree) (let ((elem (pop tree))) @@ -6898,7 +7267,11 @@ returned list are in the same order as in TREE. "Trim STRING of leading string matching REGEXP. REGEXP defaults to \"[ \\t\\n\\r]+\"." - (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string) + (declare (important-return-value t)) + (if (string-match (if regexp + (concat "\\`\\(?:" regexp "\\)") + "\\`[ \t\n\r]+") + string) (substring string (match-end 0)) string)) @@ -6906,7 +7279,10 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"." "Trim STRING of trailing string matching REGEXP. REGEXP defaults to \"[ \\t\\n\\r]+\"." - (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") + (declare (side-effect-free t)) + (let ((i (string-match-p (if regexp + (concat "\\(?:" regexp "\\)\\'") + "[ \t\n\r]+\\'") string))) (if i (substring string 0 i) string))) @@ -6914,6 +7290,7 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"." "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT. TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." + (declare (important-return-value t)) (string-trim-left (string-trim-right string trim-right) trim-left)) ;; The initial anchoring is for better performance in searching matches. @@ -6977,6 +7354,7 @@ sentence (see Info node `(elisp) Documentation Tips')." "Return OBJECT as a list. If OBJECT is already a list, return OBJECT itself. If it's not a list, return a one-element list containing OBJECT." + (declare (side-effect-free error-free)) (if (listp object) object (list object))) @@ -6992,27 +7370,17 @@ string will be displayed only if BODY takes longer than TIMEOUT seconds. (lambda () ,@body))) -(defun function-alias-p (func &optional noerror) +(defun function-alias-p (func &optional _noerror) "Return nil if FUNC is not a function alias. -If FUNC is a function alias, return the function alias chain. - -If the function alias chain contains loops, an error will be -signaled. If NOERROR, the non-loop parts of the chain is returned." - (declare (side-effect-free t)) - (let ((chain nil) - (orig-func func)) - (nreverse - (catch 'loop - (while (and (symbolp func) - (setq func (symbol-function func)) - (symbolp func)) - (when (or (memq func chain) - (eq func orig-func)) - (if noerror - (throw 'loop chain) - (signal 'cyclic-function-indirection (list orig-func)))) - (push func chain)) - chain)))) +If FUNC is a function alias, return the function alias chain." + (declare (advertised-calling-convention (func) "30.1") + (side-effect-free error-free)) + (let ((chain nil)) + (while (and (symbolp func) + (setq func (symbol-function func)) + (symbolp func)) + (push func chain)) + (nreverse chain))) (defun readablep (object) "Say whether OBJECT has a readable syntax. @@ -7062,6 +7430,7 @@ is inserted before adjusting the number of empty lines." If OMIT-NULLS, empty lines will be removed from the results. If KEEP-NEWLINES, don't strip trailing newlines from the result lines." + (declare (side-effect-free t)) (if (equal string "") (if omit-nulls nil @@ -7090,13 +7459,15 @@ lines." (setq start (length string))))) (nreverse lines)))) -(defun buffer-match-p (condition buffer-or-name &optional arg) +(defvar buffer-match-p--past-warnings nil) + +(defun buffer-match-p (condition buffer-or-name &rest args) "Return non-nil if BUFFER-OR-NAME matches CONDITION. CONDITION is either: - the symbol t, to always match, - the symbol nil, which never matches, - a regular expression, to match a buffer name, -- a predicate function that takes BUFFER-OR-NAME and ARG as +- a predicate function that takes BUFFER-OR-NAME plus ARGS as arguments, and returns non-nil if the buffer matches, - a cons-cell, where the car describes how to interpret the cdr. The car can be one of the following: @@ -7121,9 +7492,18 @@ CONDITION is either: ((pred stringp) (string-match-p condition (buffer-name buffer))) ((pred functionp) - (if (eq 1 (cdr (func-arity condition))) - (funcall condition buffer-or-name) - (funcall condition buffer-or-name arg))) + (if (cdr args) + ;; New in Emacs>29.1. no need for compatibility hack. + (apply condition buffer-or-name args) + (condition-case-unless-debug err + (apply condition buffer-or-name args) + (wrong-number-of-arguments + (unless (member condition + buffer-match-p--past-warnings) + (message "%s" (error-message-string err)) + (push condition buffer-match-p--past-warnings)) + (apply condition buffer-or-name + (if args nil '(nil))))))) (`(major-mode . ,mode) (eq (buffer-local-value 'major-mode buffer) @@ -7145,20 +7525,42 @@ CONDITION is either: (throw 'match t))))))) (funcall match (list condition)))) -(defun match-buffers (condition &optional buffers arg) +(defun match-buffers (condition &optional buffers &rest args) "Return a list of buffers that match CONDITION, or nil if none match. See `buffer-match-p' for various supported CONDITIONs. By default all buffers are checked, but the optional argument BUFFERS can restrict that: its value should be an explicit list of buffers to check. -Optional argument ARG is passed to `buffer-match-p', for +Optional arguments ARGS are passed to `buffer-match-p', for predicate conditions in CONDITION." (let (bufs) (dolist (buf (or buffers (buffer-list))) - (when (buffer-match-p condition (get-buffer buf) arg) + (when (apply #'buffer-match-p condition (get-buffer buf) args) (push buf bufs))) bufs)) +(defmacro handler-bind (handlers &rest body) + "Setup error HANDLERS around execution of BODY. +HANDLERS is a list of (CONDITIONS HANDLER) where +CONDITIONS should be a list of condition names (symbols) or +a single condition name, and HANDLER is a form whose evaluation +returns a function. +When an error is signaled during execution of BODY, if that +error matches CONDITIONS, then the associated HANDLER +function is called with the error object as argument. +HANDLERs can either transfer the control via a non-local exit, +or return normally. If a handler returns normally, the search for an +error handler continues from where it left off." + ;; FIXME: Completion support as in `condition-case'? + (declare (indent 1) (debug ((&rest (sexp form)) body))) + (let ((args '())) + (dolist (cond+handler handlers) + (let ((handler (car (cdr cond+handler))) + (conds (car cond+handler))) + (push `',(ensure-list conds) args) + (push handler args))) + `(handler-bind-1 (lambda () ,@body) ,@(nreverse args)))) + (defmacro with-memoization (place &rest code) "Return the value of CODE and stash it in PLACE. If PLACE's value is non-nil, then don't bother evaluating CODE |