[Emacs-diffs] master d7d7262: Add cl-struct specific optimizations to pcase.

[Stefan Monnier]

branch: master
commit d7d72624b29f0eeb2c242e976703e4755c6d7bef
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    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.
---
 lisp/ChangeLog             |    9 +++++++
 lisp/emacs-lisp/cl-macs.el |   52 ++++++++++++++++++++++++++++++++++++++++---
 lisp/emacs-lisp/pcase.el   |    1 +
 3 files changed, 58 insertions(+), 4 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 8670e45..25ac7ae 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,12 @@
+2015-03-24  Stefan Monnier  <address@hidden>
+
+       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  <address@hidden>
 
        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 a81d217..5d55a1d 100644
--- 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 a9933e4..3a2fa4f 100644
--- 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))))