bug#51368: 29.0.50; `cl-case' should error on incorrect use

[Philipp Stephani <p.stephani2@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 682 bytes --]

Am Mo., 1. Nov. 2021 um 14:31 Uhr schrieb Lars Ingebrigtsen <larsi@gnus.org>:
>
> Philipp Stephani <p.stephani2@gmail.com> writes:
>
> > Yes, but the problem only arises if the user wants to match the symbol
> > `quote' plus exactly one other value. That should already be
> > exceedingly rare, and can be trivially rewritten by swapping the two
> > values (i.e. write (foo quote) instead of (quote foo)). So I think
> > issuing a warning or error for that case is worth it.
>
> I think we're getting into slightly muddy waters, but I think I agree --
> a warning here is (much more) likely to be helpful than not.
>

Ok, I've attached two patches that implement these suggestions.

[-- Attachment #2: 0001-Signal-an-error-if-a-fallback-case-is-misplaced-Bug-.patch --]
[-- Type: application/octet-stream, Size: 2463 bytes --]

From 9c629b85cecfd2845585d03c3bd7438b69686af9 Mon Sep 17 00:00:00 2001
From: Philipp Stephani <phst@google.com>
Date: Fri, 12 Nov 2021 20:26:06 +0100
Subject: [PATCH 1/2] Signal an error if a fallback case is misplaced
 (Bug#51368).

* lisp/emacs-lisp/cl-macs.el (cl-case): Signal an error if a t or
'otherwise' key doesn't come last.

* test/lisp/emacs-lisp/cl-macs-tests.el (cl-case-error): New unit
test.
---
 lisp/emacs-lisp/cl-macs.el            |  9 +++++++--
 test/lisp/emacs-lisp/cl-macs-tests.el | 11 +++++++++++
 2 files changed, 18 insertions(+), 2 deletions(-)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 1852471bcb..61caa09009 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -776,11 +776,16 @@ cl-case
 \(fn EXPR (KEYLIST BODY...)...)"
   (declare (indent 1) (debug (form &rest (sexp body))))
   (macroexp-let2 macroexp-copyable-p temp expr
-    (let* ((head-list nil))
+    (let* ((head-list nil)
+           (has-otherwise nil))
       `(cond
         ,@(mapcar
            (lambda (c)
-             (cons (cond ((memq (car c) '(t otherwise)) t)
+             (cons (cond (has-otherwise
+                          (error "Misplaced t or `otherwise' clause"))
+                         ((memq (car c) '(t otherwise))
+                          (setq has-otherwise t)
+                          t)
                          ((eq (car c) 'cl--ecase-error-flag)
                           `(error "cl-ecase failed: %s, %s"
                                   ,temp ',(reverse head-list)))
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 033764a7f9..68e29b32d9 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -673,4 +673,15 @@ cl-macs--progv
   (should (equal (cl-progv '(test1 test2) '(1 2) (list test1 test2))
                  '(1 2))))
 
+(ert-deftest cl-case-error ()
+  "Test that `cl-case' and `cl-ecase' signal an error if a t or
+`otherwise' key is misplaced."
+  (dolist (form '((cl-case val (t 1) (123 2))
+                  (cl-ecase val (t 1) (123 2))
+                  (cl-ecase val (123 2) (t 1))))
+    (ert-info ((prin1-to-string form) :prefix "Form: ")
+      (let ((error (should-error (macroexpand form))))
+        (should (equal (cdr error)
+                       '("Misplaced t or `otherwise' clause")))))))
+
 ;;; cl-macs-tests.el ends here
-- 
2.30.1 (Apple Git-130)


[-- Attachment #3: 0002-Have-cl-case-warn-about-suspicious-cases-Bug-51368.patch --]
[-- Type: application/octet-stream, Size: 4304 bytes --]

From 31c8a6d98222de7f7790f822e9ae22fe66addece Mon Sep 17 00:00:00 2001
From: Philipp Stephani <phst@google.com>
Date: Fri, 12 Nov 2021 20:28:23 +0100
Subject: [PATCH 2/2] Have 'cl-case' warn about suspicious cases (Bug#51368).

* lisp/emacs-lisp/cl-macs.el (cl-case): Warn if the user passes a nil
key list (which would never match).  Warn about quoted symbols that
should probably be unquoted.

* test/lisp/emacs-lisp/cl-macs-tests.el (cl-case-warning): New unit
test.
---
 lisp/emacs-lisp/cl-macs.el            | 15 +++++++++++++
 test/lisp/emacs-lisp/cl-macs-tests.el | 32 +++++++++++++++++++++++++++
 2 files changed, 47 insertions(+)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 61caa09009..c1681f37c5 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -789,6 +789,21 @@ cl-case
                          ((eq (car c) 'cl--ecase-error-flag)
                           `(error "cl-ecase failed: %s, %s"
                                   ,temp ',(reverse head-list)))
+                         ((null (car c))
+                          (macroexp-warn-and-return
+                           "Case nil will never match"
+                           nil 'suspicious))
+                         ((and (consp (car c)) (not (cddar c))
+                               (memq (caar c) '(quote function)))
+                          (macroexp-warn-and-return
+                           (format-message
+                            (concat "Case %s will match `%s'.  If "
+                                    "that's intended, write %s "
+                                    "instead.  Otherwise, don't "
+                                    "quote `%s'.")
+                            (car c) (caar c) (list (cadar c) (caar c))
+                            (cadar c))
+                           `(cl-member ,temp ',(car c)) 'suspicious))
                          ((listp (car c))
                           (setq head-list (append (car c) head-list))
                           `(cl-member ,temp ',(car c)))
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 68e29b32d9..69d828709a 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -24,6 +24,8 @@
 (require 'cl-lib)
 (require 'cl-macs)
 (require 'ert)
+(require 'ert-x)
+(require 'pcase)
 
 \f
 ;;;; cl-loop tests -- many adapted from Steele's CLtL2
@@ -684,4 +686,34 @@ cl-case-error
         (should (equal (cdr error)
                        '("Misplaced t or `otherwise' clause")))))))
 
+(ert-deftest cl-case-warning ()
+  "Test that `cl-case' and `cl-ecase' warn about suspicious
+constructs."
+  (pcase-dolist (`(,case . ,message)
+                 `((nil . "Case nil will never match")
+                   ('nil . ,(concat "Case 'nil will match `quote'.  "
+                                    "If that's intended, write "
+                                    "(nil quote) instead.  "
+                                    "Otherwise, don't quote `nil'."))
+                   ('t . ,(concat "Case 't will match `quote'.  "
+                                  "If that's intended, write "
+                                  "(t quote) instead.  "
+                                  "Otherwise, don't quote `t'."))
+                   ('foo . ,(concat "Case 'foo will match `quote'.  "
+                                    "If that's intended, write "
+                                    "(foo quote) instead.  "
+                                    "Otherwise, don't quote `foo'."))
+                   (#'foo . ,(concat "Case #'foo will match "
+                                     "`function'.  If that's "
+                                     "intended, write (foo function) "
+                                     "instead.  Otherwise, don't "
+                                     "quote `foo'."))))
+    (dolist (macro '(cl-case cl-ecase))
+      (let ((form `(,macro val (,case 1))))
+        (ert-info ((prin1-to-string form) :prefix "Form: ")
+          (ert-with-message-capture messages
+            (macroexpand form)
+            (should (equal messages
+                           (concat "Warning: " message "\n")))))))))
+
 ;;; cl-macs-tests.el ends here
-- 
2.30.1 (Apple Git-130)