From 65a701d7c9ecbdd810f94a18786f73e81e31f391 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Wed, 14 Dec 2022 17:48:17 +0100
Subject: [PATCH] Warn about unmatchable constant args to `eq`, `memq` etc

Add a byte-compiler warning about attempts to compare literal values
with undefined identity relation to other values.  For example:

  (eq x 2.0)
  (memq x '("a" (b) [c]))

Such incomparable values include all literal conses, strings, vectors,
records and (except for eql and memql) floats and bignums.
The warning currently applies to eq, eql, memq, memql, assq, rassq,
remq and delq.

* lisp/emacs-lisp/bytecomp.el (bytecomp--dodgy-eq-arg)
(bytecomp--value-type-description, bytecomp--arg-type-description)
(bytecomp--warn-dodgy-eq-arg, bytecomp--check-eq-args)
(bytecomp--check-memq-args): New.
(eq, eql, memq, memql, assq, rassq, remq, delq):
Set compiler-macro property.
* lisp/emacs-lisp/byte-run.el (with-suppressed-warnings):
Amend doc string.
* test/lisp/emacs-lisp/bytecomp-tests.el
(bytecomp--with-warning-test): Fix text-quoting-style and expand
re-warning so that it doesn't need to be a literal.
(bytecomp-warn-dodgy-args-eq, bytecomp-warn-dodgy-args-memq):
New tests.
---
 lisp/emacs-lisp/byte-run.el            |  3 +-
 lisp/emacs-lisp/bytecomp.el            | 74 ++++++++++++++++++++++++++
 test/lisp/emacs-lisp/bytecomp-tests.el | 54 +++++++++++++++++--
 3 files changed, 127 insertions(+), 4 deletions(-)

diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 1babf3ec2c..b5e887db83 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -653,7 +653,8 @@ with-suppressed-warnings
 `suspicious'.
 
 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.  For `suspicious', only `set-buffer', `lsh' and `eq'
+can be used."
   ;; Note: during compilation, this definition is overridden by the one in
   ;; byte-compile-initial-macro-environment.
   (declare (debug (sexp body)) (indent 1))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index f176e769bf..9af32102c0 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -5487,6 +5487,80 @@ batch-byte-recompile-directory
            (eval form)
          form)))
 
+;; Check for (in)comparable constant values in calls to `eq', `memq' etc.
+
+(defun bytecomp--dodgy-eq-arg (x number-ok)
+  "Whether X is a bad argument to `eq' (or `eql' if NUMBER-OK is non-nil)."
+  (cond ((consp x) (and (eq (car x) 'quote) (consp (cadr x))))
+        ((symbolp x) nil)
+        ((integerp x) (not (or (<= -536870912 x 536870911) number-ok)))
+        ((floatp x) (not number-ok))
+        (t t)))
+
+(defun bytecomp--value-type-description (x)
+  (cond ((and x (proper-list-p x)) "list")
+        ((recordp x) "record")
+        (t (symbol-name (type-of x)))))
+
+(defun bytecomp--arg-type-description (x)
+  (bytecomp--value-type-description
+   (if (and (consp x) (eq (car x) 'quote))
+       (cadr x)
+     x)))
+
+(defun bytecomp--warn-dodgy-eq-arg (form type parenthesis)
+  (macroexp-warn-and-return
+   (format "`%s' called with literal %s that may never match (%s)"
+           (car form) type parenthesis)
+   form '(suspicious eq) t))
+
+(defun bytecomp--check-eq-args (form a b &rest _ignore)
+  (let* ((number-ok (eq (car form) 'eql))
+         (bad-arg (cond ((bytecomp--dodgy-eq-arg a number-ok) 1)
+                        ((bytecomp--dodgy-eq-arg 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 elem list &rest _ignore)
+  (let* ((fn (car form))
+         (number-ok (eq fn 'memql)))
+    (cond
+     ((bytecomp--dodgy-eq-arg 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/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index e7c308213e..00361a4286 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -837,9 +837,11 @@ bytecomp--with-warning-test
   (declare (indent 1))
   `(with-current-buffer (get-buffer-create "*Compile-Log*")
      (let ((inhibit-read-only t)) (erase-buffer))
-     (byte-compile ,@form)
-     (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
-       (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning))))))
+     (let ((text-quoting-style 'grave))
+       (byte-compile ,@form)
+       (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
+         (should (re-search-forward
+                  (string-replace " " "[ \n]+" ,re-warning)))))))
 
 (ert-deftest bytecomp-warn-wrong-args ()
   (bytecomp--with-warning-test "remq.*3.*2"
@@ -863,6 +865,52 @@ bytecomp-warn-wide-docstring/defvar
   (bytecomp--with-warning-test "defvar.*foo.*wider than.*characters"
     `(defvar foo t ,bytecomp-tests--docstring)))
 
+(ert-deftest bytecomp-warn-dodgy-args-eq ()
+  (dolist (fn '(eq eql))
+    (cl-flet ((msg (type arg)
+                (format
+                 "`%s' called with literal %s that may never match (arg %d)"
+                 fn type arg)))
+      (bytecomp--with-warning-test (msg "list" 1)   `(,fn '(a) 'x))
+      (bytecomp--with-warning-test (msg "string" 2) `(,fn 'x "a"))
+      (bytecomp--with-warning-test (msg "vector" 2) `(,fn 'x [a]))
+      (unless (eq fn 'eql)
+        (bytecomp--with-warning-test (msg "integer" 2) `(,fn 'x #x10000000000))
+        (bytecomp--with-warning-test (msg "float" 2)   `(,fn 'x 1.0))))))
+
+(ert-deftest bytecomp-warn-dodgy-args-memq ()
+  (dolist (fn '(memq memql remq delq assq rassq))
+    (cl-labels
+        ((msg1 (type)
+           (format
+            "`%s' called with literal %s that may never match (arg 1)"
+            fn type))
+         (msg2 (type)
+           (format
+            "`%s' called with literal %s that may never match (element 2 of arg 2)"
+            fn type))
+         (lst (elt)
+           (cond ((eq fn 'assq)  `((a . 1) (,elt . 2) (c . 3)))
+                 ((eq fn 'rassq) `((1 . a) (2 . ,elt) (3 . c)))
+                 (t              `(a       ,elt       c))))
+         (form2 (elt)
+           `(,fn 'x ',(lst elt))))
+
+    (bytecomp--with-warning-test (msg1 "list")   `(,fn '(a) '(x)))
+    (bytecomp--with-warning-test (msg1 "string") `(,fn "a" '(x)))
+    (bytecomp--with-warning-test (msg1 "vector") `(,fn [a] '(x)))
+    (unless (eq fn 'memql)
+      (bytecomp--with-warning-test (msg1 "integer") `(,fn #x10000000000 '(x)))
+      (bytecomp--with-warning-test (msg1 "float")   `(,fn 1.0 '(x))))
+
+    (bytecomp--with-warning-test (msg2 "list")   (form2 '(b)))
+    (bytecomp--with-warning-test (msg2 "list")   (form2 ''b))
+    (bytecomp--with-warning-test (msg2 "string") (form2 "b"))
+    (bytecomp--with-warning-test (msg2 "vector") (form2 [b]))
+    (unless (eq fn 'memql)
+      (bytecomp--with-warning-test (msg2 "integer") (form2 #x10000000000))
+      (bytecomp--with-warning-test (msg2 "float")   (form2 1.0))))))
+
 (defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse)
   `(ert-deftest ,(intern (format "bytecomp/%s" file)) ()
      (with-current-buffer (get-buffer-create "*Compile-Log*")
-- 
2.32.0 (Apple Git-132)

