(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)
(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))
(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)
"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")
(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
projects / emacs.git / commitdiff