* lisp/subr.el (macrop): New function.

[bpt/emacs.git] / lisp / emacs-lisp / pcase.el

diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 50c9251..eb2c7f0 100644 (file)
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -353,23 +353,34 @@ MATCH is the pattern that needs to be matched, of the form:
     (symbolp . numberp)
     (symbolp . consp)
     (symbolp . arrayp)
+    (symbolp . vectorp)
     (symbolp . stringp)
     (symbolp . byte-code-function-p)
     (integerp . consp)
     (integerp . arrayp)
+    (integerp . vectorp)
     (integerp . stringp)
     (integerp . byte-code-function-p)
     (numberp . consp)
     (numberp . arrayp)
+    (numberp . vectorp)
     (numberp . stringp)
     (numberp . byte-code-function-p)
     (consp . arrayp)
+    (consp . vectorp)
     (consp . stringp)
     (consp . byte-code-function-p)
-    (arrayp . stringp)
     (arrayp . byte-code-function-p)
+    (vectorp . byte-code-function-p)
+    (stringp . vectorp)
     (stringp . byte-code-function-p)))
 
+(defun pcase--mutually-exclusive-p (pred1 pred2)
+  (or (member (cons pred1 pred2)
+              pcase-mutually-exclusive-predicates)
+      (member (cons pred2 pred1)
+              pcase-mutually-exclusive-predicates)))
+
 (defun pcase--split-match (sym splitter match)
   (cond
     ((eq (car match) 'match)
@@ -433,10 +444,7 @@ MATCH is the pattern that needs to be matched, of the form:
    ;; A QPattern but not for a cons, can only go to the `else' side.
    ((eq (car-safe pat) '\`) '(:pcase--fail . nil))
    ((and (eq (car-safe pat) 'pred)
-         (or (member (cons 'consp (cadr pat))
-                     pcase-mutually-exclusive-predicates)
-             (member (cons (cadr pat) 'consp)
-                     pcase-mutually-exclusive-predicates)))
+         (pcase--mutually-exclusive-p #'consp (cadr pat)))
     '(:pcase--fail . nil))))
 
 (defun pcase--split-equal (elem pat)
@@ -496,11 +504,14 @@ MATCH is the pattern that needs to be matched, of the form:
                (not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
       '(:pcase--succeed . :pcase--fail))
      ((and (eq 'pred (car upat))
-           (eq 'pred (car-safe pat))
-           (or (member (cons (cadr upat) (cadr pat))
-                       pcase-mutually-exclusive-predicates)
-               (member (cons (cadr pat) (cadr upat))
-                       pcase-mutually-exclusive-predicates)))
+           (let ((otherpred
+                  (cond ((eq 'pred (car-safe pat)) (cadr pat))
+                        ((not (eq '\` (car-safe pat))) nil)
+                        ((consp (cadr pat)) #'consp)
+                        ((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 '\` (car-safe pat))