Warn about bad face specs in `defface` at compile time

* lisp/emacs-lisp/bytecomp.el (byte-compile--custom-declare-face):
Byte-compile `defface` forms, or the byte-compile handler won't
be called.
(bytecomp--check-cus-face-spec): New.
(bytecomp--custom-declare): Call it.
* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-test-defface-spec):
New tests.

(cherry picked from commit bba14a27678317eee68e87a343e7314b3949f6c7)

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index f34e65feaa4d94228c5f1d3da71ef225ed2884c1..4cb6518c8e9fbb3306bbd8a3edb50a99dca23785 100644 (file)
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2721,7 +2721,7 @@ Call from the source buffer."
       (let ((newdocs (byte-compile--docstring docs kind name)))
         (unless (eq docs newdocs)
           (setq form (byte-compile--list-with-n form 3 newdocs)))))
-    form))
+    (byte-compile-keep-pending form)))
 
 (put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
 (defun byte-compile-file-form-require (form)
@@ -5369,6 +5369,56 @@ FORM is used to provide location, `bytecomp--cus-function' and
       (bytecomp--cus-warn type "`%s' is not a valid type" type))
      )))
 
+(defun bytecomp--check-cus-face-spec (spec)
+  "Check for mistakes in a `defface' SPEC argument."
+  (when (consp spec)
+    (dolist (sp spec)
+      (let ((display (car-safe sp))
+            (atts (cdr-safe sp)))
+        (cond ((listp display)
+               (dolist (condition display)
+                 (unless (memq (car-safe condition)
+                               '(type class background min-colors supports))
+                   (bytecomp--cus-warn
+                    (list sp spec)
+                    "Bad face display condition `%S'" (car condition)))))
+              ((not (memq display '(t default)))
+               (bytecomp--cus-warn
+                (list sp spec) "Bad face display `%S'" display)))
+        (when (and (consp atts) (null (cdr atts)))
+          (setq atts (car atts)))       ; old (DISPLAY ATTS) syntax
+        (while atts
+          (let ((attr (car atts))
+                (val (cadr atts)))
+            (cond
+             ((not (keywordp attr))
+              (bytecomp--cus-warn
+               (list atts sp spec)
+               "Non-keyword in face attribute list: `%S'" attr))
+             ((null (cdr atts))
+              (bytecomp--cus-warn
+               (list atts sp spec) "Missing face attribute `%s' value" attr))
+             ((memq attr '( :inherit :extend
+                            :family :foundry :width :height :weight :slant
+                            :foreground :distant-foreground :background
+                            :underline :overline :strike-through :box
+                            :inverse-video :stipple :font
+                            ;; FIXME: obsolete keywords, warn about them too?
+                            ;; `:reverse-video' is very rare.
+                            :bold           ; :bold t   = :weight bold
+                            :italic         ; :italic t = :slant italic
+                            :reverse-video  ; alias for :inverse-video
+                            ))
+              (when (eq (car-safe val) 'quote)
+                (bytecomp--cus-warn
+                 (list val atts sp spec)
+                 "Value for face attribute `%s' should not be quoted" attr)))
+             (t
+              (bytecomp--cus-warn
+               (list atts sp spec)
+               "`%s' is not a valid face attribute keyword" attr))))
+          (setq atts (cddr atts)))))))
+
 ;; Unified handler for multiple functions with similar arguments:
 ;; (NAME SOMETHING DOC KEYWORD-ARGS...)
 (byte-defop-compiler-1 define-widget           bytecomp--custom-declare)
@@ -5402,6 +5452,13 @@ FORM is used to provide location, `bytecomp--cus-function' and
                         (eq (car-safe type-arg) 'quote))
                 (bytecomp--check-cus-type (cadr type-arg)))))))
 
+      (when (eq fun 'custom-declare-face)
+        (let ((face-arg (nth 2 form)))
+          (when (and (eq (car-safe face-arg) 'quote)
+                     (consp (cdr face-arg))
+                     (null (cddr face-arg)))
+            (bytecomp--check-cus-face-spec (nth 1 face-arg)))))
+
       ;; Check :group
       (when (cond
              ((memq fun '(custom-declare-variable custom-declare-face))

diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index e3ce87cc9afd76e057bed641145ca2c254265e35..cce6b1221fc5c1f69c5ea6caf286613e943c75c4 100644 (file)
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -1985,6 +1985,32 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
      (dc 'integerp))
     ))
 
+(ert-deftest bytecomp-test-defface-spec ()
+  (cl-flet ((df (spec) `(defface mytest ',spec "doc" :group 'test)))
+    (bytecomp--with-warning-test
+     (rx "Bad face display condition `max-colors'")
+     (df '((((class color grayscale) (max-colors 75) (background light))
+            :foreground "cyan"))))
+    (bytecomp--with-warning-test
+     (rx "Bad face display `defualt'")
+     (df '((defualt :foreground "cyan"))))
+    (bytecomp--with-warning-test
+     (rx "`:inverse' is not a valid face attribute keyword")
+     (df '((t :background "blue" :inverse t))))
+    (bytecomp--with-warning-test
+     (rx "`:inverse' is not a valid face attribute keyword")
+     (df '((t (:background "blue" :inverse t)))))  ; old attr list syntax
+    (bytecomp--with-warning-test
+     (rx "Value for face attribute `:inherit' should not be quoted")
+     (df '((t :inherit 'other))))
+    (bytecomp--with-warning-test
+     (rx "Missing face attribute `:extend' value")
+     (df '((t :foundry "abc" :extend))))
+    (bytecomp--with-warning-test
+     (rx "Non-keyword in face attribute list: `\"green\"'")
+     (df '((t :foreground "white" "green"))))
+    ))
+
 (ert-deftest bytecomp-function-attributes ()
   ;; Check that `byte-compile' keeps the declarations, interactive spec and
   ;; doc string of the function (bug#55830).