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.

1 files changed, 68 insertions, 0 deletions

diff --git a/test/automated/pcase-tests.el b/test/automated/pcase-tests.el
new file mode 100644
index 00000000000..ec0c3bc7fd5
--- /dev/null
+++ b/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.