Add pcase-defmacro, as well as quote' and app' patterns.

* loadup.el: Increase max-lisp-eval-depth when macroexpanding macroexp.
* emacs-lisp/pcase.el: Allow (F . ARGS) in `app' patterns.
(pcase--funcall, pcase--eval): New functions.
(pcase--u1): Use them for guard, pred, let, and app.
(\`): Use the new feature to generate better code for vector patterns.
* emacs-lisp/pcase.el: Use pcase-defmacro to handle backquote.
(pcase--upat): Remove.
(pcase--macroexpand): Don't hardcode handling of `.
(pcase--split-consp, pcase--split-vector): Remove.
(pcase--split-equal): Disregard ` since it's expanded away.
(pcase--split-member): Optimize for quote rather than for `.
(pcase--split-pred): Optimize for quote rather than for `.
(pcase--u1): Remove handling of ` (and of `or' and `and').
Quote non-selfquoting values when passing them to `eq'.
Drop `app's let-binding if the variable is not used.
(pcase--q1): Remove.
(`): Define as a pattern macro.
* emacs-lisp/pcase.el (pcase--match): New smart-constructor function.
(pcase--expand pcase--q1, pcase--app-subst-match): Use it.
(pcase--macroexpand): Handle self-quoting patterns here, expand them to
quote patterns.
(pcase--split-match): Don't hoist or/and here any more.
(pcase--split-equal): Optimize quote patterns as well as ` patterns.
(pcase--flip): New helper macro.
(pcase--u1): Optimize the memq case directly.
Don't handle neither self-quoting nor and/or patterns any more.
* emacs-lisp/pcase.el (pcase-defmacro): New macro.
(pcase--macroexpand): New function.
(pcase--expand): Use it.
* emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest):
New optimization functions.
(pcase--u1): Add support for `quote' and `app'.
(pcase): Document them in the docstring.

etc/NEWS

@@ -102,6 +102,10 @@ performance improvements when pasting large amounts of text.
 
 * Changes in Specialized Modes and Packages in Emacs 24.5
 
+** pcase
+*** New UPatterns `quote' and `app'.
+*** New UPatterns can be defined with `pcase-defmacro'.
+
 ** Lisp mode
 *** Strings after `:documentation' are highlighted as docstrings.
 

lisp/ChangeLog

@@ -1,3 +1,40 @@
+2014-09-22  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	Add pcase-defmacro, as well as `quote' and `app' patterns.
+	* loadup.el: Increase max-lisp-eval-depth when macroexpanding macroexp.
+	* emacs-lisp/pcase.el: Allow (F . ARGS) in `app' patterns.
+	(pcase--funcall, pcase--eval): New functions.
+	(pcase--u1): Use them for guard, pred, let, and app.
+	(\`): Use the new feature to generate better code for vector patterns.
+	* emacs-lisp/pcase.el: Use pcase-defmacro to handle backquote.
+	(pcase--upat): Remove.
+	(pcase--macroexpand): Don't hardcode handling of `.
+	(pcase--split-consp, pcase--split-vector): Remove.
+	(pcase--split-equal): Disregard ` since it's expanded away.
+	(pcase--split-member): Optimize for quote rather than for `.
+	(pcase--split-pred): Optimize for quote rather than for `.
+	(pcase--u1): Remove handling of ` (and of `or' and `and').
+	Quote non-selfquoting values when passing them to `eq'.
+	Drop `app's let-binding if the variable is not used.
+	(pcase--q1): Remove.
+	(`): Define as a pattern macro.
+	* emacs-lisp/pcase.el (pcase--match): New smart-constructor function.
+	(pcase--expand pcase--q1, pcase--app-subst-match): Use it.
+	(pcase--macroexpand): Handle self-quoting patterns here, expand them to
+	quote patterns.
+	(pcase--split-match): Don't hoist or/and here any more.
+	(pcase--split-equal): Optimize quote patterns as well as ` patterns.
+	(pcase--flip): New helper macro.
+	(pcase--u1): Optimize the memq case directly.
+	Don't handle neither self-quoting nor and/or patterns any more.
+	* emacs-lisp/pcase.el (pcase-defmacro): New macro.
+	(pcase--macroexpand): New function.
+	(pcase--expand): Use it.
+	* emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest):
+	New optimization functions.
+	(pcase--u1): Add support for `quote' and `app'.
+	(pcase): Document them in the docstring.
+
 2014-09-22  Stefan Monnier  <monnier@iro.umontreal.ca>
 
 	Use lexical-bindin in Ibuffer.

lisp/emacs-lisp/pcase.el

@@ -102,10 +102,12 @@ UPatterns can take the following forms:
   SYMBOL	matches anything and binds it to SYMBOL.
   (or UPAT...)	matches if any of the patterns matches.
   (and UPAT...)	matches if all the patterns match.
+  'VAL		matches if the object is `equal' to VAL
   `QPAT		matches if the QPattern QPAT matches.
-  (pred PRED)	matches if PRED applied to the object returns non-nil.
+  (pred FUN)	matches if FUN applied to the object returns non-nil.
   (guard BOOLEXP)	matches if BOOLEXP evaluates to non-nil.
   (let UPAT EXP)	matches if EXP matches UPAT.
+  (app FUN UPAT)	matches if FUN applied to the object matches UPAT.
 If a SYMBOL is used twice in the same pattern (i.e. the pattern is
 \"non-linear\"), then the second occurrence is turned into an `eq'uality test.
 
@@ -117,12 +119,14 @@ QPatterns can take the following forms:
   STRING                matches if the object is `equal' to STRING.
   ATOM                  matches if the object is `eq' to ATOM.
 
-PRED can take the form
-  FUNCTION	     in which case it gets called with one argument.
-  (FUN ARG1 .. ARGN) in which case it gets called with an N+1'th argument
+FUN can take the form
+  SYMBOL or (lambda ARGS BODY)  in which case it's called with one argument.
+  (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
                         which is the value being matched.
-A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
-PRED patterns can refer to variables bound earlier in the pattern.
+So a FUN of the form SYMBOL is equivalent to one of the form (FUN).
+FUN can refer to variables bound earlier in the pattern.
+FUN is assumed to be pure, i.e. it can be dropped if its result is not used,
+and two identical calls can be merged into one.
 E.g. you can match pairs where the cdr is larger than the car with a pattern
 like `(,a . ,(pred (< a))) or, with more checks:
 `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
@@ -157,6 +161,7 @@ like `(,a . ,(pred (< a))) or, with more checks:
   (let* ((x (make-symbol "x"))
          (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
     (pcase--expand
+     ;; FIXME: Could we add the FILE:LINE data in the error message?
      exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
 
 (defun pcase--let* (bindings body)
@@ -277,7 +282,7 @@ of the form (UPAT EXP)."
            (main
             (pcase--u
              (mapcar (lambda (case)
-                       `((match ,val . ,(car case))
+                       `(,(pcase--match val (pcase--macroexpand (car case)))
                          ,(lambda (vars)
                             (unless (memq case used-cases)
                               ;; Keep track of the cases that are used.
@@ -296,6 +301,45 @@ 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
+     ((null head)
+      (if (pcase--self-quoting-p pat) `',pat pat))
+     ((memq head '(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--match (val upat)
+  "Build a MATCH structure, hoisting all `or's and `and's outside."
+  (cond
+   ;; Hoist or/and patterns into or/and matches.
+   ((memq (car-safe upat) '(or and))
+    `(,(car upat)
+      ,@(mapcar (lambda (upat)
+                  (pcase--match val upat))
+                (cdr upat))))
+   (t
+    `(match ,val . ,upat))))
+
 (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
@@ -319,11 +363,6 @@ of the form (UPAT EXP)."
    ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
    (t (macroexp-if test then else))))
 
-(defun pcase--upat (qpattern)
-  (cond
-   ((eq (car-safe qpattern) '\,) (cadr qpattern))
-   (t (list '\` qpattern))))
-
 ;; Note about MATCH:
 ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
 ;; check, we want to turn all the similar patterns into ones of the form
@@ -399,17 +438,8 @@ MATCH is the pattern that needs to be matched, of the form:
     ((eq (car match) 'match)
      (if (not (eq sym (cadr match)))
          (cons match match)
-       (let ((pat (cddr match)))
-         (cond
-          ;; Hoist `or' and `and' patterns to `or' and `and' matches.
-          ((memq (car-safe pat) '(or and))
-           (pcase--split-match sym splitter
-                               (cons (car pat)
-                                     (mapcar (lambda (alt)
-                                               `(match ,sym . ,alt))
-                                             (cdr pat)))))
-          (t (let ((res (funcall splitter (cddr match))))
-               (cons (or (car res) match) (or (cdr res) match))))))))
+       (let ((res (funcall splitter (cddr match))))
+         (cons (or (car res) match) (or (cdr res) match)))))
     ((memq (car match) '(or and))
      (let ((then-alts '())
            (else-alts '())
@@ -446,45 +476,13 @@ MATCH is the pattern that needs to be matched, of the form:
           (push (cons (cdr split) code&vars) else-rest))))
     (cons (nreverse then-rest) (nreverse else-rest))))
 
-(defun pcase--split-consp (syma symd pat)
-  (cond
-   ;; A QPattern for a cons, can only go the `then' side.
-   ((and (eq (car-safe pat) '\`) (consp (cadr pat)))
-    (let ((qpat (cadr pat)))
-      (cons `(and (match ,syma . ,(pcase--upat (car qpat)))
-                  (match ,symd . ,(pcase--upat (cdr qpat))))
-            :pcase--fail)))
-   ;; 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)
-         (pcase--mutually-exclusive-p #'consp (cadr pat)))
-    '(:pcase--fail . nil))))
-
-(defun pcase--split-vector (syms pat)
-  (cond
-   ;; A QPattern for a vector of same length.
-   ((and (eq (car-safe pat) '\`)
-         (vectorp (cadr pat))
-         (= (length syms) (length (cadr pat))))
-    (let ((qpat (cadr pat)))
-      (cons `(and ,@(mapcar (lambda (s)
-                              `(match ,(car s) .
-                                      ,(pcase--upat (aref qpat (cdr s)))))
-                            syms))
-            :pcase--fail)))
-   ;; Other QPatterns go to the `else' side.
-   ((eq (car-safe pat) '\`) '(:pcase--fail . nil))
-   ((and (eq (car-safe pat) 'pred)
-         (pcase--mutually-exclusive-p #'vectorp (cadr pat)))
-    '(:pcase--fail . nil))))
-
 (defun pcase--split-equal (elem pat)
   (cond
    ;; The same match will give the same result.
-   ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem))
+   ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem))
     '(:pcase--succeed . :pcase--fail))
    ;; A different match will fail if this one succeeds.
-   ((and (eq (car-safe pat) '\`)
+   ((and (eq (car-safe pat) 'quote)
          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
          ;;     (consp (cadr pat)))
          )
@@ -498,6 +496,7 @@ MATCH is the pattern that needs to be matched, of the form:
 	'(:pcase--fail . nil))))))
 
 (defun pcase--split-member (elems pat)
+  ;; FIXME: The new pred-based member code doesn't do these optimizations!
   ;; Based on pcase--split-equal.
   (cond
    ;; The same match (or a match of membership in a superset) will
@@ -505,10 +504,10 @@ MATCH is the pattern that needs to be matched, of the form:
    ;; (???
    ;;  '(:pcase--succeed . nil))
    ;; A match for one of the elements may succeed or fail.
-   ((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
+   ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems))
     nil)
    ;; A different match will fail if this one succeeds.
-   ((and (eq (car-safe pat) '\`)
+   ((and (eq (car-safe pat) 'quote)
          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
          ;;     (consp (cadr pat)))
          )
@@ -539,7 +538,7 @@ MATCH is the pattern that needs to be matched, of the form:
      ((and (eq 'pred (car upat))
            (let ((otherpred
                   (cond ((eq 'pred (car-safe pat)) (cadr pat))
-                        ((not (eq '\` (car-safe pat))) nil)
+                        ((not (eq 'quote (car-safe pat))) nil)
                         ((consp (cadr pat)) #'consp)
                         ((vectorp (cadr pat)) #'vectorp)
                         ((byte-code-function-p (cadr pat))
@@ -547,7 +546,7 @@ MATCH is the pattern that needs to be matched, of the form:
              (pcase--mutually-exclusive-p (cadr upat) otherpred)))
       '(:pcase--fail . nil))
      ((and (eq 'pred (car upat))
-           (eq '\` (car-safe pat))
+           (eq 'quote (car-safe pat))
            (symbolp (cadr upat))
            (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
            (get (cadr upat) 'side-effect-free)
@@ -569,10 +568,70 @@ MATCH is the pattern that needs to be matched, of the form:
 (defun pcase--self-quoting-p (upat)
   (or (keywordp upat) (numberp upat) (stringp upat)))
 
+(defun pcase--app-subst-match (match sym fun nsym)
+  (cond
+   ((eq (car match) 'match)
+    (if (and (eq sym (cadr match))
+             (eq 'app (car-safe (cddr match)))
+             (equal fun (nth 1 (cddr match))))
+        (pcase--match nsym (nth 2 (cddr match)))
+      match))
+   ((memq (car match) '(or and))
+    `(,(car match)
+      ,@(mapcar (lambda (match)
+                  (pcase--app-subst-match match sym fun nsym))
+                (cdr match))))
+   (t (error "Uknown MATCH %s" match))))
+
+(defun pcase--app-subst-rest (rest sym fun nsym)
+  (mapcar (lambda (branch)
+            `(,(pcase--app-subst-match (car branch) sym fun nsym)
+              ,@(cdr branch)))
+          rest))
+
 (defsubst pcase--mark-used (sym)
   ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
   (if (symbolp sym) (put sym 'pcase-used t)))
 
+(defmacro pcase--flip (fun arg1 arg2)
+  "Helper function, used internally to avoid (funcall (lambda ...) ...)."
+  (declare (debug (sexp body)))
+  `(,fun ,arg2 ,arg1))
+
+(defun pcase--funcall (fun arg vars)
+  "Build a function call to FUN with arg ARG."
+  (if (symbolp fun)
+      `(,fun ,arg)
+    (let* (;; `vs' is an upper bound on the vars we need.
+           (vs (pcase--fgrep (mapcar #'car vars) fun))
+           (env (mapcar (lambda (var)
+                          (list var (cdr (assq var vars))))
+                        vs))
+           (call (progn
+                   (when (memq arg vs)
+                     ;; `arg' is shadowed by `env'.
+                     (let ((newsym (make-symbol "x")))
+                       (push (list newsym arg) env)
+                       (setq arg newsym)))
+                   (if (functionp fun)
+                       `(funcall #',fun ,arg)
+                     `(,@fun ,arg)))))
+      (if (null vs)
+          call
+        ;; Let's not replace `vars' in `fun' since it's
+        ;; too difficult to do it right, instead just
+        ;; let-bind `vars' around `fun'.
+        `(let* ,env ,call)))))
+
+(defun pcase--eval (exp vars)
+  "Build an expression that will evaluate EXP."
+  (let* ((found (assq exp vars)))
+    (if found (cdr found)
+      (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
+             (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
+                          vs)))
+        (if env (macroexp-let* env exp) exp)))))
+
 ;; It's very tempting to use `pcase' below, tho obviously, it'd create
 ;; bootstrapping problems.
 (defun pcase--u1 (matches code vars rest)
@@ -594,22 +653,26 @@ Otherwise, it defers to REST which is a list of branches of the form
    ((eq 'or (caar matches))
     (let* ((alts (cdar matches))
            (var (if (eq (caar alts) 'match) (cadr (car alts))))
-           (simples '()) (others '()))
+           (simples '()) (others '()) (memq-ok t))
       (when var
         (dolist (alt alts)
           (if (and (eq (car alt) 'match) (eq var (cadr alt))
                    (let ((upat (cddr alt)))
-                     (and (eq (car-safe upat) '\`)
-                          (or (integerp (cadr upat)) (symbolp (cadr upat))
-                              (stringp (cadr upat))))))
-              (push (cddr alt) simples)
+                     (eq (car-safe upat) 'quote)))
+              (let ((val (cadr (cddr alt))))
+                (unless (or (integerp val) (symbolp val))
+                  (setq memq-ok nil))
+                (push (cadr (cddr alt)) simples))
             (push alt others))))
       (cond
        ((null alts) (error "Please avoid it") (pcase--u rest))
+       ;; Yes, we can use `memq' (or `member')!
        ((> (length simples) 1)
-        ;; De-hoist the `or' MATCH into an `or' pattern that will be
-        ;; turned into a `memq' below.
-        (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
+        (pcase--u1 (cons `(match ,var
+                                 . (pred (pcase--flip
+                                          ,(if memq-ok #'memq #'member)
+                                          ',simples)))
+                         (cdr matches))
                    code vars
                    (if (null others) rest
                      (cons (cons
@@ -643,35 +706,11 @@ Otherwise, it defers to REST which is a list of branches of the form
                  sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
                (then-rest (car splitrest))
                (else-rest (cdr splitrest)))
-          (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat)))
-                         `(,(cadr upat) ,sym)
-                       (let* ((exp (cadr upat))
-                              ;; `vs' is an upper bound on the vars we need.
-                              (vs (pcase--fgrep (mapcar #'car vars) exp))
-                              (env (mapcar (lambda (var)
-                                             (list var (cdr (assq var vars))))
-                                           vs))
-                              (call (if (eq 'guard (car upat))
-                                        exp
-                                      (when (memq sym vs)
-                                        ;; `sym' is shadowed by `env'.
-                                        (let ((newsym (make-symbol "x")))
-                                          (push (list newsym sym) env)
-                                          (setq sym newsym)))
-                                      (if (functionp exp)
-                                          `(funcall #',exp ,sym)
-                                        `(,@exp ,sym)))))
-                         (if (null vs)
-                             call
-                           ;; Let's not replace `vars' in `exp' since it's
-                           ;; too difficult to do it right, instead just
-                           ;; let-bind `vars' around `exp'.
-                           `(let* ,env ,call))))
+          (pcase--if (if (eq (car upat) 'pred)
+                         (pcase--funcall (cadr upat) sym vars)
+                       (pcase--eval (cadr upat) vars))
                      (pcase--u1 matches code vars then-rest)
                      (pcase--u else-rest))))
-       ((pcase--self-quoting-p upat)
-        (pcase--mark-used sym)
-        (pcase--q1 sym upat matches code vars rest))
        ((symbolp upat)
         (pcase--mark-used sym)
         (if (not (assq upat vars))
@@ -686,57 +725,41 @@ Otherwise, it defers to REST which is a list of branches of the form
         ;;            (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
         (macroexp-let2
             macroexp-copyable-p sym
-            (let* ((exp (nth 2 upat))
-                   (found (assq exp vars)))
-              (if found (cdr found)
-                (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
-                       (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
-                                    vs)))
-                  (if env (macroexp-let* env exp) exp))))
-          (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
+            (pcase--eval (nth 2 upat) vars)
+          (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
                      code vars rest)))
-       ((eq (car-safe upat) '\`)
+       ((eq (car-safe upat) 'app)
+        ;; A upat of the form (app FUN UPAT)
         (pcase--mark-used sym)
-        (pcase--q1 sym (cadr upat) matches code vars rest))
-       ((eq (car-safe upat) 'or)
-        (let ((all (> (length (cdr upat)) 1))
-              (memq-fine t))
-          (when all
-            (dolist (alt (cdr upat))
-              (unless (if (pcase--self-quoting-p alt)
-                          (progn
-                            (unless (or (symbolp alt) (integerp alt))
-                              (setq memq-fine nil))
-                            t)
-                        (and (eq (car-safe alt) '\`)
-                             (or (symbolp (cadr alt)) (integerp (cadr alt))
-                                 (setq memq-fine nil)
-                                 (stringp (cadr alt)))))
-                (setq all nil))))
-          (if all
-              ;; Use memq for (or `a `b `c `d) rather than a big tree.
-              (let* ((elems (mapcar (lambda (x) (if (consp x) (cadr x) x))
-                                    (cdr upat)))
-                     (splitrest
-                      (pcase--split-rest
-                       sym (lambda (pat) (pcase--split-member elems pat)) rest))
-                     (then-rest (car splitrest))
-                     (else-rest (cdr splitrest)))
-                (pcase--mark-used sym)
-                (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
-                           (pcase--u1 matches code vars then-rest)
-                           (pcase--u else-rest)))
-            (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
-                       (append (mapcar (lambda (upat)
-                                         `((and (match ,sym . ,upat) ,@matches)
-                                           ,code ,@vars))
-                                       (cddr upat))
-                               rest)))))
-       ((eq (car-safe upat) 'and)
-        (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat))
-                                   (cdr upat))
-                           matches)
-                   code vars rest))
+        (let* ((fun (nth 1 upat))
+               (nsym (make-symbol "x"))
+               (body
+                ;; We don't change `matches' to reuse the newly computed value,
+                ;; because we assume there shouldn't be such redundancy in there.
+                (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches)
+                           code vars
+                           (pcase--app-subst-rest rest sym fun nsym))))
+          (if (not (get nsym 'pcase-used))
+              body
+            (macroexp-let*
+             `((,nsym ,(pcase--funcall fun sym vars)))
+             body))))
+       ((eq (car-safe upat) 'quote)
+        (pcase--mark-used sym)
+        (let* ((val (cadr upat))
+               (splitrest (pcase--split-rest
+                           sym (lambda (pat) (pcase--split-equal val pat)) rest))
+               (then-rest (car splitrest))
+               (else-rest (cdr splitrest)))
+          (pcase--if (cond
+                      ((null val) `(null ,sym))
+                      ((or (integerp val) (symbolp val))
+                       (if (pcase--self-quoting-p val)
+                           `(eq ,sym ,val)
+                         `(eq ,sym ',val)))
+                      (t `(equal ,sym ',val)))
+                     (pcase--u1 matches code vars then-rest)
+                     (pcase--u else-rest))))
        ((eq (car-safe upat) 'not)
         ;; FIXME: The implementation below is naive and results in
         ;; inefficient code.
@@ -758,79 +781,25 @@ Otherwise, it defers to REST which is a list of branches of the form
                      (pcase--u rest))
                    vars
                    (list `((and . ,matches) ,code . ,vars))))
-       (t (error "Unknown upattern `%s'" upat)))))
-   (t (error "Incorrect MATCH %s" (car matches)))))
+       (t (error "Unknown internal pattern `%S'" upat)))))
+   (t (error "Incorrect MATCH %S" (car matches)))))
 
-(defun pcase--q1 (sym qpat matches code vars rest)
-  "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
-Otherwise, it defers to REST which is a list of branches of the form
-\(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
+(pcase-defmacro \` (qpat)
   (cond
-   ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
-   ((floatp qpat) (error "Floating point patterns not supported"))
+   ((eq (car-safe qpat) '\,) (cadr qpat))
    ((vectorp qpat)
-    (let* ((len (length qpat))
-           (syms (mapcar (lambda (i) (cons (make-symbol (format "xaref%s" i)) i))
-                         (number-sequence 0 (1- len))))
-           (splitrest (pcase--split-rest
-                       sym
-                       (lambda (pat) (pcase--split-vector syms pat))
-                       rest))
-           (then-rest (car splitrest))
-           (else-rest (cdr splitrest))
-           (then-body (pcase--u1
-                       `(,@(mapcar (lambda (s)
-                                     `(match ,(car s) .
-                                             ,(pcase--upat (aref qpat (cdr s)))))
-                                   syms)
-                         ,@matches)
-                       code vars then-rest)))
-      (pcase--if
-       `(and (vectorp ,sym) (= (length ,sym) ,len))
-       (macroexp-let* (delq nil (mapcar (lambda (s)
-                                          (and (get (car s) 'pcase-used)
-                                               `(,(car s) (aref ,sym ,(cdr s)))))
-                                        syms))
-                      then-body)
-       (pcase--u else-rest))))
+    `(and (pred vectorp)
+          (app length ,(length qpat))
+          ,@(let ((upats nil))
+              (dotimes (i (length qpat))
+                (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
+                      upats))
+              (nreverse upats))))
    ((consp qpat)
-    (let* ((syma (make-symbol "xcar"))
-           (symd (make-symbol "xcdr"))
-           (splitrest (pcase--split-rest
-                       sym
-                       (lambda (pat) (pcase--split-consp syma symd pat))
-                       rest))
-           (then-rest (car splitrest))
-           (else-rest (cdr splitrest))
-           (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
-                                   (match ,symd . ,(pcase--upat (cdr qpat)))
-                                   ,@matches)
-                                 code vars then-rest)))
-      (pcase--if
-       `(consp ,sym)
-       ;; We want to be careful to only add bindings that are used.
-       ;; The byte-compiler could do that for us, but it would have to pay
-       ;; attention to the `consp' test in order to figure out that car/cdr
-       ;; can't signal errors and our byte-compiler is not that clever.
-       ;; FIXME: Some of those let bindings occur too early (they are used in
-       ;; `then-body', but only within some sub-branch).
-       (macroexp-let*
-        `(,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
-          ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
-        then-body)
-       (pcase--u else-rest))))
-   ((or (integerp qpat) (symbolp qpat) (stringp qpat))
-    (let* ((splitrest (pcase--split-rest
-                       sym (lambda (pat) (pcase--split-equal qpat pat)) rest))
-           (then-rest (car splitrest))
-           (else-rest (cdr splitrest)))
-      (pcase--if (cond
-                  ((stringp qpat) `(equal ,sym ,qpat))
-                  ((null qpat) `(null ,sym))
-                  (t `(eq ,sym ',qpat)))
-                 (pcase--u1 matches code vars then-rest)
-                 (pcase--u else-rest))))
-   (t (error "Unknown QPattern %s" qpat))))
+    `(and (pred consp)
+          (app car ,(list '\` (car qpat)))
+          (app cdr ,(list '\` (cdr qpat)))))
+   ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat)))
 
 
 (provide 'pcase)

lisp/loadup.el

@@ -119,7 +119,8 @@
   (let ((macroexp--pending-eager-loads '(skip)))
     (load "emacs-lisp/pcase"))
   ;; Re-load macroexp so as to eagerly macro-expand its uses of pcase.
-  (load "emacs-lisp/macroexp"))
+  (let ((max-lisp-eval-depth (* 2 max-lisp-eval-depth)))
+    (load "emacs-lisp/macroexp")))
 
 (load "cus-face")
 (load "faces")  ; after here, `defface' may be used.

test/automated/pcase-tests.el

@@ -0,0 +1,68 @@
+;;; pcase-tests.el --- Test suite for pcase macro.
+
+;; Copyright (C) 2012-2014 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'cl-lib)
+
+(ert-deftest pcase-tests-base ()
+  "Test pcase code."
+  (should (equal (pcase '(1 . 2) ((app car '2) 6) ((app car '1) 5)) 5)))
+
+(pcase-defmacro pcase-tests-plus (pat n)
+  `(app (lambda (v) (- v ,n)) ,pat))
+
+(ert-deftest pcase-tests-macro ()
+  (should (equal (pcase 5 ((pcase-tests-plus x 3) x)) 2)))
+
+(defun pcase-tests-grep (fname exp)
+  (when (consp exp)
+    (or (eq fname (car exp))
+        (cl-some (lambda (exp) (pcase-tests-grep fname exp)) (cdr exp)))))
+
+(ert-deftest pcase-tests-tests ()
+  (should (pcase-tests-grep 'memq '(or (+ 2 3) (memq x y))))
+  (should-not (pcase-tests-grep 'memq '(or (+ 2 3) (- x y)))))
+
+(ert-deftest pcase-tests-member ()
+  (should (pcase-tests-grep
+           'memq (macroexpand-all '(pcase x ((or 1 2 3) body)))))
+  (should (pcase-tests-grep
+           'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body)))))
+  (should-not (pcase-tests-grep
+               'memq (macroexpand-all '(pcase x ((or "a" 2 3) body)))))
+  (let ((exp (macroexpand-all
+                      '(pcase x
+                         ("a" body1)
+                         (2 body2)
+                         ((or "a" 2 3) body)))))
+    (should-not (pcase-tests-grep 'memq exp))
+    (should-not (pcase-tests-grep 'member exp))))
+
+(ert-deftest pcase-tests-vectors ()
+  (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3)))
+
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
+
+;;; pcase-tests.el ends here.