master 0d827c7: * lisp/emacs-lisp/pcase.el: Fix bug#46786

[Stefan Monnier]

branch: master
commit 0d827c7f52b92aaffe751cf937427938f1ac67de
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * lisp/emacs-lisp/pcase.el: Fix bug#46786
    
    Revert commit a218c9861573b5ec4979ff2662f5c0343397e3ff, but in order
    to avoid the spurious warnings that this commit tried to squash,
    keep track of the vars used during the match so as to add
    corresponding annotations to explicitly silence the spurious warnings.
    
    To do this, we change the VARS used in `pcase-u` (and throughout
    the pcase code): they used to hold elements of the form (NAME . VAL)
    and now they hold elements of the form (NAME VAL . USED).
    
    (pcase--expand): Bind all vars instead of only those found via fgrep.
    (pcase-codegen): Silence "unused var" warnings for those vars that have
    already been referenced during the match itself.
    (pcase--funcall, pcase--eval): Record the vars that are used.
    (pcase--u1): Record the vars that are used via non-linear patterns.
    
    * lisp/textmodes/mhtml-mode.el (mhtml-forward):
    * lisp/vc/diff-mode.el (diff-goto-source): Silence newly
    discovered warnings.
    
    * test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-bug46786): New test.
---
 lisp/emacs-lisp/pcase.el            | 60 ++++++++++++++++++++++---------------
 lisp/textmodes/mhtml-mode.el        |  2 +-
 lisp/vc/diff-mode.el                |  2 +-
 test/lisp/emacs-lisp/pcase-tests.el |  7 +++++
 4 files changed, 45 insertions(+), 26 deletions(-)

diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index b1e1305..0fa1b98 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -328,8 +328,7 @@ of the elements of LIST is performed as if by `pcase-let'.
            (seen '())
            (codegen
             (lambda (code vars)
-              (let ((vars (macroexp--fgrep vars code))
-                    (prev (assq code seen)))
+              (let ((prev (assq code seen)))
                 (if (not prev)
                     (let ((res (pcase-codegen code vars)))
                       (push (list code vars res) seen)
@@ -354,14 +353,14 @@ of the elements of LIST is performed as if by `pcase-let'.
                         (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code))
                               defs)
                         (setcar res 'funcall)
-                        (setcdr res (cons bsym (mapcar #'cdr prevvars)))
+                        (setcdr res (cons bsym (mapcar #'cadr prevvars)))
                         (setcar (cddr prev) bsym)
                         (setq res bsym)))
                     (setq vars (copy-sequence vars))
                     (let ((args (mapcar (lambda (pa)
                                           (let ((v (assq (car pa) vars)))
                                             (setq vars (delq v vars))
-                                            (cdr v)))
+                                            (cadr v)))
                                         prevvars)))
                       ;; If some of `vars' were not found in `prevvars', that's
                       ;; OK it just means those vars aren't present in all
@@ -383,9 +382,7 @@ of the elements of LIST is performed as if by `pcase-let'.
                              (if (pcase--small-branch-p (cdr case))
                                  ;; Don't bother sharing multiple
                                  ;; occurrences of this leaf since it's small.
-                                 (lambda (code vars)
-                                   (pcase-codegen code
-                                                  (macroexp--fgrep vars code)))
+                                 #'pcase-codegen
                                codegen)
                              (cdr case)
                              vars))))
@@ -452,10 +449,15 @@ for the result of evaluating EXP (first arg to `pcase').
   ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
   ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
   ;; codegen from later metamorphosing this let into a funcall.
-  (if vars
-      `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
-         ,@code)
-    `(progn ,@code)))
+  (if (null vars)
+      `(progn ,@code)
+    `(let ,(mapcar (lambda (b) (list (car b) (cadr b))) vars)
+       ;; Try and silence some of the most common spurious "unused
+       ;; var" warnings.
+       ,@(delq nil (mapcar (lambda (var)
+                             (if (cddr var) `(ignore ,(car var))))
+                           vars))
+       ,@code)))
 
 (defun pcase--small-branch-p (code)
   (and (= 1 (length code))
@@ -497,11 +499,14 @@ for the result of evaluating EXP (first arg to `pcase').
   "Expand matcher for rules BRANCHES.
 Each BRANCH has the form (MATCH CODE . VARS) where
 CODE is the code generator for that branch.
-VARS is the set of vars already bound by earlier matches.
 MATCH is the pattern that needs to be matched, of the form:
   (match VAR . PAT)
   (and MATCH ...)
-  (or MATCH ...)"
+  (or MATCH ...)
+VARS is the set of vars already bound by earlier matches.
+It is a list of (NAME VAL . USED) where NAME is the variable's symbol,
+VAL is the expression to which it should be bound and USED is a boolean
+recording whether the var has been referenced by earlier parts of the match."
   (when (setq branches (delq nil branches))
     (let* ((carbranch (car branches))
            (match (car carbranch)) (cdarbranch (cdr carbranch))
@@ -748,8 +753,11 @@ A and B can be one of:
    ((symbolp fun) `(,fun ,arg))
    ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars)))
    (t
-    (let* (;; `env' is an upper bound on the bindings we need.
-           (env (mapcar (lambda (x) (list (car x) (cdr x)))
+    (let* (;; `env' is hopefully an upper bound on the bindings we need,
+           ;; FIXME: See bug#46786 for a counter example :-(
+           (env (mapcar (lambda (x)
+                          (setcdr (cdr x) 'used)
+                          (list (car x) (cadr x)))
                         (macroexp--fgrep vars fun)))
            (call (progn
                    (when (assq arg env)
@@ -757,7 +765,7 @@ A and B can be one of:
                      (let ((newsym (gensym "x")))
                        (push (list newsym arg) env)
                        (setq arg newsym)))
-                   (if (functionp fun)
+                   (if (or (functionp fun) (not (consp fun)))
                        `(funcall #',fun ,arg)
                      `(,@fun ,arg)))))
       (if (null env)
@@ -770,10 +778,12 @@ A and B can be one of:
 (defun pcase--eval (exp vars)
   "Build an expression that will evaluate EXP."
   (let* ((found (assq exp vars)))
-    (if found (cdr found)
+    (if found (progn (setcdr (cdr found) 'used) (cadr found))
       (let* ((env (macroexp--fgrep vars exp)))
         (if env
-            (macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x)))
+            (macroexp-let* (mapcar (lambda (x)
+                                     (setcdr (cdr x) 'used)
+                                     (list (car x) (cadr x)))
                                    env)
                            exp)
           exp)))))
@@ -865,12 +875,14 @@ Otherwise, it defers to REST which is a list of branches 
of the form
                      (pcase--u else-rest))))
        ((and (symbolp upat) upat)
         (pcase--mark-used sym)
-        (if (not (assq upat vars))
-            (pcase--u1 matches code (cons (cons upat sym) vars) rest)
-          ;; Non-linear pattern.  Turn it into an `eq' test.
-          (pcase--u1 (cons `(match ,sym . (pred (eql ,(cdr (assq upat vars)))))
-                           matches)
-                     code vars rest)))
+        (let ((v (assq upat vars)))
+          (if (not v)
+              (pcase--u1 matches code (cons (list upat sym) vars) rest)
+            ;; Non-linear pattern.  Turn it into an `eq' test.
+            (setq (cddr v) 'used)
+            (pcase--u1 (cons `(match ,sym . (pred (eql ,(cadr v))))
+                             matches)
+                       code vars rest))))
        ((eq (car-safe upat) 'app)
         ;; A upat of the form (app FUN PAT)
         (pcase--mark-used sym)
diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el
index 32542d0..2590538 100644
--- a/lisp/textmodes/mhtml-mode.el
+++ b/lisp/textmodes/mhtml-mode.el
@@ -313,7 +313,7 @@ Prefix arg specifies how many times to move (default 1)."
   (interactive "P")
   (pcase (get-text-property (point) 'mhtml-submode)
     ('nil (sgml-skip-tag-forward arg))
-    (submode (forward-sexp arg))))
+    (_submode (forward-sexp arg))))
 
 ;;;###autoload
 (define-derived-mode mhtml-mode html-mode
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 8bbab46..342b4cc 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -2003,7 +2003,7 @@ revision of the file otherwise."
   (if event (posn-set-point (event-end event)))
   (let ((buffer (when event (current-buffer)))
         (reverse (not (save-excursion (beginning-of-line) (looking-at 
"[-<]")))))
-    (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched)
+    (pcase-let ((`(,buf ,_line-offset ,pos ,src ,_dst ,_switched)
                  (diff-find-source-location other-file reverse)))
       (pop-to-buffer buf)
       (goto-char (+ (car pos) (cdr src)))
diff --git a/test/lisp/emacs-lisp/pcase-tests.el 
b/test/lisp/emacs-lisp/pcase-tests.el
index 1438411..6ddeb7b 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -83,6 +83,13 @@
     (should (equal (funcall f t) 'left))
     (should (equal (funcall f nil) 'right))))
 
+(ert-deftest pcase-tests-bug46786 ()
+  (let ((self 'outer))
+    (should (equal (cl-macrolet ((show-self () `(list 'self self)))
+                     (pcase-let ((`(,self ,self2) '(inner "2")))
+                       (show-self)))
+                   '(self inner)))))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End: