From: "Mattias Engdegård" <mattias.engdegard@gmail.com>
To: Stefan Kangas <stefankangas@gmail.com>
Cc: 65852@debbugs.gnu.org, Mauro Aranda <maurooaranda@gmail.com>
Subject: bug#65852: 30.0.50; image-auto-resize :type has choices in wrong order
Date: Tue, 12 Sep 2023 16:42:41 +0200 [thread overview]
Message-ID: <8490D7BE-4204-4FC3-B583-D4D0674FB075@gmail.com> (raw)
In-Reply-To: <865AB7EF-D175-4A6B-BD64-6C0EE0338D13@gmail.com>
[-- Attachment #1: Type: text/plain, Size: 880 bytes --]
I now see that we have an existing defcustom check that runs very late in the compilation.
Although I prefer this kind of check to be carried out during macro-expansion, doing so has the disadvantage that actual values aren't always available. On the other hand, defcustom arguments are usually constants.
Anyway, I went overboard and wrote a sizeable expansion to the current set of warnings and now also checks :type args in define-widget (see attached patch). Try it out and tell me what you think. Maybe the regexp check is too ad-hocky.
Another warning that I rather like but may give too many false positives is that of `const` and `other` types without an actual value which is then assumed to be nil. This seems to be an undocumented 'feature' but it doesn't help readability; it's often unclear whether `nil` was intended or just a result of a forgotten value.
[-- Attachment #2: more-defcustom-warnings.diff --]
[-- Type: application/octet-stream, Size: 11797 bytes --]
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 7feaf118b86..85962b7c38c 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1618,57 +1618,6 @@ byte-compile-format-warn
(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 @@ byte-compile-form
(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,193 @@ byte-compile-make-local-variable
(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)
+ (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)
+ (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 'string)
+ (let ((tag (plist-get (cdr type) :tag)))
+ (when (and (stringp tag)
+ (let ((case-fold-search t))
+ (string-match-p (rx (or "regex" "regular expression"))
+ tag)))
+ (bytecomp--cus-warn
+ type "`string' with :tag %S should use type `regexp'?" tag))))
+ ((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)))
+ ((and nil ; currently disabled
+ ;; This is a useful check but it results in perhaps
+ ;; a bit too many complaints. Keep it?
+ (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 "accidentally quoted type: %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))
+ )))
+
+;; Uniform 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)
next prev parent reply other threads:[~2023-09-12 14:42 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-09-10 13:40 bug#65852: 30.0.50; image-auto-resize :type has choices in wrong order Mauro Aranda
2023-09-10 13:48 ` Mauro Aranda
2023-09-10 13:49 ` Stefan Kangas
2023-09-10 13:58 ` Mauro Aranda
2023-09-10 14:24 ` Stefan Kangas
2023-09-10 14:47 ` Mauro Aranda
2023-09-10 15:38 ` Stefan Kangas
2023-09-10 15:38 ` Mattias Engdegård
2023-09-12 14:42 ` Mattias Engdegård [this message]
2023-09-17 15:20 ` Mattias Engdegård
2023-09-17 21:53 ` Mauro Aranda
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=8490D7BE-4204-4FC3-B583-D4D0674FB075@gmail.com \
--to=mattias.engdegard@gmail.com \
--cc=65852@debbugs.gnu.org \
--cc=maurooaranda@gmail.com \
--cc=stefankangas@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).