summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/byte-opt.el72
-rw-r--r--lisp/emacs-lisp/byte-run.el19
-rw-r--r--lisp/emacs-lisp/bytecomp.el174
-rw-r--r--lisp/emacs-lisp/cconv.el6
-rw-r--r--lisp/emacs-lisp/cl-lib.el2
-rw-r--r--lisp/emacs-lisp/cl-macs.el13
-rw-r--r--lisp/emacs-lisp/comp.el46
-rw-r--r--lisp/emacs-lisp/easy-mmode.el10
-rw-r--r--lisp/emacs-lisp/eieio.el5
-rw-r--r--lisp/emacs-lisp/gv.el6
-rw-r--r--lisp/emacs-lisp/macroexp.el32
-rw-r--r--lisp/emacs-lisp/package.el1
-rw-r--r--lisp/emacs-lisp/pcase.el2
-rw-r--r--lisp/emacs-lisp/range.el8
14 files changed, 274 insertions, 122 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 937300cf0c0..4d39e28fc8e 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -410,7 +410,10 @@ for speeding up processing.")
(`(condition-case ,var ,exp . ,clauses)
`(,fn ,var ;Not evaluated.
- ,(byte-optimize-form exp for-effect)
+ ,(byte-optimize-form exp
+ (if (assq :success clauses)
+ (null var)
+ for-effect))
,@(mapcar (lambda (clause)
(let ((byte-optimize--lexvars
(and lexical-binding
@@ -755,7 +758,8 @@ for speeding up processing.")
((eq head 'list) (cdr form))
((memq head
;; FIXME: Replace this list with a function property?
- '( length safe-length cons lambda
+ '( lambda internal-make-closure
+ length safe-length cons
string unibyte-string make-string concat
format format-message
substring substring-no-properties string-replace
@@ -971,6 +975,43 @@ for speeding up processing.")
(t ;; Moving the constant to the end can enable some lapcode optimizations.
(list (car form) (nth 2 form) (nth 1 form)))))
+(defun byte-opt--nary-comparison (form)
+ "Optimise n-ary comparisons such as `=', `<' etc."
+ (let ((nargs (length (cdr form))))
+ (cond
+ ((= nargs 1)
+ `(progn (cadr form) t))
+ ((>= nargs 3)
+ ;; At least 3 arguments: transform to N-1 binary comparisons,
+ ;; since those have their own byte-ops which are particularly
+ ;; fast for fixnums.
+ (let* ((op (car form))
+ (bindings nil)
+ (rev-args nil))
+ (if (memq nil (mapcar #'macroexp-copyable-p (cddr form)))
+ ;; At least one arg beyond the first is non-constant non-variable:
+ ;; create temporaries for all args to guard against side-effects.
+ ;; The optimiser will eliminate trivial bindings later.
+ (let ((i 1))
+ (dolist (arg (cdr form))
+ (let ((var (make-symbol (format "arg%d" i))))
+ (push var rev-args)
+ (push (list var arg) bindings)
+ (setq i (1+ i)))))
+ ;; All args beyond the first are copyable: no temporary variables
+ ;; required.
+ (setq rev-args (reverse (cdr form))))
+ (let ((prev (car rev-args))
+ (exprs nil))
+ (dolist (arg (cdr rev-args))
+ (push (list op arg prev) exprs)
+ (setq prev arg))
+ (let ((and-expr (cons 'and exprs)))
+ (if bindings
+ (list 'let (nreverse bindings) and-expr)
+ and-expr)))))
+ (t form))))
+
(defun byte-optimize-constant-args (form)
(let ((ok t)
(rest (cdr form)))
@@ -1126,13 +1167,18 @@ See Info node `(elisp) Integer Basics'."
(put 'max 'byte-optimizer #'byte-optimize-min-max)
(put 'min 'byte-optimizer #'byte-optimize-min-max)
-(put '= 'byte-optimizer #'byte-optimize-binary-predicate)
(put 'eq 'byte-optimizer #'byte-optimize-eq)
(put 'eql 'byte-optimizer #'byte-optimize-equal)
(put 'equal 'byte-optimizer #'byte-optimize-equal)
(put 'string= 'byte-optimizer #'byte-optimize-binary-predicate)
(put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate)
+(put '= 'byte-optimizer #'byte-opt--nary-comparison)
+(put '< 'byte-optimizer #'byte-opt--nary-comparison)
+(put '<= 'byte-optimizer #'byte-opt--nary-comparison)
+(put '> 'byte-optimizer #'byte-opt--nary-comparison)
+(put '>= 'byte-optimizer #'byte-opt--nary-comparison)
+
(put 'string-greaterp 'byte-optimizer #'byte-optimize-string-greaterp)
(put 'string> 'byte-optimizer #'byte-optimize-string-greaterp)
@@ -1297,11 +1343,8 @@ See Info node `(elisp) Integer Basics'."
(if else
`(progn ,condition ,@else)
condition))
- ;; (if X nil t) -> (not X)
- ((and (eq then nil) (eq else '(t)))
- `(not ,condition))
- ;; (if X t [nil]) -> (not (not X))
- ((and (eq then t) (or (null else) (eq else '(nil))))
+ ;; (if X t) -> (not (not X))
+ ((and (eq then t) (null else))
`(not ,(byte-opt--negate condition)))
;; (if VAR VAR X...) -> (or VAR (progn X...))
((and (symbolp condition) (eq condition then))
@@ -1379,6 +1422,9 @@ See Info node `(elisp) Integer Basics'."
;; (apply F ... (list X Y ...)) -> (funcall F ... X Y ...)
((eq (car-safe last) 'list)
`(funcall ,fn ,@(butlast (cddr form)) ,@(cdr last)))
+ ;; (apply F ... (cons X Y)) -> (apply F ... X Y)
+ ((eq (car-safe last) 'cons)
+ (append (butlast form) (cdr last)))
(t form)))
form)))
@@ -2223,18 +2269,12 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; goto ... --> goto <delete until TAG or end>
;; return ... --> return <delete until TAG or end>
- ;; (unless a jump-table is being used, where deleting may affect
- ;; other valid case bodies)
;;
((and (memq (car lap0) '(byte-goto byte-return))
- (not (memq (car lap1) '(TAG nil)))
- ;; FIXME: Instead of deferring simply when jump-tables are
- ;; being used, keep a list of tags used for switch tags and
- ;; use them instead (see `byte-compile-inline-lapcode').
- (not byte-compile-jump-tables))
+ (not (memq (car lap1) '(TAG nil))))
(setq tmp rest)
(let ((i 0)
- (opt-p (memq byte-optimize-log '(t lap)))
+ (opt-p (memq byte-optimize-log '(t byte)))
str deleted)
(while (and (setq tmp (cdr tmp))
(not (eq 'TAG (car (car tmp)))))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index eb7d026b146..9345665eea8 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -262,7 +262,8 @@ This is used by `declare'.")
(interactive-form nil)
(warnings nil)
(warn #'(lambda (msg form)
- (push (macroexp-warn-and-return msg nil nil t form)
+ (push (macroexp-warn-and-return
+ (format-message msg) nil nil t form)
warnings))))
(while
(and body
@@ -649,11 +650,11 @@ in `byte-compile-warning-types'; see the variable
`byte-compile-warnings' for a fuller explanation of the warning
types. The types that can be suppressed with this macro are
`free-vars', `callargs', `redefine', `obsolete',
-`interactive-only', `lexical', `mapcar', `constants' and
-`suspicious'.
+`interactive-only', `lexical', `mapcar', `constants',
+`suspicious' and `empty-body'.
For the `mapcar' case, only the `mapcar' function can be used in
-the symbol list. For `suspicious', only `set-buffer' and `lsh' can be used."
+the symbol list."
;; Note: during compilation, this definition is overridden by the one in
;; byte-compile-initial-macro-environment.
(declare (debug (sexp body)) (indent 1))
@@ -679,11 +680,11 @@ Otherwise, return nil. For internal use only."
;; This is called from lread.c and therefore needs to be preloaded.
(if lread--unescaped-character-literals
(let ((sorted (sort lread--unescaped-character-literals #'<)))
- (format-message "unescaped character literals %s detected, %s expected!"
- (mapconcat (lambda (char) (format "`?%c'" char))
- sorted ", ")
- (mapconcat (lambda (char) (format "`?\\%c'" char))
- sorted ", ")))))
+ (format "unescaped character literals %s detected, %s expected!"
+ (mapconcat (lambda (char) (format-message "`?%c'" char))
+ sorted ", ")
+ (mapconcat (lambda (char) (format-message "`?\\%c'" char))
+ sorted ", ")))))
(defun byte-compile-info (string &optional message type)
"Format STRING in a way that looks pleasing in the compilation output.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 5df1205869c..e8a8fe37756 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -295,7 +295,8 @@ The information is logged to `byte-compile-log-buffer'."
'(redefine callargs free-vars unresolved
obsolete noruntime interactive-only
make-local mapcar constants suspicious lexical lexical-dynamic
- docstrings docstrings-non-ascii-quotes not-unused)
+ docstrings docstrings-non-ascii-quotes not-unused
+ empty-body)
"The list of warning types used when `byte-compile-warnings' is t.")
(defcustom byte-compile-warnings t
"List of warnings that the byte-compiler should issue (t for almost all).
@@ -326,6 +327,7 @@ Elements of the list may be:
docstrings-non-ascii-quotes docstrings that have non-ASCII quotes.
This depends on the `docstrings' warning type.
suspicious constructs that usually don't do what the coder wanted.
+ empty-body body argument to a special form or macro is empty.
If the list begins with `not', then the remaining elements specify warnings to
suppress. For example, (not mapcar) will suppress warnings about mapcar.
@@ -541,15 +543,19 @@ Return the compile-time value of FORM."
;; Later `internal--with-suppressed-warnings' binds it again, this
;; time in order to affect warnings emitted during the
;; compilation itself.
- (let ((byte-compile--suppressed-warnings
- (append warnings byte-compile--suppressed-warnings)))
- ;; This function doesn't exist, but is just a placeholder
- ;; symbol to hook up with the
- ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery.
- `(internal--with-suppressed-warnings
- ',warnings
- ,(macroexpand-all `(progn ,@body)
- macroexpand-all-environment))))))
+ (if body
+ (let ((byte-compile--suppressed-warnings
+ (append warnings byte-compile--suppressed-warnings)))
+ ;; This function doesn't exist, but is just a placeholder
+ ;; symbol to hook up with the
+ ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery.
+ `(internal--with-suppressed-warnings
+ ',warnings
+ ,(macroexpand-all `(progn ,@body)
+ macroexpand-all-environment)))
+ (macroexp-warn-and-return
+ (format-message "`with-suppressed-warnings' with empty body")
+ nil '(empty-body with-suppressed-warnings) t warnings)))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
expanded by the compiler as when expanded by the interpreter.")
@@ -1569,7 +1575,7 @@ extra args."
"`%s' called with %d args to fill %d format field(s)" (car form)
nargs nfields)))))
-(dolist (elt '(format message error))
+(dolist (elt '(format message format-message error))
(put elt 'byte-compile-format-like t))
(defun byte-compile--suspicious-defcustom-choice (type)
@@ -1766,10 +1772,16 @@ It is too wide if it has any lines longer than the largest of
kind name col))
;; There's a "naked" ' character before a symbol/list, so it
;; should probably be quoted with \=.
- (when (string-match-p "\\( [\"#]\\|[ \t]\\|^\\)'[a-z(]" docs)
+ (when (string-match-p (rx (| (in " \t") bol)
+ (? (in "\"#"))
+ "'"
+ (in "A-Za-z" "("))
+ docs)
(byte-compile-warn-x
- name "%s%sdocstring has wrong usage of unescaped single quotes (use \\= or different quoting)"
- kind name))
+ name
+ (concat "%s%sdocstring has wrong usage of unescaped single quotes"
+ " (use \\=%c or different quoting such as %c...%c)")
+ kind name ?' ?` ?'))
;; There's a "Unicode quote" in the string -- it should probably
;; be an ASCII one instead.
(when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes)
@@ -3439,7 +3451,7 @@ lambda-expression."
(t "."))))
(if (eq (car-safe (symbol-function (car form))) 'macro)
(byte-compile-report-error
- (format "`%s' defined after use in %S (missing `require' of a library file?)"
+ (format-message "`%s' defined after use in %S (missing `require' of a library file?)"
(car form) form)))
(if (and handler
;; Make sure that function exists.
@@ -3736,7 +3748,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
'((0 . byte-compile-no-args)
(1 . byte-compile-one-arg)
(2 . byte-compile-two-args)
- (2-and . byte-compile-and-folded)
+ (2-cmp . byte-compile-cmp)
(3 . byte-compile-three-args)
(0-1 . byte-compile-zero-or-one-arg)
(1-2 . byte-compile-one-or-two-args)
@@ -3815,11 +3827,11 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-defop-compiler cons 2)
(byte-defop-compiler aref 2)
(byte-defop-compiler set 2)
-(byte-defop-compiler (= byte-eqlsign) 2-and)
-(byte-defop-compiler (< byte-lss) 2-and)
-(byte-defop-compiler (> byte-gtr) 2-and)
-(byte-defop-compiler (<= byte-leq) 2-and)
-(byte-defop-compiler (>= byte-geq) 2-and)
+(byte-defop-compiler (= byte-eqlsign) 2-cmp)
+(byte-defop-compiler (< byte-lss) 2-cmp)
+(byte-defop-compiler (> byte-gtr) 2-cmp)
+(byte-defop-compiler (<= byte-leq) 2-cmp)
+(byte-defop-compiler (>= byte-geq) 2-cmp)
(byte-defop-compiler get 2)
(byte-defop-compiler nth 2)
(byte-defop-compiler substring 1-3)
@@ -3883,18 +3895,20 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-compile-form (nth 2 form))
(byte-compile-out (get (car form) 'byte-opcode) 0)))
-(defun byte-compile-and-folded (form)
- "Compile calls to functions like `<='.
-These implicitly `and' together a bunch of two-arg bytecodes."
- (let ((l (length form)))
- (cond
- ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t)))
- ((= l 3) (byte-compile-two-args form))
- ;; Don't use `cl-every' here (see comment where we require cl-lib).
- ((not (memq nil (mapcar #'macroexp-copyable-p (nthcdr 2 form))))
- (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form))
- (,(car form) ,@(nthcdr 2 form)))))
- (t (byte-compile-normal-call form)))))
+(defun byte-compile-cmp (form)
+ "Compile calls to numeric comparisons such as `<', `=' etc."
+ ;; Lisp-level transforms should already have reduced valid calls to 2 args.
+ (if (not (= (length form) 3))
+ (byte-compile-subr-wrong-args form "1 or more")
+ (byte-compile-two-args
+ (if (macroexp-const-p (nth 1 form))
+ ;; First argument is constant: flip it so that the constant
+ ;; is last, which may allow more lapcode optimisations.
+ (let* ((op (car form))
+ (flipped-op (cdr (assq op '((< . >) (<= . >=)
+ (> . <) (>= . <=) (= . =))))))
+ (list flipped-op (nth 2 form) (nth 1 form)))
+ form))))
(defun byte-compile-three-args (form)
(if (not (= (length form) 4))
@@ -4049,9 +4063,15 @@ This function is never called when `lexical-binding' is nil."
(byte-compile-constant 1)
(byte-compile-out (get '* 'byte-opcode) 0))
(3
- (byte-compile-form (nth 1 form))
- (byte-compile-form (nth 2 form))
- (byte-compile-out (get (car form) 'byte-opcode) 0))
+ (let ((arg1 (nth 1 form))
+ (arg2 (nth 2 form)))
+ (when (and (memq (car form) '(+ *))
+ (macroexp-const-p arg1))
+ ;; Put constant argument last for better LAP optimisation.
+ (cl-rotatef arg1 arg2))
+ (byte-compile-form arg1)
+ (byte-compile-form arg2)
+ (byte-compile-out (get (car form) 'byte-opcode) 0)))
(_
;; >2 args: compile as a single function call.
(byte-compile-normal-call form))))
@@ -4835,6 +4855,11 @@ binding slots have been popped."
(dolist (clause (reverse clauses))
(let ((condition (nth 1 clause)))
+ (when (and (eq (car-safe condition) 'quote)
+ (cdr condition) (null (cddr condition)))
+ (byte-compile-warn-x
+ condition "`condition-case' condition should not be quoted: %S"
+ condition))
(unless (consp condition) (setq condition (list condition)))
(dolist (c condition)
(unless (and c (symbolp c))
@@ -5487,6 +5512,83 @@ and corresponding effects."
(eval form)
form)))
+;; Check for (in)comparable constant values in calls to `eq', `memq' etc.
+
+(defun bytecomp--dodgy-eq-arg-p (x number-ok)
+ "Whether X is a bad argument to `eq' (or `eql' if NUMBER-OK is non-nil)."
+ (pcase x
+ ((or `(quote ,(pred consp)) `(function (lambda . ,_))) t)
+ ((or (pred consp) (pred symbolp)) nil)
+ ((pred integerp)
+ (not (or (<= -536870912 x 536870911) number-ok)))
+ ((pred floatp) (not number-ok))
+ (_ t)))
+
+(defun bytecomp--value-type-description (x)
+ (cond
+ ((proper-list-p x) "list")
+ ((recordp x) "record")
+ (t (symbol-name (type-of x)))))
+
+(defun bytecomp--arg-type-description (x)
+ (pcase x
+ (`(function (lambda . ,_)) "function")
+ (`(quote . ,val) (bytecomp--value-type-description val))
+ (_ (bytecomp--value-type-description x))))
+
+(defun bytecomp--warn-dodgy-eq-arg (form type parenthesis)
+ (macroexp-warn-and-return
+ (format-message "`%s' called with literal %s that may never match (%s)"
+ (car form) type parenthesis)
+ form (list 'suspicious (car form)) t))
+
+(defun bytecomp--check-eq-args (form &optional a b &rest _ignore)
+ (let* ((number-ok (eq (car form) 'eql))
+ (bad-arg (cond ((bytecomp--dodgy-eq-arg-p a number-ok) 1)
+ ((bytecomp--dodgy-eq-arg-p b number-ok) 2))))
+ (if bad-arg
+ (bytecomp--warn-dodgy-eq-arg
+ form
+ (bytecomp--arg-type-description (nth bad-arg form))
+ (format "arg %d" bad-arg))
+ form)))
+
+(put 'eq 'compiler-macro #'bytecomp--check-eq-args)
+(put 'eql 'compiler-macro #'bytecomp--check-eq-args)
+
+(defun bytecomp--check-memq-args (form &optional elem list &rest _ignore)
+ (let* ((fn (car form))
+ (number-ok (eq fn 'memql)))
+ (cond
+ ((bytecomp--dodgy-eq-arg-p elem number-ok)
+ (bytecomp--warn-dodgy-eq-arg
+ form (bytecomp--arg-type-description elem) "arg 1"))
+ ((and (consp list) (eq (car list) 'quote)
+ (proper-list-p (cadr list)))
+ (named-let loop ((elts (cadr list)) (i 1))
+ (if elts
+ (let* ((elt (car elts))
+ (x (cond ((eq fn 'assq) (car-safe elt))
+ ((eq fn 'rassq) (cdr-safe elt))
+ (t elt))))
+ (if (or (symbolp x)
+ (and (integerp x)
+ (or (<= -536870912 x 536870911) number-ok))
+ (and (floatp x) number-ok))
+ (loop (cdr elts) (1+ i))
+ (bytecomp--warn-dodgy-eq-arg
+ form (bytecomp--value-type-description x)
+ (format "element %d of arg 2" i))))
+ form)))
+ (t form))))
+
+(put 'memq 'compiler-macro #'bytecomp--check-memq-args)
+(put 'memql 'compiler-macro #'bytecomp--check-memq-args)
+(put 'assq 'compiler-macro #'bytecomp--check-memq-args)
+(put 'rassq 'compiler-macro #'bytecomp--check-memq-args)
+(put 'remq 'compiler-macro #'bytecomp--check-memq-args)
+(put 'delq 'compiler-macro #'bytecomp--check-memq-args)
+
(provide 'byte-compile)
(provide 'bytecomp)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 0154716627f..e715bd90a00 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -236,9 +236,9 @@ Returns a form where all lambdas don't have any free variables."
(not (intern-soft var))
(eq ?_ (aref (symbol-name var) 0)))
(let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
- (format "Unused lexical %s `%S'%s"
- varkind (bare-symbol var)
- (if suggestions (concat "\n " suggestions) "")))))
+ (format-message "Unused lexical %s `%S'%s"
+ varkind (bare-symbol var)
+ (if suggestions (concat "\n " suggestions) "")))))
(define-inline cconv--var-classification (binder form)
(inline-quote
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 152a1fe9434..95a51a4bdde 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -201,7 +201,7 @@ should return.
Note that Emacs Lisp doesn't really support multiple values, so
all this function does is return LIST."
(unless (listp list)
- (signal 'wrong-type-argument list))
+ (signal 'wrong-type-argument (list list)))
list)
(defsubst cl-multiple-value-list (expression)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 43207ce7026..cffe8b09f53 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2052,7 +2052,8 @@ info node `(cl) Function Bindings' for details.
(dolist (binding bindings)
(let ((var (make-symbol (format "--cl-%s--" (car binding))))
(args-and-body (cdr binding)))
- (if (and (= (length args-and-body) 1) (symbolp (car args-and-body)))
+ (if (and (= (length args-and-body) 1)
+ (macroexp-copyable-p (car args-and-body)))
;; Optimize (cl-flet ((fun var)) body).
(setq var (car args-and-body))
(push (list var (if (= (length args-and-body) 1)
@@ -3175,8 +3176,9 @@ To see the documentation for a defined struct type, use
(when (cl-oddp (length desc))
(push
(macroexp-warn-and-return
- (format "Missing value for option `%S' of slot `%s' in struct %s!"
- (car (last desc)) slot name)
+ (format-message
+ "Missing value for option `%S' of slot `%s' in struct %s!"
+ (car (last desc)) slot name)
nil nil nil (car (last desc)))
forms)
(when (and (keywordp (car defaults))
@@ -3184,8 +3186,9 @@ To see the documentation for a defined struct type, use
(let ((kw (car defaults)))
(push
(macroexp-warn-and-return
- (format " I'll take `%s' to be an option rather than a default value."
- kw)
+ (format-message
+ " I'll take `%s' to be an option rather than a default value."
+ kw)
nil nil nil kw)
forms)
(push kw desc)
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 7ba8e956fb2..d2e7d933f4f 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -1220,7 +1220,7 @@ clashes."
(defun comp-decrypt-arg-list (x function-name)
"Decrypt argument list X for FUNCTION-NAME."
(unless (fixnump x)
- (signal 'native-compiler-error-dyn-func function-name))
+ (signal 'native-compiler-error-dyn-func (list function-name)))
(let ((rest (not (= (logand x 128) 0)))
(mandatory (logand x 127))
(nonrest (ash x -8)))
@@ -1264,7 +1264,7 @@ clashes."
'pure))))
(when (byte-code-function-p f)
(signal 'native-compiler-error
- "can't native compile an already byte-compiled function"))
+ '("can't native compile an already byte-compiled function")))
(setf (comp-func-byte-func func)
(byte-compile (comp-func-name func)))
(let ((lap (byte-to-native-lambda-lap
@@ -1288,7 +1288,7 @@ clashes."
"Byte-compile FORM, spilling data from the byte compiler."
(unless (eq (car-safe form) 'lambda)
(signal 'native-compiler-error
- "Cannot native-compile, form is not a lambda"))
+ '("Cannot native-compile, form is not a lambda")))
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt)
(make-temp-file "comp-lambda-" nil ".eln")))
@@ -1369,7 +1369,7 @@ clashes."
(alist-get 'no-native-compile byte-native-qualities))
(throw 'no-native-compile nil))
(unless byte-to-native-top-level-forms
- (signal 'native-compiler-error-empty-byte filename))
+ (signal 'native-compiler-error-empty-byte (list filename)))
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename
filename
@@ -1740,7 +1740,7 @@ Return value is the fall-through block name."
do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func))
(setf (comp-limplify-curr-block comp-pass) ff-bb))))
(_ (signal 'native-ice
- "missing previous setimm while creating a switch"))))
+ '("missing previous setimm while creating a switch")))))
(defun comp-emit-set-call-subr (subr-name sp-delta)
"Emit a call for SUBR-NAME.
@@ -2823,7 +2823,7 @@ blocks."
(first-processed (l)
(if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l)))
p
- (signal 'native-ice "can't find first preprocessed"))))
+ (signal 'native-ice '("can't find first preprocessed")))))
(when-let ((blocks (comp-func-blocks comp-func))
(entry (gethash 'entry blocks))
@@ -3721,7 +3721,7 @@ Prepare every function for final compilation and drive the C back-end."
(progn
(delete-file temp-file)
output)
- (signal 'native-compiler-error (buffer-string)))
+ (signal 'native-compiler-error (list (buffer-string))))
(comp-log-to-buffer (buffer-string))))))))
@@ -3805,22 +3805,22 @@ Return the trampoline if found or nil otherwise."
form nil
;; If we've disabled nativecomp, don't write the trampolines to
;; the eln cache (but create them).
- (and (not inhibit-automatic-native-compilation)
- (cl-loop
- for dir in (if native-compile-target-directory
- (list (expand-file-name comp-native-version-dir
- native-compile-target-directory))
- (comp-eln-load-path-eff))
- for f = (expand-file-name
- (comp-trampoline-filename subr-name)
- dir)
- unless (file-exists-p dir)
- do (ignore-errors
- (make-directory dir t)
- (cl-return f))
- when (file-writable-p f)
- do (cl-return f)
- finally (error "Cannot find suitable directory for output in \
+ (unless inhibit-automatic-native-compilation
+ (cl-loop
+ for dir in (if native-compile-target-directory
+ (list (expand-file-name comp-native-version-dir
+ native-compile-target-directory))
+ (comp-eln-load-path-eff))
+ for f = (expand-file-name
+ (comp-trampoline-filename subr-name)
+ dir)
+ unless (file-exists-p dir)
+ do (ignore-errors
+ (make-directory dir t)
+ (cl-return f))
+ when (file-writable-p f)
+ do (cl-return f)
+ finally (error "Cannot find suitable directory for output in \
`native-comp-eln-load-path'"))))))
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index 5721470ad0d..77f4b26d9bb 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -250,7 +250,8 @@ INIT-VALUE LIGHTER KEYMAP.
(warnwrap (if (or (null body) (keywordp (car body))) #'identity
(lambda (exp)
(macroexp-warn-and-return
- "Use keywords rather than deprecated positional arguments to `define-minor-mode'"
+ (format-message
+ "Use keywords rather than deprecated positional arguments to `define-minor-mode'")
exp))))
keyw keymap-sym tmp)
@@ -417,6 +418,8 @@ No problems result if this variable is not bound.
`(defvar ,keymap-sym
(let ((m ,keymap))
(cond ((keymapp m) m)
+ ;; FIXME: `easy-mmode-define-keymap' is obsolete,
+ ;; so this form should also be obsolete somehow.
((listp m)
(with-suppressed-warnings ((obsolete
easy-mmode-define-keymap))
@@ -682,6 +685,7 @@ Valid keywords and arguments are:
:group Ignored.
:suppress Non-nil to call `suppress-keymap' on keymap,
`nodigits' to suppress digits as prefix arguments."
+ (declare (obsolete define-keymap "29.1"))
(let (inherit dense suppress)
(while args
(let ((key (pop args))
@@ -722,9 +726,7 @@ The M, BS, and ARGS arguments are as per that function. DOC is
the constant's documentation.
This macro is deprecated; use `defvar-keymap' instead."
- ;; FIXME: Declare obsolete in favor of `defvar-keymap'. It is still
- ;; used for `gud-menu-map' and `gud-minor-mode-map', so fix that first.
- (declare (doc-string 3) (indent 1))
+ (declare (doc-string 3) (indent 1) (obsolete defvar-keymap "29.1"))
`(defconst ,m
(easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args))
,doc))
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 064a55f2727..9a1f5b9db0f 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -184,8 +184,9 @@ and reference them using the function `class-option'."
(when (and initarg (eq alloc :class))
(push
(cons sname
- (format "Meaningless :initarg for class allocated slot '%S'"
- sname))
+ (format-message
+ "Meaningless :initarg for class allocated slot `%S'"
+ sname))
warnings))
(let ((init (plist-get soptions :initform)))
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index e307776252a..dad91e92a45 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -417,9 +417,9 @@ The return value is the last VAL in the list.
(lambda (do key alist &optional default remove testfn)
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
- (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
- (assoc ,k ,getter ,testfn)
- (assq ,k ,getter))
+ (macroexp-let2 nil p (if (member testfn '(nil 'eq #'eq))
+ `(assq ,k ,getter)
+ `(assoc ,k ,getter ,testfn))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
(lambda (v)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 168de1bf180..c909ffb6933 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -291,10 +291,11 @@ It should normally be a symbol with position and it defaults to FORM."
(setq arglist (cdr arglist)))
(if values
(macroexp-warn-and-return
- (format (if (eq values 'too-few)
- "attempt to open-code `%s' with too few arguments"
- "attempt to open-code `%s' with too many arguments")
- name)
+ (format-message
+ (if (eq values 'too-few)
+ "attempt to open-code `%s' with too few arguments"
+ "attempt to open-code `%s' with too many arguments")
+ name)
form nil nil arglist)
;; The following leads to infinite recursion when loading a
@@ -367,14 +368,14 @@ Assumes the caller has bound `macroexpand-all-environment'."
(if (null body)
(macroexp-unprogn
(macroexp-warn-and-return
- (format "Empty %s body" fun)
- nil nil 'compile-only fun))
+ (format-message "`%s' with empty body" fun)
+ nil (list 'empty-body fun) 'compile-only fun))
(macroexp--all-forms body))
(cdr form))
form)))
(`(while)
(macroexp-warn-and-return
- "missing `while' condition"
+ (format-message "missing `while' condition")
`(signal 'wrong-number-of-arguments '(while 0))
nil 'compile-only form))
(`(setq ,(and var (pred symbolp)
@@ -392,7 +393,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(let ((nargs (length args)))
(if (/= (logand nargs 1) 0)
(macroexp-warn-and-return
- "odd number of arguments in `setq' form"
+ (format-message "odd number of arguments in `setq' form")
`(signal 'wrong-number-of-arguments '(setq ,nargs))
nil 'compile-only fn)
(let ((assignments nil))
@@ -457,12 +458,13 @@ Assumes the caller has bound `macroexpand-all-environment'."
(let ((arg (nth funarg form)))
(when (and (eq 'quote (car-safe arg))
(eq 'lambda (car-safe (cadr arg))))
- (setcar (nthcdr funarg form)
- (macroexp-warn-and-return
- (format "%S quoted with ' rather than with #'"
- (let ((f (cadr arg)))
- (if (symbolp f) f `(lambda ,(nth 1 f) ...))))
- arg nil nil (cadr arg))))))
+ (setcar
+ (nthcdr funarg form)
+ (macroexp-warn-and-return
+ (format
+ "(lambda %s ...) quoted with ' rather than with #'"
+ (or (nth 1 (cadr arg)) "()"))
+ arg nil nil (cadr arg))))))
;; Macro expand compiler macros. This cannot be delayed to
;; byte-optimize-form because the output of the compiler-macro can
;; use macros.
@@ -486,7 +488,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(setq form (macroexp--compiler-macro handler newform))
(if (eq newform form)
newform
- (macroexp--expand-all newform)))
+ (macroexp--expand-all form)))
(macroexp--expand-all newform))))))
(_ form))))
(pop byte-compile-form-stack)))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index f92afe56b76..09917cd29b1 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -4562,6 +4562,7 @@ will be signaled in that case."
(package--print-email-button maint)
(string-trim (substring-no-properties (buffer-string))))))))
+;;;###autoload
(defun package-report-bug (desc)
"Prepare a message to send to the maintainers of a package.
DESC must be a `package-desc' object."
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 810b13f61d6..1c5ce5169ab 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -947,7 +947,7 @@ Otherwise, it defers to REST which is a list of branches of the form
(let ((code (pcase--u1 matches code vars rest)))
(if (eq upat '_) code
(macroexp-warn-and-return
- "Pattern t is deprecated. Use `_' instead"
+ (format-message "Pattern t is deprecated. Use `_' instead")
code nil nil upat))))
((eq upat 'pcase--dontcare) :pcase--dontcare)
((memq (car-safe upat) '(guard pred))
diff --git a/lisp/emacs-lisp/range.el b/lisp/emacs-lisp/range.el
index 1165fcbbd7d..f441c240a27 100644
--- a/lisp/emacs-lisp/range.el
+++ b/lisp/emacs-lisp/range.el
@@ -194,7 +194,7 @@ these ranges."
(nreverse result)))))
(defun range-add-list (ranges list)
- "Return a list of ranges that has all articles from both RANGES and LIST.
+ "Return a list of ranges that has all numbers from both RANGES and LIST.
Note: LIST has to be sorted over `<'."
(if (not ranges)
(range-compress-list list)
@@ -249,9 +249,9 @@ Note: LIST has to be sorted over `<'."
out)))
(defun range-remove (range1 range2)
- "Return a range that has all articles from RANGE2 removed from RANGE1.
+ "Return a range that has all numbers from RANGE2 removed from RANGE1.
The returned range is always a list. RANGE2 can also be a unsorted
-list of articles. RANGE1 is modified by side effects, RANGE2 is not
+list of numbers. RANGE1 is modified by side effects, RANGE2 is not
modified."
(if (or (null range1) (null range2))
range1
@@ -345,7 +345,7 @@ modified."
(defun range-list-intersection (list ranges)
"Return a list of numbers in LIST that are members of RANGES.
-oLIST is a sorted list."
+LIST is a sorted list."
(setq ranges (range-normalize ranges))
(let (number result)
(while (setq number (pop list))
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-30 16:18:10 +0000