mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-10 16:20:17 -08:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into feature/igc

Browse source
This commit is contained in:
Gerd Möllmann 2025-04-05 04:31:10 +02:00
commit 8ece02f9f0
228 changed files with 5033 additions and 2310 deletions
Download patch file Download diff file Expand all files Collapse all files

8
lisp/emacs-lisp/backtrace.el
View file

@ -48,7 +48,6 @@
Set to nil to disable fontification, which may be necessary in
order to debug the code that does fontification."
:type 'boolean
:group 'backtrace
:version "27.1")
(defcustom backtrace-line-length 5000
@ -59,7 +58,6 @@ shorter than this, but success is not guaranteed. If set to nil
or zero, backtrace mode will not abbreviate the forms it prints."
:type '(choice natnum
(const :value nil :tag "Don't abbreviate"))
:group 'backtrace
:version "27.1")
;;; Backtrace frame data structure
@ -877,14 +875,12 @@ followed by `backtrace-print-frame', once for each stack frame."
;; (set-buffer-multibyte t)
(setq-local revert-buffer-function #'backtrace-revert)
(setq-local filter-buffer-substring-function #'backtrace--filter-visible)
(setq-local indent-line-function 'lisp-indent-line)
(setq-local indent-region-function 'lisp-indent-region)
(setq-local indent-line-function #'lisp-indent-line)
(setq-local indent-region-function #'lisp-indent-region)
(add-function :around (local 'cl-print-expand-ellipsis-function)
#'backtrace--expand-ellipsis)
(add-hook 'xref-backend-functions #'backtrace--xref-backend nil t))
(put 'backtrace-mode 'mode-class 'special)
;;; Backtrace printing
;;;###autoload

86
lisp/emacs-lisp/bytecomp.el
View file

@ -2947,9 +2947,8 @@ FUN should be an interpreted closure."
(push `(,(car binding) ',(cdr binding)) renv))
((eq binding t))
(t (push `(defvar ,binding) body))))
(if (null renv)
`(lambda ,args ,@preamble ,@body)
`(let ,renv (lambda ,args ,@preamble ,@body)))))
(let ((fun `(lambda ,args ,@preamble ,@body)))
(if renv `(let ,renv ,fun) fun))))
;;;###autoload
(defun byte-compile (form)
@ -4230,7 +4229,7 @@ This function is never called when `lexical-binding' is nil."
(pcase (length form)
(1
;; No args: use the identity value for the operation.
(byte-compile-constant (eval form)))
(byte-compile-constant (eval form lexical-binding)))
(2
;; One arg: compile (OP x) as (* x 1). This is identity for
;; all numerical values including -0.0, infinities and NaNs.
@ -4488,39 +4487,42 @@ being undefined (or obsolete) will be suppressed.
If CONDITION's value is (not (featurep \\='emacs)) or (featurep \\='xemacs),
that suppresses all warnings during execution of BODY."
(declare (indent 1) (debug t))
`(let* ((fbound-list (byte-compile-find-bound-condition
,condition '(fboundp functionp)
byte-compile-unresolved-functions))
(bound-list (byte-compile-find-bound-condition
,condition '(boundp default-boundp local-variable-p)))
(new-bound-list
;; (seq-difference byte-compile-bound-variables))
(delq nil (mapcar (lambda (s)
(if (memq s byte-compile-bound-variables) nil s))
bound-list)))
;; Maybe add to the bound list.
(byte-compile-bound-variables
(append new-bound-list byte-compile-bound-variables)))
(mapc #'byte-compile--check-prefixed-var new-bound-list)
(unwind-protect
;; If things not being bound at all is ok, so must them being
;; obsolete. Note that we add to the existing lists since Tramp
;; (ab)uses this feature.
;; FIXME: If `foo' is obsoleted by `bar', the code below
;; correctly arranges to silence the warnings after testing
;; existence of `foo', but the warning should also be
;; silenced after testing the existence of `bar'.
(let ((byte-compile-not-obsolete-vars
(append byte-compile-not-obsolete-vars bound-list))
(byte-compile-not-obsolete-funcs
(append byte-compile-not-obsolete-funcs fbound-list)))
,@body)
;; Maybe remove the function symbol from the unresolved list.
(dolist (fbound fbound-list)
(when fbound
(setq byte-compile-unresolved-functions
(delq (assq fbound byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))))
`(byte-compile--maybe-guarded ,condition (lambda () ,@body)))
(defun byte-compile--maybe-guarded (condition body-fun)
(let* ((fbound-list (byte-compile-find-bound-condition
condition '(fboundp functionp)
byte-compile-unresolved-functions))
(bound-list (byte-compile-find-bound-condition
condition '(boundp default-boundp local-variable-p)))
(new-bound-list
;; (seq-difference byte-compile-bound-variables))
(delq nil (mapcar (lambda (s)
(if (memq s byte-compile-bound-variables) nil s))
bound-list)))
;; Maybe add to the bound list.
(byte-compile-bound-variables
(append new-bound-list byte-compile-bound-variables)))
(mapc #'byte-compile--check-prefixed-var new-bound-list)
(unwind-protect
;; If things not being bound at all is ok, so must them being
;; obsolete. Note that we add to the existing lists since Tramp
;; (ab)uses this feature.
;; FIXME: If `foo' is obsoleted by `bar', the code below
;; correctly arranges to silence the warnings after testing
;; existence of `foo', but the warning should also be
;; silenced after testing the existence of `bar'.
(let ((byte-compile-not-obsolete-vars
(append byte-compile-not-obsolete-vars bound-list))
(byte-compile-not-obsolete-funcs
(append byte-compile-not-obsolete-funcs fbound-list)))
(funcall body-fun))
;; Maybe remove the function symbol from the unresolved list.
(dolist (fbound fbound-list)
(when fbound
(setq byte-compile-unresolved-functions
(delq (assq fbound byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))))
(defun byte-compile-if (form)
(byte-compile-form (car (cdr form)))
@ -4551,8 +4553,10 @@ that suppresses all warnings during execution of BODY."
;; and the other is a constant expression whose value can be
;; compared with `eq' (with `macroexp-const-p').
(or
(and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 (eval obj2)))
(and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 (eval obj1)))))
(and (symbolp obj1) (macroexp-const-p obj2)
(cons obj1 (eval obj2 lexical-binding)))
(and (symbolp obj2) (macroexp-const-p obj1)
(cons obj2 (eval obj1 lexical-binding)))))
(defun byte-compile--common-test (test-1 test-2)
"Most specific common test of `eq', `eql' and `equal'."
@ -4605,7 +4609,7 @@ Return (TAIL VAR TEST CASES), where:
;; Require a non-empty body, since the member
;; function value depends on the switch argument.
body
(let ((value (eval expr)))
(let ((value (eval expr lexical-binding)))
(and (proper-list-p value)
(progn
(setq switch-var var)
@ -5175,7 +5179,7 @@ binding slots have been popped."
(if (null fun)
(message "Macro %s unrecognized, won't work in file" name)
(message "Macro %s partly recognized, trying our luck" name)
(push (cons name (eval fun))
(push (cons name (eval fun lexical-binding))
byte-compile-macro-environment)))
(byte-compile-keep-pending form))))

29
lisp/emacs-lisp/checkdoc.el
View file

@ -1694,35 +1694,6 @@ function,command,variable,option or symbol." ms1))))))
(if ret
(checkdoc-create-error ret mb me)
nil)))
;; * Format the documentation string so that it fits in an
;; Emacs window on an 80-column screen. It is a good idea
;; for most lines to be no wider than 60 characters. The
;; first line can be wider if necessary to fit the
;; information that ought to be there.
(save-excursion
(let* ((start (point))
(eol nil)
;; Respect this file local variable.
(max-column (max 80 byte-compile-docstring-max-column))
;; Allow the first line to be three characters longer, to
;; fit the leading ` "' while still having a docstring
;; shorter than e.g. 80 characters.
(first t)
(get-max-column (lambda () (+ max-column (if first 3 0)))))
(while (and (< (point) e)
(or (progn (end-of-line) (setq eol (point))
(< (current-column) (funcall get-max-column)))
(progn (beginning-of-line)
(re-search-forward "\\\\\\\\[[<{]"
eol t))
(checkdoc-in-sample-code-p start e)))
(setq first nil)
(forward-line 1))
(end-of-line)
(if (and (< (point) e) (> (current-column) (funcall get-max-column)))
(checkdoc-create-error
(format "Some lines are over %d columns wide" max-column)
s (save-excursion (goto-char s) (line-end-position))))))
;; Here we deviate to tests based on a variable or function.
;; We must do this before checking for symbols in quotes because there
;; is a chance that just such a symbol might really be an argument.

29
lisp/emacs-lisp/cl-generic.el
View file

@ -1082,13 +1082,36 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
nil t)
(re-search-forward base-re nil t))))
;; WORKAROUND: This can't be a defconst due to bug#21237.
(defvar cl--generic-find-defgeneric-regexp "(\\(?:cl-\\)?defgeneric[ \t]+%s\\_>")
(defun cl--generic-search-method-make-form-matcher (met-name)
(let ((name (car met-name))
(qualifiers (cadr met-name))
(specializers (cddr met-name)))
(lambda (form)
(pcase form
(`(cl-generic-define-method
(function ,(pred (eq name)))
(quote ,(and (pred listp) m-qualifiers))
(quote ,(and (pred listp) m-args))
,_call-con
,_function)
(ignore-errors
(let* ((m-spec-args (car (cl--generic-split-args m-args)))
(m-specializers
(mapcar (lambda (spec-arg)
(if (eq '&context (car-safe (car spec-arg)))
spec-arg (cdr spec-arg)))
m-spec-args)))
(and (equal qualifiers m-qualifiers)
(equal specializers m-specializers)))))))))
(defconst cl--generic-find-defgeneric-regexp "(\\(?:cl-\\)?defgeneric[ \t]+%s\\_>")
(with-eval-after-load 'find-func
(defvar find-function-regexp-alist)
(add-to-list 'find-function-regexp-alist
`(cl-defmethod . ,#'cl--generic-search-method))
`(cl-defmethod
. (,#'cl--generic-search-method
. ,#'cl--generic-search-method-make-form-matcher)))
(add-to-list 'find-function-regexp-alist
'(cl-defgeneric . cl--generic-find-defgeneric-regexp)))

8
lisp/emacs-lisp/cl-lib.el
View file

@ -154,12 +154,10 @@ to an element already in the list stored in PLACE.
`(setq ,place (cl-adjoin ,x ,place ,@keys)))
`(cl-callf2 cl-adjoin ,x ,place ,@keys)))
(defun cl--set-buffer-substring (start end val)
(defun cl--set-buffer-substring (start end val &optional inherit)
"Delete region from START to END and insert VAL."
(save-excursion (delete-region start end)
(goto-char start)
(insert val)
val))
(replace-region-contents start end val 0 nil inherit)
val)
(defun cl--set-substring (str start end val)
(if end (if (< end 0) (incf end (length str)))

79
lisp/emacs-lisp/cl-macs.el
View file

@ -2072,7 +2072,8 @@ a `let' form, except that the list of symbols can be computed at run-time."
Each definition can take the form (FUNC EXP) where FUNC is the function
name, and EXP is an expression that returns the function value to which
it should be bound, or it can take the more common form (FUNC ARGLIST
BODY...) which is a shorthand for (FUNC (lambda ARGLIST BODY)).
BODY...) which is a shorthand for (FUNC (lambda ARGLIST BODY))
where BODY is wrapped in a `cl-block' named FUNC.
FUNC is defined only within FORM, not BODY, so you can't write recursive
function definitions. Use `cl-labels' for that. See Info node
@ -2276,13 +2277,17 @@ Like `cl-flet' but the definitions can refer to previous ones.
(defmacro cl-labels (bindings &rest body)
"Make local (recursive) function definitions.
BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...)
where FUNC is the function name, ARGLIST its arguments, and BODY the
forms of the function body.
Each definition can take the form (FUNC EXP) where FUNC is the function
name, and EXP is an expression that returns the function value to which
it should be bound, or it can take the more common form (FUNC ARGLIST
BODY...) which is a shorthand for (FUNC (lambda ARGLIST BODY))
where BODY is wrapped in a `cl-block' named FUNC.
FUNC is defined in any BODY, as well as FORM, so you can write recursive
and mutually recursive function definitions. See Info node
`(cl) Function Bindings' for details.
FUNC is in scope in any BODY or EXP, as well as in FORM, so you can write
recursive and mutually recursive function definitions, with the caveat
that EXPs are evaluated in sequence and you cannot call a FUNC before its
EXP has been evaluated.
See Info node `(cl) Function Bindings' for details.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug cl-flet))
@ -2575,6 +2580,50 @@ See also `macroexp-let2'."
collect `(,(car name) ,gensym))
,@body)))))
;;;###autoload
(defmacro cl-with-accessors (bindings instance &rest body)
"Use BINDINGS as function calls on INSTANCE inside BODY.
This macro helps when writing code that makes repeated use of the
accessor functions of a structure or object instance, such as those
created by `cl-defstruct' and `defclass'.
BINDINGS is a list of (NAME ACCESSOR) pairs. Inside BODY, NAME is
treated as the function call (ACCESSOR INSTANCE) using
`cl-symbol-macrolet'. NAME can be used with `setf' and `setq' as a
generalized variable. Because of how the accessor is used,
`cl-with-accessors' can be used with any generalized variable that can
take a single argument, such as `car' and `cdr'.
See also the macro `with-slots' described in the Info
node `(eieio)Accessing Slots', which is similar, but uses slot names
instead of accessor functions.
\(fn ((NAME ACCESSOR) ...) INSTANCE &rest BODY)"
(declare (debug [(&rest (symbolp symbolp)) form body])
(indent 2))
(cond ((null body)
(macroexp-warn-and-return "`cl-with-accessors' used with empty body"
nil 'empty-body))
((null bindings)
(macroexp-warn-and-return "`cl-with-accessors' used without accessors"
(macroexp-progn body)
'suspicious))
(t
(cl-once-only (instance)
(let ((symbol-macros))
(dolist (b bindings)
(pcase b
(`(,(and (pred symbolp) var)
,(and (pred symbolp) accessor))
(push `(,var (,accessor ,instance))
symbol-macros))
(_
(error "Malformed `cl-with-accessors' binding: %S" b))))
`(cl-symbol-macrolet
,symbol-macros
,@body))))))
;;; Multiple values.
;;;###autoload
@ -3229,7 +3278,8 @@ To see the documentation for a defined struct type, use
;; and pred-check, so changing it is not straightforward.
(push `(,defsym ,accessor (cl-x)
,(let ((long-docstring
(format "Access slot \"%s\" of `%s' struct CL-X." slot name)))
(format "Access slot \"%s\" of `%s' struct X."
slot name)))
(concat
;; NB. This will produce incorrect results
;; in some cases, as our coding conventions
@ -3246,15 +3296,22 @@ To see the documentation for a defined struct type, use
80))
(concat
(internal--format-docstring-line
"Access slot \"%s\" of CL-X." slot)
"Access slot \"%s\" of X." slot)
"\n"
(internal--format-docstring-line
"Struct CL-X is a `%s'." name))
"Struct X is a `%s'." name))
(internal--format-docstring-line long-docstring))
(if doc (concat "\n" doc) "")))
(if doc (concat "\n" doc) "")
"\n"
(format "\n\n(fn %s X)" accessor)))
(declare (side-effect-free t))
,access-body)
forms)
;; FIXME: This hack is to document this as a generalized
;; variable, despite it not having the `gv-expander'
;; property. See `help-fns--generalized-variable'.
(push `(function-put ',accessor 'document-generalized-variable t)
forms)
(when (oddp (length desc))
(push
(macroexp-warn-and-return

16
lisp/emacs-lisp/cl-preloaded.el
View file

@ -292,7 +292,13 @@
(:include cl--class)
(:noinline t)
(:constructor nil)
(:constructor built-in-class--make (name docstring parents))
(:constructor built-in-class--make
(name docstring parent-types
&aux (parents
(mapcar (lambda (type)
(or (get type 'cl--class)
(error "Unknown type: %S" type)))
parent-types))))
(:copier nil))
"Type descriptors for built-in types.
The `slots' (and hence `index-table') are currently unused."
@ -322,13 +328,7 @@ The `slots' (and hence `index-table') are currently unused."
;; (message "Missing predicate for: %S" name)
nil)
(put ',name 'cl--class
(built-in-class--make ',name ,docstring
(mapcar (lambda (type)
(let ((class (get type 'cl--class)))
(unless class
(error "Unknown type: %S" type))
class))
',parents))))))
(built-in-class--make ',name ,docstring ',parents)))))
;; FIXME: Our type DAG has various quirks:
;; - Some `keyword's are also `symbol-with-pos' but that's not reflected

12
lisp/emacs-lisp/comp.el
View file

@ -2027,15 +2027,11 @@ TARGET-BB-SYM is the symbol name of the target block."
(call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag)))
(set ,(and (pred comp-mvar-p) mvar-3)
(call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2)))
(cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2))
(cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,_bb1 ,bb2))
(comp--emit-assume 'and mvar-tested
(make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
(comp--add-cond-cstrs-target-block b bb2)
nil)
(comp--emit-assume 'and mvar-tested
(make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
(comp--add-cond-cstrs-target-block b bb1)
t))
(make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
(comp--add-cond-cstrs-target-block b bb2)
nil))
(`((set ,(and (pred comp-mvar-p) cmp-res)
(,(pred comp--call-op-p)
,(and (or (pred comp--equality-fun-p)

6
lisp/emacs-lisp/edebug.el
View file

@ -1288,7 +1288,7 @@ infinite loops when the code/environment contains a circular object.")
(while (not (eq sexp (setq sexp (edebug-unwrap sexp)))))
(cond
((consp sexp)
(or (gethash sexp edebug--unwrap-cache nil)
(or (gethash sexp edebug--unwrap-cache)
(let ((remainder sexp)
(current (cons nil nil)))
(prog1 current
@ -1303,8 +1303,8 @@ infinite loops when the code/environment contains a circular object.")
(setf (cdr current)
(edebug-unwrap* remainder))
nil)
((gethash remainder edebug--unwrap-cache nil)
(setf (cdr current) (gethash remainder edebug--unwrap-cache nil))
((gethash remainder edebug--unwrap-cache)
(setf (cdr current) (gethash remainder edebug--unwrap-cache))
nil)
(t (setq current
(setf (cdr current) (cons nil nil)))))))))))

51
lisp/emacs-lisp/eieio.el
View file

@ -1,10 +1,10 @@
;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*-
;;; or maybe Eric's Implementation of Emacs Interpreted Objects
;; Copyright (C) 1995-1996, 1998-2025 Free Software Foundation, Inc.
;; Copyright (C) 1995-2025 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 1.4
;; Old-Version: 1.4
;; Keywords: OO, lisp
;; This file is part of GNU Emacs.
@ -44,14 +44,6 @@
;;; Code:
(defvar eieio-version "1.4"
"Current version of EIEIO.")
(defun eieio-version ()
"Display the current version of EIEIO."
(interactive)
(message eieio-version))
(require 'eieio-core)
(eval-when-compile (require 'subr-x))
@ -297,20 +289,22 @@ and reference them using the function `class-option'."
`(defun ,name (&rest slots)
,(internal--format-docstring-line
"Create a new object of class type `%S'." name)
(declare (compiler-macro
(lambda (whole)
(if (not (stringp (car slots)))
whole
(macroexp-warn-and-return
(format "Obsolete name arg %S to constructor %S"
(car slots) (car whole))
;; Keep the name arg, for backward compatibility,
;; but hide it so we don't trigger indefinitely.
`(,(car whole) (identity ,(car slots))
,@(cdr slots))
nil nil (car slots))))))
(declare (compiler-macro eieio--constructor-macro))
(apply #'make-instance ',name slots))))))
(defun eieio--constructor-macro (whole &rest slots)
(if (or (null slots) (keywordp (car slots))
;; Detect the second pass!
(eq 'identity (car-safe (car slots))))
whole
(macroexp-warn-and-return
(format "Obsolete name arg %S to constructor %S"
(car slots) (car whole))
;; Keep the name arg, for backward compatibility,
;; but hide it so we don't trigger indefinitely.
`(,(car whole) (identity ,(car slots))
,@(cdr slots))
nil nil (car slots))))
;;; Get/Set slots in an object.
;;
@ -1004,6 +998,19 @@ of `eq'."
(error "EIEIO: `change-class' is unimplemented"))
(define-obsolete-function-alias 'change-class #'eieio-change-class "26.1")
;;; Obsolete
;;
(make-obsolete-variable 'eieio-version 'emacs-version "31.1")
(defvar eieio-version "1.4"
"Current version of EIEIO.")
(defun eieio-version ()
"Display the current version of EIEIO."
(declare (obsolete emacs-version "31.1"))
(interactive)
(message eieio-version))
(provide 'eieio)
;;; eieio.el ends here

18
lisp/emacs-lisp/eldoc.el
View file

@ -138,6 +138,14 @@ is only skipped if the documentation needs to be truncated there."
(const :tag "Skip echo area if truncating" maybe))
:version "28.1")
(defcustom eldoc-help-at-pt nil
"If non-nil, show `help-at-pt-kbd-string' at point via Eldoc.
This setting is an alternative to `help-at-pt-display-when-idle'. If
the value is non-nil, `eldoc-show-help-at-pt' will show help-at-point
via Eldoc."
:type 'boolean
:version "31.1")
(defface eldoc-highlight-function-argument
'((t (:inherit bold)))
"Face used for the argument at point in a function's argument list.
@ -410,7 +418,7 @@ Also store it in `eldoc-last-message' and return that value."
(overlay-end show-paren--overlay)))))))
(defvar eldoc-documentation-functions nil
(defvar eldoc-documentation-functions (list #'eldoc-show-help-at-pt)
"Hook of functions that produce doc strings.
A doc string is typically relevant if point is on a function-like
@ -957,6 +965,12 @@ the docstrings eventually produced, using
(setq eldoc--last-request-state token)
(eldoc--invoke-strategy nil))))))
(defun eldoc-show-help-at-pt (&rest _)
"Show help at point via Eldoc if `eldoc-help-at-pt' is non-nil.
Intended for `eldoc-documentation-functions' (which see)."
(when-let* ((help (and eldoc-help-at-pt (help-at-pt-kbd-string))))
(format "Help: %s" (substitute-command-keys help))))
;; This section only affects ElDoc output to the echo area, as in
;; `eldoc-display-in-echo-area'.
@ -994,7 +1008,7 @@ the docstrings eventually produced, using
;; Prime the command list.
(eldoc-add-command-completions
"back-to-indentation"
"comment-indent-new-line" "delete-char" "back-to-indentation"
"backward-" "beginning-of-" "delete-other-windows" "delete-window"
"down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-"
"handle-select-window" "indent-for-tab-command" "left-" "mark-page"

38
lisp/emacs-lisp/ert.el
View file

@ -422,16 +422,23 @@ and aborts the current test as failed if it doesn't."
(cl-defmacro should-error (form &rest keys &key type exclude-subtypes)
"Evaluate FORM and check that it signals an error.
The error signaled needs to match TYPE. TYPE should be a list
of condition names. (It can also be a non-nil symbol, which is
equivalent to a singleton list containing that symbol.) If
EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its
condition names is an element of TYPE. If EXCLUDE-SUBTYPES is
non-nil, the error matches TYPE if it is an element of TYPE.
If no error was signaled, abort the test as failed and
return (ERROR-SYMBOL . DATA) from the error.
If the error matches, returns (ERROR-SYMBOL . DATA) from the
error. If not, or if no error was signaled, abort the test as
failed."
You can also match specific errors using the KEYWORD-ARGS arguments,
which is specified as keyword/argument pairs. The following arguments
are defined:
:type TYPE -- If TYPE is non-nil, the error signaled needs to match
TYPE. TYPE should be a list of condition names. It can also be a
symbol, which is equivalent to a one-element list containing that
symbol.
:exclude-subtypes EXCLUDED -- If EXCLUDED is non-nil, the error matches
TYPE only if it is an element of TYPE. If nil (the default), the error
matches TYPE if one of its condition names is an element of TYPE.
\(fn FORM &rest KEYWORD-ARGS)"
(declare (debug t))
(unless type (setq type ''error))
(ert--expand-should
@ -662,6 +669,19 @@ Return nil if they are."
(put 'equal-including-properties 'ert-explainer
'ert--explain-equal-including-properties)
(defun ert--explain-time-equal-p (a b)
"Explainer function for `time-equal-p'.
A and B are the time values to compare."
(declare (ftype (function (t t) list))
(side-effect-free t))
(unless (time-equal-p a b)
`(different-time-values
,(format-time-string "%F %T.%N%z" a t)
,(format-time-string "%F %T.%N%z" b t)
difference
,(format-time-string "%s.%N" (time-subtract a b) t))))
(function-put #'time-equal-p 'ert-explainer #'ert--explain-time-equal-p)
;;; Implementation of `ert-info'.
;; TODO(ohler): The name `info' clashes with

61
lisp/emacs-lisp/find-func.el
View file

@ -144,6 +144,16 @@ Instead of regexp variable, types can be mapped to functions as well,
in which case the function is called with one argument (the object
we're looking for) and it should search for it.
A value can also be a cons (REGEX . EXPANDED-FORM-MATCHER-FACTORY).
REGEX is as above; EXPANDED-FORM-MATCHER-FACTORY is a function of one
argument, the same object we'd pass to a REGEX function; it should return
another function of one argument that returns non-nil if we're looking at
a macroexpanded form that defines the object we're looking for.
If you want to use EXPANDED-FORM-MATCHER-FACTORY exclusively, you can
set REGEX to a never-match regexp, and force the fallback to
EXPANDED-FORM-MATCHER-FACTORY. EXPANDED-FORM-MATCHER-FACTORY is
called with the buffer to search the current one.
Symbols can have their own version of this alist on
the property `find-function-type-alist'.
See the function `find-function-update-type-alist'.")
@ -434,7 +444,13 @@ The search is done in the source for library LIBRARY."
(regexp-symbol
(or (and (symbolp symbol)
(alist-get type (get symbol 'find-function-type-alist)))
(alist-get type find-function-regexp-alist))))
(alist-get type find-function-regexp-alist)))
(form-matcher-factory
(and (functionp (cdr-safe regexp-symbol))
(cdr regexp-symbol)))
(regexp-symbol (if form-matcher-factory
(car regexp-symbol)
regexp-symbol)))
(with-current-buffer (find-file-noselect filename)
(let ((regexp (if (functionp regexp-symbol) regexp-symbol
(format (symbol-value regexp-symbol)
@ -474,7 +490,8 @@ The search is done in the source for library LIBRARY."
;; expands macros until it finds the symbol.
(cons (current-buffer)
(find-function--search-by-expanding-macros
(current-buffer) symbol type))))))))))
(current-buffer) symbol type
form-matcher-factory))))))))))
;;;###autoload
(defun find-function-update-type-alist (symbol type variable)
@ -506,19 +523,13 @@ Return t if any PRED returns t."
(find-function--any-subform-p left-child pred)
(find-function--any-subform-p right-child pred))))))
(defun find-function--search-by-expanding-macros (buf symbol type)
(defun find-function--search-by-expanding-macros
(buf symbol type matcher-factory)
"Expand macros in BUF to search for the definition of SYMBOL of TYPE."
(catch 'found
(with-current-buffer buf
(save-excursion
(goto-char (point-min))
(condition-case nil
(while t
(let ((form (read (current-buffer)))
(expected-symbol-p
(lambda (form)
(cond
((null type)
(with-current-buffer buf
(when-let* ((expected-symbol-p
(cond ((null type)
(lambda (form)
;; Check if a given form is a `defalias' to
;; SYM, the function name we are searching
;; for. All functions in Emacs Lisp
@ -526,20 +537,28 @@ Return t if any PRED returns t."
;; after several steps of macroexpansion.
(and (eq (car-safe form) 'defalias)
(equal (car-safe (cdr form))
`(quote ,symbol))))
((eq type 'defvar)
`(quote ,symbol)))))
((eq type 'defvar)
(lambda (form)
;; Variables generated by macros ultimately
;; expand to `defvar'.
(and (eq (car-safe form) 'defvar)
(eq (car-safe (cdr form)) symbol)))
(t nil)))))
(eq (car-safe (cdr form)) symbol))))
(matcher-factory
(funcall matcher-factory symbol)))))
(catch 'found
(save-excursion
(goto-char (point-min))
(condition-case nil
(while t
(when (find-function--any-subform-p
(find-function--try-macroexpand form)
(find-function--try-macroexpand
(read (current-buffer)))
expected-symbol-p)
;; We want to return the location at the beginning
;; of the macro, so move back one sexp.
(throw 'found (progn (backward-sexp) (point))))))
(end-of-file nil))))))
(throw 'found (progn (backward-sexp) (point)))))
(end-of-file nil)))))))
(defun find-function-library (function &optional lisp-only verbose)
"Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION.

12
lisp/emacs-lisp/gv.el
View file

@ -317,11 +317,14 @@ The return value is the last VAL in the list.
;;;###autoload
(defmacro incf (place &optional delta)
"Increment PLACE by DELTA (default to 1).
"Increment generalized variable PLACE by DELTA (default to 1).
The DELTA is first added to PLACE, and then stored in PLACE.
Return the incremented value of PLACE.
For more information about generalized variables, see Info node
`(elisp) Generalized Variables'.
See also `decf'."
(declare (debug (gv-place &optional form)))
(gv-letplace (getter setter) place
@ -329,11 +332,14 @@ See also `decf'."
;;;###autoload
(defmacro decf (place &optional delta)
"Decrement PLACE by DELTA (default to 1).
"Decrement generalized variable PLACE by DELTA (default to 1).
The DELTA is first subtracted from PLACE, and then stored in PLACE.
Return the decremented value of PLACE.
For more information about generalized variables, see Info node
`(elisp) Generalized Variables'.
See also `incf'."
(declare (debug (gv-place &optional form)))
(gv-letplace (getter setter) place
@ -678,6 +684,8 @@ REF must have been previously obtained with `gv-ref'."
`(insert (prog1 ,store (erase-buffer))))
(make-obsolete-generalized-variable 'buffer-string nil "29.1")
;; FIXME: Can't use `replace-region-contents' because it's not
;; expected to be costly, so we need to pass MAX-SECS==0.
(gv-define-simple-setter buffer-substring cl--set-buffer-substring)
(make-obsolete-generalized-variable 'buffer-substring nil "29.1")

3
lisp/emacs-lisp/map.el
View file

@ -403,8 +403,7 @@ If MAP is a plist, TESTFN defaults to `eq'."
(cl-defmethod map-contains-key ((map hash-table) key &optional _testfn)
"Return non-nil if MAP contains KEY, ignoring TESTFN."
(let ((v '(nil)))
(not (eq v (gethash key map v)))))
(hash-table-contains-p key map))
(cl-defgeneric map-some (pred map)
"Return the first non-nil value from applying PRED to elements of MAP.

2
lisp/emacs-lisp/shortdoc.el
View file

@ -710,6 +710,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
"Other Hash Table Functions"
(hash-table-p
:eval (hash-table-p 123))
(hash-table-contains-p
:no-eval (hash-table-contains-p 'key table))
(copy-hash-table
:no-eval (copy-hash-table table)
:result-string "#s(hash-table ...)")

2
lisp/emacs-lisp/smie.el
View file

@ -2063,7 +2063,7 @@ position corresponding to each rule."
(interactive "P")
(let ((trace (cdr (smie-config--get-trace))))
(cond
((null trace) (message "No SMIE rules involved"))
((null trace) (message "No SMIE rules involved at this position"))
((not arg)
(message "Rules used: %s"
(mapconcat (lambda (elem)

54
lisp/emacs-lisp/subr-x.el
View file

@ -281,35 +281,6 @@ the string."
(declare (pure t) (side-effect-free t))
(string-remove-suffix "\n" string))
(defun replace-region-contents (beg end replace-fn
&optional max-secs max-costs)
"Replace the region between BEG and END using REPLACE-FN.
REPLACE-FN runs on the current buffer narrowed to the region. It
should return either a string or a buffer replacing the region.
The replacement is performed using `replace-buffer-contents'
which also describes the MAX-SECS and MAX-COSTS arguments and the
return value.
Note: If the replacement is a string, it'll be placed in a
temporary buffer so that `replace-buffer-contents' can operate on
it. Therefore, if you already have the replacement in a buffer,
it makes no sense to convert it to a string using
`buffer-substring' or similar."
(save-excursion
(save-restriction
(narrow-to-region beg end)
(goto-char (point-min))
(let ((repl (funcall replace-fn)))
(if (bufferp repl)
(replace-buffer-contents repl max-secs max-costs)
(let ((source-buffer (current-buffer)))
(with-temp-buffer
(insert repl)
(let ((tmp-buffer (current-buffer)))
(set-buffer source-buffer)
(replace-buffer-contents tmp-buffer max-secs max-costs)))))))))
;;;###autoload
(defmacro named-let (name bindings &rest body)
"Looping construct taken from Scheme.
@ -389,8 +360,8 @@ buffer when possible, instead of creating a new one on each call."
;;;###autoload
(defun string-pixel-width (string &optional buffer)
"Return the width of STRING in pixels.
If BUFFER is non-nil, use the face remappings from that buffer when
determining the width.
If BUFFER is non-nil, use the face remappings, alternative and default
properties from that buffer when determining the width.
If you call this function to measure pixel width of a string
with embedded newlines, it returns the width of the widest
substring that does not include newlines."
@ -400,11 +371,14 @@ substring that does not include newlines."
;; Keeping a work buffer around is more efficient than creating a
;; new temporary buffer.
(with-work-buffer
(if buffer
(setq-local face-remapping-alist
(with-current-buffer buffer
face-remapping-alist))
(kill-local-variable 'face-remapping-alist))
;; Setup current buffer to correctly compute pixel width.
(when buffer
(dolist (v '(face-remapping-alist
char-property-alias-alist
default-text-properties))
(if (local-variable-p v buffer)
(set (make-local-variable v)
(buffer-local-value v buffer)))))
;; Avoid deactivating the region as side effect.
(let (deactivate-mark)
(insert string))
@ -413,12 +387,8 @@ substring that does not include newlines."
;; (bug#59311). Disable `line-prefix' and `wrap-prefix',
;; for the same reason.
(add-text-properties
(point-min) (point-max) '(display-line-numbers-disable t))
;; Prefer `remove-text-properties' to `propertize' to avoid
;; creating a new string on each call.
(remove-text-properties
(point-min) (point-max) '(line-prefix nil wrap-prefix nil))
(setq line-prefix nil wrap-prefix nil)
(point-min) (point-max)
'(display-line-numbers-disable t line-prefix "" wrap-prefix ""))
(car (buffer-text-pixel-size nil nil t)))))
;;;###autoload

4
lisp/emacs-lisp/testcover.el
View file

@ -296,7 +296,7 @@ iteratively copies its cdr. When VECP is non-nil, copy
vectors as well as conses."
(if (and (atom obj) (or (not vecp) (not (vectorp obj))))
obj
(let ((copy (gethash obj hash-table nil)))
(let ((copy (gethash obj hash-table)))
(unless copy
(cond
((consp obj)
@ -315,7 +315,7 @@ vectors as well as conses."
(testcover--copy-object1 rest vecp hash-table))
nil)
((gethash rest hash-table nil)
(setf (cdr current) (gethash rest hash-table nil))
(setf (cdr current) (gethash rest hash-table))
nil)
(t (setq current
(setf (cdr current) (cons nil nil)))))))))

7
lisp/emacs-lisp/warnings.el
View file

@ -373,9 +373,10 @@ entirely by setting `warning-suppress-types' or
(let ((window (display-buffer
buffer
(when warning-display-at-bottom
'(display-buffer--maybe-at-bottom
(window-height . (lambda (window)
(fit-window-to-buffer window 10)))
`(display-buffer--maybe-at-bottom
(window-height
. ,(lambda (window)
(fit-window-to-buffer window 10)))
(category . warning))))))
(when (and window (markerp warning-series)
(eq (marker-buffer warning-series) buffer))