* lisp/emacs-lisp/pcase.el (pcase-defmacro): New macro.

(pcase--macroexpand): New function.
(pcase--expand): Use it.

3 files changed, 31 insertions, 1 deletions

diff --git a/etc/NEWS b/etc/NEWS
index cbad7c5b54b..397b8866f6b 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -104,6 +104,7 @@ performance improvements when pasting large amounts of text.
 
 ** pcase
 *** New UPatterns `quote' and `app'.
+*** New UPatterns can be defined with `pcase-defmacro'.
 
 ** Lisp mode
 *** Strings after `:documentation' are highlighted as docstrings.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 1aad2004d6a..32843569eda 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,9 @@
 2014-09-22  Stefan Monnier  <monnier@iro.umontreal.ca>
 
+        * emacs-lisp/pcase.el (pcase-defmacro): New macro.
+        (pcase--macroexpand): New function.
+        (pcase--expand): Use it.
+
         Add support for `quote' and `app'.
         * emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest):
         New optimization functions.
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index fbe241b6fc8..2d5f19fe5f7 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -284,7 +284,7 @@ of the form (UPAT EXP)."
            (main
             (pcase--u
              (mapcar (lambda (case)
-                       `((match ,val . ,(car case))
+                       `((match ,val . ,(pcase--macroexpand (car case)))
                          ,(lambda (vars)
                             (unless (memq case used-cases)
                               ;; Keep track of the cases that are used.
@@ -303,6 +303,31 @@ of the form (UPAT EXP)."
           (message "Redundant pcase pattern: %S" (car case))))
       (macroexp-let* defs main))))
 
+(defun pcase--macroexpand (pat)
+  "Expands all macro-patterns in PAT."
+  (let ((head (car-safe pat)))
+    (cond
+     ((memq head '(nil pred guard quote)) pat)
+     ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
+     ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
+     ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
+     (t
+      (let* ((expander (get head 'pcase-macroexpander))
+             (npat (if expander (apply expander (cdr pat)))))
+        (if (null npat)
+            (error (if expander
+                       "Unexpandable %s pattern: %S"
+                     "Unknown %s pattern: %S")
+                   head pat)
+          (pcase--macroexpand npat)))))))
+
+;;;###autoload
+(defmacro pcase-defmacro (name args &rest body)
+  "Define a pcase UPattern macro."
+  (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3))
+  `(put ',name 'pcase-macroexpander
+        (lambda ,args ,@body)))
+
 (defun pcase-codegen (code vars)
   ;; 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