master d93bca0 2/2: * lisp/emacs-lisp/pcase.el (pcase--split-pred): Handle `memq` pred.

[Stefan Monnier]

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

    * lisp/emacs-lisp/pcase.el (pcase--split-pred): Handle `memq` pred.
    
    Improve handling of the `member` tests generated from (or 'a 'b 'c).
    This will expand
    
        (pcase EXP ((and (or 1 2 3) (guard (FOO))) EXP1) (1 EXP2) (6 EXP3))
    
    to
    
        (cond ((memql '(3 2 1) EXP)
               (cond ((FOO) EXP1) ((eql EXP 1) EXP2)))
              ((eql EXP 6) EXP3))
    
    rather than to
    
        (cond ((memql '(3 2 1) EXP)
               (cond ((FOO) EXP1) ((eql EXP 1) EXP2) ((eql EXP 6) EXP3)))
              ((eql EXP 1) EXP2)
              ((eql EXP 6) EXP3))
---
 lisp/emacs-lisp/pcase.el | 44 +++++++++++++++++++++++++++-----------------
 1 file changed, 27 insertions(+), 17 deletions(-)

diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index bfd577c..cf129c4 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -683,11 +683,6 @@ A and B can be one of:
                ;; and catch at least the easy cases such as (bug#14773).
                (not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
       '(:pcase--succeed . :pcase--fail))
-     ;; In case UPAT is of the form (pred (not PRED))
-     ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat))))
-      (let* ((test (cadr (cadr upat)))
-             (res (pcase--split-pred vars `(pred ,test) pat)))
-        (cons (cdr res) (car res))))
      ;; In case PAT is of the form (pred (not PRED))
      ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
       (let* ((test (cadr (cadr pat)))
@@ -696,19 +691,34 @@ A and B can be one of:
                                    ((eq x :pcase--fail) :pcase--succeed)))))
         (cons (funcall reverse (car res))
               (funcall reverse (cdr res)))))
-     ((and (eq 'pred (car upat))
-           (let ((otherpred
-                  (cond ((eq 'pred (car-safe pat)) (cadr pat))
-                        ((not (eq 'quote (car-safe pat))) nil)
-                        ((consp (cadr pat)) #'consp)
-                        ((stringp (cadr pat)) #'stringp)
-                        ((vectorp (cadr pat)) #'vectorp)
-                        ((byte-code-function-p (cadr pat))
-                         #'byte-code-function-p))))
-             (pcase--mutually-exclusive-p (cadr upat) otherpred)))
+     ;; All the rest below presumes UPAT is of the form (pred ...).
+     ((not (eq 'pred (car upat))) nil)
+     ;; In case UPAT is of the form (pred (not PRED))
+     ((eq 'not (car-safe (cadr upat)))
+      (let* ((test (cadr (cadr upat)))
+             (res (pcase--split-pred vars `(pred ,test) pat)))
+        (cons (cdr res) (car res))))
+     ((let ((otherpred
+             (cond ((eq 'pred (car-safe pat)) (cadr pat))
+                   ((not (eq 'quote (car-safe pat))) nil)
+                   ((consp (cadr pat)) #'consp)
+                   ((stringp (cadr pat)) #'stringp)
+                   ((vectorp (cadr pat)) #'vectorp)
+                   ((byte-code-function-p (cadr pat))
+                    #'byte-code-function-p))))
+        (pcase--mutually-exclusive-p (cadr upat) otherpred))
       '(:pcase--fail . nil))
-     ((and (eq 'pred (car upat))
-           (eq 'quote (car-safe pat))
+     ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
+     ;; try and preserve the info we get from that memq test.
+     ((and (eq 'pcase--flip (car-safe (cadr upat)))
+           (memq (cadr (cadr upat)) '(memq member memql))
+           (eq 'quote (car-safe (nth 2 (cadr upat))))
+           (eq 'quote (car-safe pat)))
+      (let ((set (cadr (nth 2 (cadr upat)))))
+        (if (member (cadr pat) set)
+            '(nil . :pcase--fail)
+          '(:pcase--fail . nil))))
+     ((and (eq 'quote (car-safe pat))
            (symbolp (cadr upat))
            (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
            (get (cadr upat) 'side-effect-free)