Expanded defcustom type byte-compilation warnings (bug#65852)
Warn about more kinds of mistakes in :type arguments of `defcustom` and `define-widget`. These include: - misplaced keyword args, as in (const red :tag "A reddish hue") - missing subordinate types, as in (repeat :tag "List of names") or (choice list string) - duplicated values, as in (choice (const yes) (const yes)) - misplaced `other` member, as in (choice (const red) (other nil) (const blue)) - various type name mistakes, as in (vector bool functionp) * lisp/emacs-lisp/bytecomp.el (byte-compile--defcustom-type-quoted) (byte-compile-nogroup-warn): Remove. (byte-compile-normal-call): Remove call to the above. (bytecomp--cus-warn, bytecomp--check-cus-type) (bytecomp--custom-declare): New.
This commit is contained in:
Mattias Engdegård
parent
e0070fc574
commit
f8ea47ebf4
2 changed files with 226 additions and 62 deletions
|
|
@ -1618,57 +1618,6 @@ extra args."
|
|||
(dolist (elt '(format message format-message error))
|
||||
(put elt 'byte-compile-format-like t))
|
||||
|
||||
(defun byte-compile--defcustom-type-quoted (type)
|
||||
"Whether defcustom TYPE contains an accidentally quoted value."
|
||||
;; Detect mistakes such as (const 'abc).
|
||||
;; We don't actually follow the syntax for defcustom types, but this
|
||||
;; should be good enough.
|
||||
(and (consp type)
|
||||
(proper-list-p type)
|
||||
(if (memq (car type) '(const other))
|
||||
(assq 'quote type)
|
||||
(let ((elts (cdr type)))
|
||||
(while (and elts (not (byte-compile--defcustom-type-quoted
|
||||
(car elts))))
|
||||
(setq elts (cdr elts)))
|
||||
elts))))
|
||||
|
||||
;; Warn if a custom definition fails to specify :group, or :type.
|
||||
(defun byte-compile-nogroup-warn (form)
|
||||
(let ((keyword-args (cdr (cdr (cdr (cdr form)))))
|
||||
(name (cadr form)))
|
||||
(when (eq (car-safe name) 'quote)
|
||||
(when (eq (car form) 'custom-declare-variable)
|
||||
(let ((type (plist-get keyword-args :type)))
|
||||
(cond
|
||||
((not type)
|
||||
(byte-compile-warn-x (cadr name)
|
||||
"defcustom for `%s' fails to specify type"
|
||||
(cadr name)))
|
||||
((byte-compile--defcustom-type-quoted type)
|
||||
(byte-compile-warn-x
|
||||
(cadr name)
|
||||
"defcustom for `%s' may have accidentally quoted value in type `%s'"
|
||||
(cadr name) type)))))
|
||||
(if (and (memq (car form) '(custom-declare-face custom-declare-variable))
|
||||
byte-compile-current-group)
|
||||
;; The group will be provided implicitly.
|
||||
nil
|
||||
(or (and (eq (car form) 'custom-declare-group)
|
||||
(equal name ''emacs))
|
||||
(plist-get keyword-args :group)
|
||||
(byte-compile-warn-x (cadr name)
|
||||
"%s for `%s' fails to specify containing group"
|
||||
(cdr (assq (car form)
|
||||
'((custom-declare-group . defgroup)
|
||||
(custom-declare-face . defface)
|
||||
(custom-declare-variable . defcustom))))
|
||||
(cadr name)))
|
||||
;; Update the current group, if needed.
|
||||
(if (and byte-compile-current-file ;Only when compiling a whole file.
|
||||
(eq (car form) 'custom-declare-group))
|
||||
(setq byte-compile-current-group (cadr name)))))))
|
||||
|
||||
;; Warn if the function or macro is being redefined with a different
|
||||
;; number of arguments.
|
||||
(defun byte-compile-arglist-warn (name arglist macrop)
|
||||
|
|
@ -3695,10 +3644,6 @@ lambda-expression."
|
|||
(defun byte-compile-normal-call (form)
|
||||
(when (and (symbolp (car form))
|
||||
(byte-compile-warning-enabled-p 'callargs (car form)))
|
||||
(if (memq (car form)
|
||||
'(custom-declare-group custom-declare-variable
|
||||
custom-declare-face))
|
||||
(byte-compile-nogroup-warn form))
|
||||
(byte-compile-callargs-warn form))
|
||||
(if byte-compile-generate-call-tree
|
||||
(byte-compile-annotate-call-tree form))
|
||||
|
|
@ -5269,6 +5214,187 @@ binding slots have been popped."
|
|||
(pcase form (`(,_ ',var) (byte-compile--declare-var var)))
|
||||
(byte-compile-normal-call form))
|
||||
|
||||
;; Warn about mistakes in `defcustom', `defface', `defgroup', `define-widget'
|
||||
|
||||
(defvar bytecomp--cus-function)
|
||||
(defvar bytecomp--cus-name)
|
||||
|
||||
(defun bytecomp--cus-warn (form format &rest args)
|
||||
"Emit a warning about a `defcustom' type.
|
||||
FORM is used to provide location, `bytecomp--cus-function' and
|
||||
`bytecomp--cus-name' for context."
|
||||
(let* ((actual-fun (or (cdr (assq bytecomp--cus-function
|
||||
'((custom-declare-group . defgroup)
|
||||
(custom-declare-face . defface)
|
||||
(custom-declare-variable . defcustom))))
|
||||
bytecomp--cus-function))
|
||||
(prefix (format "in %s%s: "
|
||||
actual-fun
|
||||
(if bytecomp--cus-name
|
||||
(format " for `%s'" bytecomp--cus-name)
|
||||
""))))
|
||||
(apply #'byte-compile-warn-x form (concat prefix format) args)))
|
||||
|
||||
(defun bytecomp--check-cus-type (type)
|
||||
"Warn about common mistakes in the `defcustom' type TYPE."
|
||||
(let ((invalid-types
|
||||
'(
|
||||
;; Lisp type predicates, often confused with customisation types:
|
||||
functionp numberp integerp fixnump natnump floatp booleanp
|
||||
characterp listp stringp consp vectorp symbolp keywordp
|
||||
hash-table-p facep
|
||||
;; other mistakes occasionally seen (oh yes):
|
||||
or and nil t
|
||||
interger intger lits bool boolen constant filename
|
||||
kbd any list-of auto
|
||||
;; from botched backquoting
|
||||
\, \,@ \`
|
||||
)))
|
||||
(cond
|
||||
((consp type)
|
||||
(let* ((head (car type))
|
||||
(tail (cdr type)))
|
||||
(while (and (keywordp (car tail)) (cdr tail))
|
||||
(setq tail (cddr tail)))
|
||||
(cond
|
||||
((plist-member (cdr type) :convert-widget) nil)
|
||||
((let ((tl tail))
|
||||
(and (not (keywordp (car tail)))
|
||||
(progn
|
||||
(while (and tl (not (keywordp (car tl))))
|
||||
(setq tl (cdr tl)))
|
||||
(and tl
|
||||
(progn
|
||||
(bytecomp--cus-warn
|
||||
tl "misplaced %s keyword in `%s' type" (car tl) head)
|
||||
t))))))
|
||||
((memq head '(choice radio))
|
||||
(unless tail
|
||||
(bytecomp--cus-warn type "`%s' without any types inside" head))
|
||||
(let ((clauses tail)
|
||||
(constants nil))
|
||||
(while clauses
|
||||
(let* ((ty (car clauses))
|
||||
(ty-head (car-safe ty)))
|
||||
(when (and (eq ty-head 'other) (cdr clauses))
|
||||
(bytecomp--cus-warn ty "`other' not last in `%s'" head))
|
||||
(when (memq ty-head '(const other))
|
||||
(let ((ty-tail (cdr ty))
|
||||
(val nil))
|
||||
(while (and (keywordp (car ty-tail)) (cdr ty-tail))
|
||||
(when (eq (car ty-tail) :value)
|
||||
(setq val (cadr ty-tail)))
|
||||
(setq ty-tail (cddr ty-tail)))
|
||||
(when ty-tail
|
||||
(setq val (car ty-tail)))
|
||||
(when (member val constants)
|
||||
(bytecomp--cus-warn
|
||||
ty "duplicated value in `%s': `%S'" head val))
|
||||
(push val constants)))
|
||||
(bytecomp--check-cus-type ty))
|
||||
(setq clauses (cdr clauses)))))
|
||||
((eq head 'cons)
|
||||
(unless (= (length tail) 2)
|
||||
(bytecomp--cus-warn
|
||||
type "`cons' requires 2 type specs, found %d" (length tail)))
|
||||
(dolist (ty tail)
|
||||
(bytecomp--check-cus-type ty)))
|
||||
((memq head '(list group vector set repeat))
|
||||
(unless tail
|
||||
(bytecomp--cus-warn type "`%s' without type specs" head))
|
||||
(dolist (ty tail)
|
||||
(bytecomp--check-cus-type ty)))
|
||||
((memq head '(alist plist))
|
||||
(let ((key-tag (memq :key-type (cdr type)))
|
||||
(value-tag (memq :value-type (cdr type))))
|
||||
(when key-tag
|
||||
(bytecomp--check-cus-type (cadr key-tag)))
|
||||
(when value-tag
|
||||
(bytecomp--check-cus-type (cadr value-tag)))))
|
||||
((memq head '(const other))
|
||||
(let* ((value-tag (memq :value (cdr type)))
|
||||
(n (length tail))
|
||||
(val (car tail)))
|
||||
(cond
|
||||
((or (> n 1) (and value-tag tail))
|
||||
(bytecomp--cus-warn type "`%s' with too many values" head))
|
||||
(value-tag
|
||||
(setq val (cadr value-tag)))
|
||||
;; ;; This is a useful check but it results in perhaps
|
||||
;; ;; a bit too many complaints.
|
||||
;; ((null tail)
|
||||
;; (bytecomp--cus-warn
|
||||
;; type "`%s' without value is implicitly nil" head))
|
||||
)
|
||||
(when (memq (car-safe val) '(quote function))
|
||||
(bytecomp--cus-warn type "`%s' with quoted value: %S" head val))))
|
||||
((eq head 'quote)
|
||||
(bytecomp--cus-warn type "type should not be quoted: %s" (cadr type)))
|
||||
((memq head invalid-types)
|
||||
(bytecomp--cus-warn type "`%s' is not a valid type" head))
|
||||
((or (not (symbolp head)) (keywordp head))
|
||||
(bytecomp--cus-warn type "irregular type `%S'" head))
|
||||
)))
|
||||
((or (not (symbolp type)) (keywordp type))
|
||||
(bytecomp--cus-warn type "irregular type `%S'" type))
|
||||
((memq type '( list cons group vector choice radio const other
|
||||
function-item variable-item set repeat restricted-sexp))
|
||||
(bytecomp--cus-warn type "`%s' without arguments" type))
|
||||
((memq type invalid-types)
|
||||
(bytecomp--cus-warn type "`%s' is not a valid type" type))
|
||||
)))
|
||||
|
||||
;; Unified handler for multiple functions with similar arguments:
|
||||
;; (NAME SOMETHING DOC KEYWORD-ARGS...)
|
||||
(byte-defop-compiler-1 define-widget bytecomp--custom-declare)
|
||||
(byte-defop-compiler-1 custom-declare-group bytecomp--custom-declare)
|
||||
(byte-defop-compiler-1 custom-declare-face bytecomp--custom-declare)
|
||||
(byte-defop-compiler-1 custom-declare-variable bytecomp--custom-declare)
|
||||
(defun bytecomp--custom-declare (form)
|
||||
(when (>= (length form) 4)
|
||||
(let* ((name-arg (nth 1 form))
|
||||
(name (and (eq (car-safe name-arg) 'quote)
|
||||
(symbolp (nth 1 name-arg))
|
||||
(nth 1 name-arg)))
|
||||
(keyword-args (nthcdr 4 form))
|
||||
(fun (car form))
|
||||
(bytecomp--cus-function fun)
|
||||
(bytecomp--cus-name name))
|
||||
|
||||
;; Check :type
|
||||
(when (memq fun '(custom-declare-variable define-widget))
|
||||
(let ((type-tag (memq :type keyword-args)))
|
||||
(if (null type-tag)
|
||||
;; :type only mandatory for `defcustom'
|
||||
(when (eq fun 'custom-declare-variable)
|
||||
(bytecomp--cus-warn form "missing :type keyword parameter"))
|
||||
(let ((dup-type (memq :type (cdr type-tag))))
|
||||
(when dup-type
|
||||
(bytecomp--cus-warn
|
||||
dup-type "duplicated :type keyword argument")))
|
||||
(let ((type-arg (cadr type-tag)))
|
||||
(when (or (null type-arg)
|
||||
(eq (car-safe type-arg) 'quote))
|
||||
(bytecomp--check-cus-type (cadr type-arg)))))))
|
||||
|
||||
;; Check :group
|
||||
(when (cond
|
||||
((memq fun '(custom-declare-variable custom-declare-face))
|
||||
(not byte-compile-current-group))
|
||||
((eq fun 'custom-declare-group)
|
||||
(not (eq name 'emacs))))
|
||||
(unless (plist-get keyword-args :group)
|
||||
(bytecomp--cus-warn form "fails to specify containing group")))
|
||||
|
||||
;; Update current group
|
||||
(when (and name
|
||||
byte-compile-current-file ; only when compiling a whole file
|
||||
(eq fun 'custom-declare-group))
|
||||
(setq byte-compile-current-group name))))
|
||||
|
||||
(byte-compile-normal-call form))
|
||||
|
||||
|
||||
(put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop)
|
||||
(put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop)
|
||||
(defun byte-compile-define-symbol-prop (form)
|
||||
|
|
|
|||
|
|
@ -1100,7 +1100,7 @@ byte-compiled. Run with dynamic binding."
|
|||
"fails to specify containing group")
|
||||
|
||||
(bytecomp--define-warning-file-test "warn-defcustom-notype.el"
|
||||
"fails to specify type")
|
||||
"missing :type keyword parameter")
|
||||
|
||||
(bytecomp--define-warning-file-test "warn-defvar-lacks-prefix.el"
|
||||
"var.*foo.*lacks a prefix")
|
||||
|
|
@ -1874,12 +1874,50 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
|
|||
(TEST-IN-COMMENTS t) (TEST-IN-STRINGS t) (TEST-IN-CODE t) \
|
||||
(FIXTURE-FN \\='#\\='electric-pair-mode))" fill-column)))
|
||||
|
||||
(ert-deftest bytecomp-test-defcustom-type-quoted ()
|
||||
(should-not (byte-compile--defcustom-type-quoted 'integer))
|
||||
(should-not (byte-compile--defcustom-type-quoted
|
||||
'(choice (const :tag "foo" bar))))
|
||||
(should (byte-compile--defcustom-type-quoted
|
||||
'(choice (const :tag "foo" 'bar)))))
|
||||
(ert-deftest bytecomp-test-defcustom-type ()
|
||||
(cl-flet ((dc (type) `(defcustom mytest nil "doc" :type ',type)))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "type should not be quoted") (dc ''integer))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "type should not be quoted") (dc '(choice '(repeat boolean))))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "misplaced :tag keyword") (dc '(choice (const b :tag "a"))))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "`choice' without any types inside") (dc '(choice :tag "a")))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "`other' not last in `choice'")
|
||||
(dc '(choice (const a) (other b) (const c))))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "duplicated value in `choice': `a'")
|
||||
(dc '(choice (const a) (const b) (const a))))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "`cons' requires 2 type specs, found 1")
|
||||
(dc '(cons :tag "a" integer)))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "`repeat' without type specs")
|
||||
(dc '(repeat :tag "a")))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "`const' with too many values")
|
||||
(dc '(const :tag "a" x y)))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "`const' with quoted value")
|
||||
(dc '(const :tag "a" 'x)))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "`bool' is not a valid type")
|
||||
(dc '(bool :tag "a")))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "irregular type `:tag'")
|
||||
(dc '(:tag "a")))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "irregular type `\"string\"'")
|
||||
(dc '(list "string")))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "`list' without arguments")
|
||||
(dc 'list))
|
||||
(bytecomp--with-warning-test
|
||||
(rx "`integerp' is not a valid type")
|
||||
(dc 'integerp))
|
||||
))
|
||||
|
||||
(ert-deftest bytecomp-function-attributes ()
|
||||
;; Check that `byte-compile' keeps the declarations, interactive spec and
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue