* lisp/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.

3 files changed, 54 insertions, 49 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 6f8178a9a4c..f1401b1b38a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,10 @@
 2014-09-22  Stefan Monnier  <monnier@iro.umontreal.ca>
 
+        * 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 `.
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index e17088ac9f2..ddcd4040f2b 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -104,17 +104,13 @@ UPatterns can take the following forms:
   (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.
 
-FUN can be either of the form (lambda ARGS BODY) or a symbol.
-It has to obey the rule that if (FUN X) returns V then calling it again will
-return the same V again (so that multiple (FUN X) can be consolidated).
-
 QPatterns can take the following forms:
   (QPAT1 . QPAT2)       matches if QPAT1 matches the car and QPAT2 the cdr.
   [QPAT1 QPAT2..QPATn]  matches a vector of length n and QPAT1..QPATn match
@@ -123,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 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))))"
@@ -600,6 +598,40 @@ MATCH is the pattern that needs to be matched, of the form:
   (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)
@@ -674,30 +706,9 @@ 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))))
        ((symbolp upat)
@@ -714,13 +725,7 @@ 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--eval (nth 2 upat) vars)
           (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
                      code vars rest)))
        ((eq (car-safe upat) 'app)
@@ -737,14 +742,7 @@ Otherwise, it defers to REST which is a list of branches of the form
           (if (not (get nsym 'pcase-used))
               body
             (macroexp-let*
-             `((,nsym
-                ,(if (symbolp fun)
-                     `(,fun ,sym)
-                   (let* ((vs (pcase--fgrep (mapcar #'car vars) fun))
-                          (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
-                                       vs))
-                          (call `(funcall #',fun ,sym)))
-                     (if env (macroexp-let* env call) call)))))
+             `((,nsym ,(pcase--funcall fun sym vars)))
              body))))
        ((eq (car-safe upat) 'quote)
         (pcase--mark-used sym)
@@ -794,7 +792,7 @@ Otherwise, it defers to REST which is a list of branches of the form
           (app length ,(length qpat))
           ,@(let ((upats nil))
               (dotimes (i (length qpat))
-                (push `(app (lambda (v) (aref v ,i)) ,(list '\` (aref qpat i)))
+                (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
                       upats))
               (nreverse upats))))
    ((consp qpat)
diff --git a/test/automated/pcase-tests.el b/test/automated/pcase-tests.el
index 7e3c40235e6..ec0c3bc7fd5 100644
--- a/test/automated/pcase-tests.el
+++ b/test/automated/pcase-tests.el
@@ -58,6 +58,8 @@
     (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