Add cl-struct specific optimizations to pcase.

* lisp/emacs-lisp/cl-macs.el (cl--struct-all-parents)
(cl--pcase-mutually-exclusive-p): New functions.
(pcase--mutually-exclusive-p): Advise to optimize cl-struct patterns.

* lisp/emacs-lisp/pcase.el (pcase--split-pred): Handle quoted string.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 8670e450e283fb33b2009f6069bf9d2fe7bb9023..25ac7ae67826ba6c1452c5a5bd04883cb54ec62d 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,12 @@
+2015-03-24  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+       Add cl-struct specific optimizations to pcase.
+       * emacs-lisp/cl-macs.el (cl--struct-all-parents)
+       (cl--pcase-mutually-exclusive-p): New functions.
+       (pcase--mutually-exclusive-p): Advise to optimize cl-struct patterns.
+
+       * emacs-lisp/pcase.el (pcase--split-pred): Handle quoted string.
+
 2015-03-23  Stefan Monnier  <monnier@iro.umontreal.ca>
 
        Add new `cl-struct' and `eieio' pcase patterns.

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index a81d217e4ee36c5e3f11c8c4984c448ed9890652..5d55a1d45799e39e274973c2f4fe35501ef3aa06 100644 (file)
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2770,16 +2770,25 @@ non-nil value, that slot cannot be set via `setf'.
 
 ;;; Add cl-struct support to pcase
 
+(defun cl--struct-all-parents (class)
+  (when (cl--struct-class-p class)
+    (let ((res ())
+          (classes (list class)))
+      ;; BFS precedence.
+      (while (let ((class (pop classes)))
+               (push class res)
+               (setq classes
+                     (append classes
+                             (cl--class-parents class)))))
+      (nreverse res))))
+
 ;;;###autoload
 (pcase-defmacro cl-struct (type &rest fields)
   "Pcase patterns to match cl-structs.
 Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of
 field NAME is matched against UPAT, or they can be of the form NAME which
 is a shorthand for (NAME NAME)."
-  ;; FIXME: This works well for a destructuring pcase-let, but for straight
-  ;; pcase, it suffers seriously from a lack of support for cl-typep in
-  ;; pcase--mutually-exclusive-p.
-  `(and (pred (pcase--swap cl-typep ',type))
+  `(and (pred (pcase--flip cl-typep ',type))
         ,@(mapcar
            (lambda (field)
              (let* ((name (if (consp field) (car field) field))
@@ -2790,6 +2799,41 @@ is a shorthand for (NAME NAME)."
                      ,pat)))
            fields)))
 
+(defun cl--pcase-mutually-exclusive-p (orig pred1 pred2)
+  "Extra special cases for `cl-typep' predicates."
+  (let* ((x1 pred1) (x2 pred2)
+         (t1
+          (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1))
+               (eq 'cl-typep (car-safe x1))    (setq x1 (cdr x1))
+               (null (cdr-safe x1))            (setq x1 (car x1))
+               (eq 'quote (car-safe x1))       (cadr x1)))
+         (t2
+          (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2))
+               (eq 'cl-typep (car-safe x2))    (setq x2 (cdr x2))
+               (null (cdr-safe x2))            (setq x2 (car x2))
+               (eq 'quote (car-safe x2))       (cadr x2))))
+    (or
+     (and (symbolp t1) (symbolp t2)
+          (let ((c1 (cl--find-class t1))
+                (c2 (cl--find-class t2)))
+            (and c1 c2
+                 (not (or (memq c1 (cl--struct-all-parents c2))
+                          (memq c2 (cl--struct-all-parents c1)))))))
+     (let ((c1 (and (symbolp t1) (cl--find-class t1))))
+       (and c1 (cl--struct-class-p c1)
+            (funcall orig (if (eq 'list (cl-struct-sequence-type t1))
+                              'consp 'vectorp)
+                     pred2)))
+     (let ((c2 (and (symbolp t2) (cl--find-class t2))))
+       (and c2 (cl--struct-class-p c2)
+            (funcall orig pred1
+                     (if (eq 'list (cl-struct-sequence-type t2))
+                         'consp 'vectorp))))
+     (funcall orig pred1 pred2))))
+(advice-add 'pcase--mutually-exclusive-p
+            :around #'cl--pcase-mutually-exclusive-p)
+
+
 (defun cl-struct-sequence-type (struct-type)
   "Return the sequence used to build STRUCT-TYPE.
 STRUCT-TYPE is a symbol naming a struct type.  Return 'vector or

diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index a9933e46bbd3cb217cadadad3b42abee71d23049..3a2fa4fdc81bdcf59242a2220fe3a2f9bc66a66c 100644 (file)
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -582,6 +582,7 @@ MATCH is the pattern that needs to be matched, of the form:
                   (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))))