From a16bf1ded587b7cc974dafa5f72427f3a1f6c5ff Mon Sep 17 00:00:00 2001
From: Earl Hyatt <okamsn@protonmail.com>
Date: Sat, 25 Nov 2023 13:00:03 -0500
Subject: [PATCH] Add the Pcase pattern `cl-lambda' for matching lambda list.

This pattern matches function argument lists as described in the Info
node `(cl)Argument Lists'.

* lisp/emacs-lisp/cl-macs.el (cl-lambda--pcase-macroexpander)
(cl-lambda, cl--pcase-lambda-list-get-var-groups)
(cl--pcase-cl-lambda-positional-pattern)
(cl--pcase-cl-lambda-plist-keys)
(cl--pcase-cl-lambda-&key-pattern)
(cl--pcase-cl-lambda-&aux-pattern):
Add pattern and supporting functions.

* test/lisp/emacs-lisp/pcase-tests.el:
(pcase-tests-cl-lambda-&whole-should-error)
(pcase-tests-cl-lambda-&whole)
(pcase-tests-cl-lambda-pos, pcase-tests-cl-lambda-pos-sub-patterns)
(pcase-tests-cl-lambda-&optional-should-error)
(pcase-tests-cl-lambda-&optional)
(pcase-tests-cl-lambda-&optional-sub-patterns)
(pcase-tests-cl-lambda-&rest-should-error)
(pcase-tests-cl-lambda-&rest-nonlist-cdr)
(pcase-tests-cl-lambda-&rest-with-&whole)
(pcase-tests-cl-lambda-&rest-only)
(pcase-tests-cl-lambda-&rest-after-&optional)
(pcase-tests-cl-lambda-&rest-sub-patterns)
(pcase-tests-cl-lambda-&key-should-error)
(pcase-tests-cl-lambda-&key-exact)
(pcase-tests-cl-lambda-&key-permissive)
(pcase-tests-cl-lambda-&key-not-first)
(pcase-tests-cl-lambda-&key-full-form)
(pcase-tests-cl-lambda-&key-sub-patterns)
(pcase-tests-cl-lambda-&aux-should-error)
(pcase-tests-cl-lambda-&aux)
(pcase-tests-cl-lambda-&aux-sub-patterns)
(pcase-tests-cl-lambda-all):
Add tests.
---
 lisp/emacs-lisp/cl-macs.el          | 325 ++++++++++++++++++
 test/lisp/emacs-lisp/pcase-tests.el | 515 ++++++++++++++++++++++++++++
 2 files changed, 840 insertions(+)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 7c207d372fc..00c10f6458f 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3825,6 +3825,331 @@ cl-type
 TYPE is a type descriptor as accepted by `cl-typep', which see."
   `(pred (pcase--flip cl-typep ',type)))
 
+;;; Pcase lambda-list pattern
+
+;; This pattern is like `cl-destructuring-bind', but with `pcase'.  We
+;; can't use `cl--do-arglist' for this, because `cl--do-arglist' uses
+;; `pop' to modify earlier variables while setting later ones, which
+;; doesn't seem to work with `pcase'.
+
+(defconst cl--pcase-lambda-list-constructs
+  '(&whole &optional &rest &key &allow-other-keys &aux)
+  "Symbols that change how the following elements are understood.")
+
+(define-error 'cl--pcase-lambda-list-bad-lambda-list
+              "Error in `cl-lambda' pattern.")
+
+(defun cl--pcase-cl-lambda-var-groups (lambda-list)
+  "Return the alist of variable groups in LAMBDA-LIST.
+
+Lists are of the form
+`([&whole WHOLE-VAR] [POS-VARS] [&optional OPT-VARS] [&rest REST-VAR]
+[&key KEY-VARS] [&aux AUX-VARS])'."
+  (let ((whole-var) (processing-whole)
+        (pos-var)
+        (opt-var) (processing-opts)
+        (rest-var) (processing-rest) (dotted-rest-var)
+        (key-var) (processing-keys) (allow-other-keys)
+        (aux-var) (processing-auxs)
+        (remaining-list (cl-copy-list lambda-list)))
+
+    (when (not (proper-list-p remaining-list))
+      (cl-shiftf dotted-rest-var
+                 (cdr (last remaining-list))
+                 nil))
+
+    (cl-flet ((missing-after (cdr) (or (null cdr)
+                                       (memq (car cdr) cl--pcase-lambda-list-constructs)))
+              (stop-processing () (setq processing-whole nil
+                                        processing-opts nil
+                                        processing-rest nil
+                                        processing-keys nil
+                                        processing-auxs nil)))
+      (cl-loop
+       for (first . rest) on lambda-list
+       do
+       (pcase first
+         ('&whole
+          (if (or (missing-after rest)
+                  whole-var pos-var opt-var
+                  rest-var key-var allow-other-keys aux-var)
+              (signal 'cl--pcase-lambda-list-bad-lambda-list (list lambda-list))
+            (stop-processing)
+            (setq processing-whole t)))
+
+         ('&optional
+          (if (or (missing-after rest)
+                  opt-var rest-var key-var allow-other-keys aux-var)
+              (signal 'cl--pcase-lambda-list-bad-lambda-list
+                      (list lambda-list))
+            (stop-processing)
+            (setq processing-opts t)))
+
+         ((or '&rest '&body)
+          (if (or (missing-after rest)
+                  rest-var key-var allow-other-keys aux-var
+                  dotted-rest-var)
+              (signal 'cl--pcase-lambda-list-bad-lambda-list
+                      (list lambda-list))
+            (stop-processing)
+            (setq processing-rest t)))
+
+         ('&key
+          (if (or (missing-after rest)
+                  key-var allow-other-keys aux-var
+                  dotted-rest-var)
+              (signal 'cl--pcase-lambda-list-bad-lambda-list
+                      (list lambda-list))
+            (stop-processing)
+            (setq processing-keys t)))
+
+         ('&allow-other-keys
+          (if (or (not processing-keys)
+                  allow-other-keys
+                  dotted-rest-var)
+              (signal 'cl--pcase-lambda-list-bad-lambda-list
+                      (list lambda-list))
+            (stop-processing)
+            (setq allow-other-keys t)))
+
+         ('&aux
+          (if (or (missing-after rest)
+                  aux-var
+                  dotted-rest-var)
+              (signal 'cl--pcase-lambda-list-bad-lambda-list
+                      (list lambda-list))
+            (stop-processing)
+            (setq processing-auxs t)))
+
+         ((guard processing-whole)
+          (setq whole-var first
+                processing-whole nil))
+
+         ((guard processing-rest)
+          (setq rest-var first
+                processing-rest nil))
+
+         ((guard processing-opts)
+          (push first opt-var))
+
+         ((guard processing-keys)
+          (push first key-var))
+
+         ((guard processing-auxs)
+          (push first aux-var))
+
+         ('&environment
+          (signal 'cl--pcase-lambda-list-bad-lambda-list
+                  (list lambda-list)))
+
+         (_
+          (if (or opt-var rest-var key-var aux-var
+                  allow-other-keys)
+              (signal 'cl--pcase-lambda-list-bad-lambda-list
+                      (list lambda-list))
+            (push first pos-var))))))
+
+    `((whole . ,whole-var)
+      (pos . ,(nreverse pos-var))
+      (opt . ,(nreverse opt-var))
+      (rest . ,(or dotted-rest-var rest-var))
+      (key . ,(nreverse key-var))
+      (allow-other-keys . ,allow-other-keys)
+      (aux . ,(nreverse aux-var)))))
+
+(defun cl--pcase-cl-lambda-positional-pattern (pos-vars opt-vars rest-var key-vars)
+  "Build a pattern for the positional, `&optional', and `&rest' variables.
+
+POS-VARS is the list of the positional variables.  OPT-VARS is the list of
+the optional variables.  REST-VAR is the `&rest' variable."
+  ;; A modified version of the back-quote pattern to better work with
+  ;; optional values.
+  (cond
+   (pos-vars `(and (pred consp)
+                   (app car-safe ,(car pos-vars))
+                   (app cdr-safe ,(cl--pcase-cl-lambda-positional-pattern
+                                   (cdr pos-vars) opt-vars
+                                   rest-var key-vars))))
+   (opt-vars (pcase-let (((or `(,var ,default ,supplied)
+                              `(,var ,default)
+                              `(,var)
+                              var)
+                          (car opt-vars)))
+               `(and (pred listp)
+                     (app car-safe (or (and (pred null)
+                                            ,@(when supplied `((let ,supplied nil)))
+                                            ,@(when default `((let ,var ,default))))
+                                       ,(if supplied
+                                            `(and (let ,supplied t)
+                                                  ,var)
+                                          var)))
+                     (app cdr-safe ,(cl--pcase-cl-lambda-positional-pattern
+                                     nil (cdr opt-vars)
+                                     rest-var key-vars)))))
+   (rest-var rest-var)
+   ;; `pcase' allows `(,a ,b) to match (1 2 3), so we need to make
+   ;; sure there aren't more values left.  However, if we are using
+   ;; `&key', then we allow more values.
+   (key-vars '_)
+   (t '(pred null))))
+
+;;;###autoload
+(defun cl--pcase-cl-lambda-plist-keys (list)
+  "Get every other element in LIST, to get the keys in a property list."
+  (cl-loop for key in list by #'cddr collect key))
+
+(defun cl--pcase-cl-lambda-&key-pattern (key-vars allow-other-keys plist-var)
+  "Build a `pcase' pattern for the `&key' variables.
+
+KEY-VARS are the forms of the key variables.  ALLOW-OTHER-KEYS is
+whether `&allow-other-keys' was used.  PLIST-VAR is the variable
+holding the property list."
+  (let* ((specified-keys nil)
+         (pat-list
+          (cl-loop
+           for bind in key-vars
+           append (pcase-let* (((or (or `((,key ,var) ,default ,supplied)
+                                        `((,key ,var) ,default)
+                                        `((,key ,var)))
+                                    (and (or `(,var ,default ,supplied)
+                                             `(,var ,default)
+                                             `(,var)
+                                             (and (pred symbolp)
+                                                  var))
+                                         ;; Strip a leading underscore, since it
+                                         ;; only means that this argument is
+                                         ;; unused, but shouldn't affect the
+                                         ;; key's name (bug#12367).
+                                         (let key (intern
+                                                   (format ":%s"
+                                                           (let ((name (symbol-name var)))
+                                                             (if (eq ?_ (aref name 0))
+                                                                 (substring name 1)
+                                                               name)))))))
+                                bind)
+                               (const-key (macroexp-const-p key))
+                               (used-key (if const-key
+                                             key
+                                           (gensym (format "plist-key-%s" var)))))
+                    (unless allow-other-keys
+                      (push key specified-keys))
+                    `(,@(unless (equal used-key key)
+                          `((let ,used-key ,key)))
+                      ,@(cond
+                         (supplied
+                          (let ((key-found (gensym "key-found")))
+                            `((let ,key-found (plist-member ,plist-var ,used-key
+                                                            #'equal))
+                              (or (and (guard ,key-found)
+                                       (let ,var (cadr ,key-found))
+                                       (let ,supplied t))
+                                  (and (let ,var ,default)
+                                       (let ,supplied nil))))))
+                         (default
+                          (let ((key-found (gensym "key-found")))
+                            `((let ,var
+                                (if-let ((,key-found (plist-member ,plist-var
+                                                                   ,used-key
+                                                                   #'equal)))
+                                    (cl-second ,key-found)
+                                  ,default)))))
+                         (t
+                          `((let ,var  (plist-get ,plist-var ,used-key #'equal))))))))))
+    `(and ,@(unless allow-other-keys
+              `((guard (or (null (cl-set-difference (cl--pcase-cl-lambda-plist-keys ,plist-var)
+                                                    (list ,@specified-keys)
+                                                    :test #'equal))
+                           (plist-get ,plist-var :allow-other-keys)))))
+          ,@pat-list)))
+
+(defun cl--pcase-cl-lambda-&aux-pattern (aux-vars)
+  "Build `pcase' pattern for `&aux' variables.
+
+AUX-VARS is the list of bindings."
+  `(and ,@(cl-loop for bind in aux-vars
+                   collect (pcase-let (((or `(,var ,val)
+                                            `(,var)
+                                            var)
+                                        bind))
+                             `(let ,var ,val)))))
+
+;;;###autoload
+(pcase-defmacro cl-lambda (lambda-list)
+  "Match a CL lambda list.  See the Info node `(cl)Argument Lists'.
+
+This pattern does not support `&environment'.
+
+`&key' will fail to match if there are more keys in the plist
+then specified, unless `&allow-other-keys' is given or unless the
+plist associates the key `:allow-other-keys' with a non-nil
+value.  Unlike `cl-destructuring-bind', this pattern does not
+signal an error if there are unmatched keys in the plist.
+
+Unlike the back-quote pattern, the pattern will fail to match if the
+non-optional part of LAMBDA-LIST is shorter than EXPVAL.
+
+For this `pcase' pattern, the variables in LAMBDA-LIST can
+themselves be `pcase' patterns, instead of just symbols as in a
+normal CL lambda list.  However, lambda-list constructs like
+`&optional', `&key', and `&aux' use sub-lists to specify default
+values and other features.  For example,
+
+    (cl-lambda (&optional (opt1 default1 opt1-supplied)))
+
+Therefore, to avoid ambiguity, the use of sub-patterns can only
+be done within the sub-list for those constructs.  For example,
+
+    (cl-lambda (&optional ((and opt1 (guard (listp opt1)))
+                           nil)))
+
+For similar reasons, the cdr of a dotted list (as opposed to the
+element following `&rest') for the remainder of a list cannot be
+a sub-pattern."
+  (let* ((groups (cl--pcase-cl-lambda-var-groups lambda-list))
+         (whole-var (alist-get 'whole groups))
+         (pos-vars (alist-get 'pos groups))
+         (opt-vars (alist-get 'opt groups))
+         (rest-var (alist-get 'rest groups))
+         (key-vars (alist-get 'key groups))
+         (allow-other-keys (alist-get 'allow-other-keys groups))
+         (aux-vars (alist-get 'aux groups)))
+    (remq nil
+          `(and (pred listp)
+                ,(when whole-var
+                   whole-var)
+                ,(when (or pos-vars opt-vars rest-var)
+                   (cl--pcase-cl-lambda-positional-pattern
+                    pos-vars opt-vars
+                    rest-var key-vars))
+                ,@(when key-vars
+                    (let ((plist-var (gensym "maybe-plist")))
+                      (cond
+                       (rest-var
+                        (list (cl--pcase-cl-lambda-&key-pattern
+                               key-vars allow-other-keys
+                               rest-var)))
+                       ((or pos-vars opt-vars)
+                        (if whole-var
+                            `((let ,plist-var (nthcdr ,(+ (length pos-vars)
+                                                          (length opt-vars))
+                                                      ,whole-var))
+                              ,(cl--pcase-cl-lambda-&key-pattern
+                                key-vars allow-other-keys
+                                plist-var))
+                          `((app (nthcdr ,(+ (length pos-vars)
+                                             (length opt-vars)))
+                                 ,plist-var)
+                            ,(cl--pcase-cl-lambda-&key-pattern
+                              key-vars allow-other-keys
+                              plist-var))))
+                       (t
+                        `((and ,plist-var
+                               ,(cl--pcase-cl-lambda-&key-pattern
+                                 key-vars allow-other-keys
+                                 plist-var)))))))
+                ,(when aux-vars
+                   (cl--pcase-cl-lambda-&aux-pattern aux-vars))))))
+
 ;; Local variables:
 ;; generated-autoload-file: "cl-loaddefs.el"
 ;; End:
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index 799e8d36647..9c32259e953 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -160,4 +160,519 @@ pcase-tests-setq
   (should-error (pcase-setq a)
                 :type '(wrong-number-of-arguments)))
 
+;;; Tests for the `cl-lambda' `pcase' pattern.
+
+(ert-deftest pcase-tests-cl-lambda-&whole-should-error ()
+  "`&whole' must come first if given, and must be followed by a patter."
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&whole))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (a b &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&rest a &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&key a &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&aux (a 1) &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&optional (a 1) &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&whole whole1 &whole whole2))
+                   (list whole1 whole2)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list))
+
+(ert-deftest pcase-tests-cl-lambda-&whole ()
+  "`&whole' can be a `pcase' pattern."
+  (should (equal (list (list 1 2 3) 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-lambda (&whole whole a b c))
+                    (list whole a b c)))))
+
+  (should (equal (list 1 2 3 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-lambda (&whole `(,a0 ,b0 ,c0) a b c))
+                    (list a0 b0 c0 a b c))))))
+
+(ert-deftest pcase-tests-cl-lambda-pos ()
+  "Positional variables must match the length of EXPVAL."
+  (should (equal (list 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-lambda (a b c))
+                    (list a b c)))))
+
+  (should (equal nil
+                 (pcase (list (list 1))
+                   ((cl-lambda (a b))
+                    (list a b)))))
+
+  (should (equal nil
+                 (pcase (list (list 1 2 3))
+                   ((cl-lambda (a b))
+                    (list a b))))))
+
+(ert-deftest pcase-tests-cl-lambda-pos-sub-patterns ()
+  (should (equal (list 1 2 3 4)
+                 (pcase (list 1 2 (list 3 4))
+                   ((cl-lambda (a b (cl-lambda (c d))))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2)
+                 (pcase (list (list 1 2))
+                   ((cl-lambda (`(,a ,b)))
+                    (list a b))))))
+
+(ert-deftest pcase-tests-cl-lambda-&optional-should-error ()
+  "`&optional' cannot be used after `&optional', `&rest', `&key', and `&aux'."
+  (should-error (equal (list 1 2 3)
+                       (pcase (list 1 2 3)
+                         ((cl-lambda (&rest a &optional b c))
+                          (list a b c))))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&body a &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&key a &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&allow-other-keys &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&aux (a 1) &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&optional a &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list))
+
+(ert-deftest pcase-tests-cl-lambda-&optional ()
+  (should (equal (list 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-lambda (a b &optional c))
+                    (list a b c)))))
+
+  (should (equal (list 1 2 nil)
+                 (pcase (list 1 2)
+                   ((cl-lambda (a b &optional c))
+                    (list a b c)))))
+
+  (should (equal (list 1 2 13)
+                 (pcase (list 1 2)
+                   ((cl-lambda (a b &optional (c 13)))
+                    (list a b c)))))
+
+  (should (equal (list 1 2 13 nil)
+                 (pcase (list 1 2)
+                   ((cl-lambda (a b &optional (c 13 c-supplied)))
+                    (list a b c c-supplied)))))
+
+  (should (equal (list 1 2 3 t)
+                 (pcase (list 1 2 3)
+                   ((cl-lambda (a b &optional (c 13 c-supplied)))
+                    (list a b c c-supplied))))))
+
+(ert-deftest pcase-tests-cl-lambda-&optional-sub-patterns ()
+  "Test using sub-patterns in `cl-lambda' pattern.
+Sub-patterns must be contained within a sub-list, since a sub-list
+also provides a default value."
+  (should-error (pcase (list 1 2 (list 3 4))
+                  ((cl-lambda (a b &optional `(,c ,d)))
+                   (list a b c d))))
+
+  (should (equal (list 1 2 33)
+                 (pcase (list 1 2)
+                   ((cl-lambda (a b &optional ((and opt1
+                                                    (guard (numberp opt1)))
+                                               33)))
+                    (list a b opt1)))))
+
+  (should (equal nil
+                 (pcase (list 1 2 'not-num)
+                   ((cl-lambda (a b &optional ((and opt1
+                                                    (guard (numberp opt1)))
+                                               33)))
+                    (list a b opt1)))))
+
+  (should (equal nil
+                 (pcase (list 1 2 nil)
+                   ((cl-lambda (a b &optional ((and opt1
+                                                    (guard (numberp opt1)))
+                                               'not-num)))
+                    (list a b opt1)))))
+
+  (should (equal (list 1 2 3 4)
+                 (pcase (list 1 2 (list 3 4))
+                   ((cl-lambda (a b &optional (`(,c ,d))))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2 nil nil)
+                 (pcase (list 1 2)
+                   ((cl-lambda (a b &optional (`(,c ,d))))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2 13 14)
+                 (pcase (list 1 2)
+                   ((cl-lambda (a b &optional (`(,c ,d) (list 13 14))))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2 13 14)
+                 (pcase (list 1 2)
+                   ((cl-lambda ( a b
+                                 &optional ((cl-lambda (c &optional (d 14)))
+                                            (list 13))))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2 13 14 nil)
+                 (pcase (list 1 2)
+                   ((cl-lambda (a b &optional (`(,c ,d) (list 13 14) cd-supplied)))
+                    (list a b c d cd-supplied)))))
+
+  (should (equal (list 1 2 13 14 nil t nil)
+                 (pcase (list 1 2)
+                   ((cl-lambda ( a b
+                                 &optional
+                                 ((cl-lambda (&optional (c 27 c-sub-sup)
+                                                        (d 14 d-sub-sup)))
+                                  (list 13)
+                                  cd-supplied)))
+                    (list a b c d cd-supplied c-sub-sup d-sub-sup))))))
+
+(ert-deftest pcase-tests-cl-lambda-&rest-should-error ()
+  "`&rest' (`&body', `.') cannot be used after `&rest', `&body', `&key',and `&aux'."
+  (should-error (equal (list 1 2 3)
+                       (pcase (list 1 2 3)
+                         ((cl-lambda (&rest a &rest b))
+                          (list a b c))))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (equal (list 1 2 3)
+                       (pcase (list 1 2 3)
+                         ((cl-lambda (&body a &body b))
+                          (list a b c))))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (equal (list 1 2 3)
+                       (pcase (list 1 2 3)
+                         ((cl-lambda (&body a . b))
+                          (list a b c))))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&body a &rest b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&rest a &body b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&key a &rest b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&key a &body b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&key a . b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&allow-other-keys &rest b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&allow-other-keys &body b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&allow-other-keys . b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&aux (a 1) &rest b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&aux (a 1) &body b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-lambda (&aux (a 1) . b))
+                   (list a b c)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list))
+
+(ert-deftest pcase-tests-cl-lambda-&rest-nonlist-cdr ()
+  (should (equal (list 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-lambda (a &rest b))
+                    (list a b)))))
+
+  (should (equal (list 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-lambda (a &body b))
+                    (list a b)))))
+
+  (should (equal (list 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-lambda (a . b))
+                    (list a b))))))
+
+(ert-deftest pcase-tests-cl-lambda-&rest-with-&whole ()
+  (should (equal (list (cons 1 2) 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-lambda (&whole whole a &rest b))
+                    (list whole a b)))))
+
+  (should (equal (list (cons 1 2) 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-lambda (&whole whole a &body b))
+                    (list whole a b)))))
+
+  (should (equal (list (cons 1 2) 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-lambda (&whole whole a . b))
+                    (list whole a b))))))
+
+(ert-deftest pcase-tests-cl-lambda-&rest-only ()
+  "Using only `&rest' should work like `&whole'."
+  (should (equal (list (list 1 2))
+                 (pcase (list 1 2)
+                   ((cl-lambda (&rest a))
+                    (list a)))))
+
+  (should (equal (list (cons 1 2))
+                 (pcase (cons 1 2)
+                   ((cl-lambda (&body a))
+                    (list a))))))
+
+(ert-deftest pcase-tests-cl-lambda-&rest-after-&optional ()
+  (should (equal (list 1 2 3 (list 4 5))
+                 (pcase (list 1 2 3 4 5)
+                   ((cl-lambda (&optional a b c &rest d))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2 3 (list 4 5))
+                 (pcase (list 1 2 3 4 5)
+                   ((cl-lambda (&optional a b c &body d))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2 3 (list 4 5))
+                 (pcase (list 1 2 3 4 5)
+                   ((cl-lambda (&optional a b c . d))
+                    (list a b c d))))))
+
+(ert-deftest pcase-tests-cl-lambda-&rest-sub-patterns ()
+  ;; We can't do (a . `(,b . ,c)), so we don't test that.
+  (should (equal (list 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-lambda (a &rest (cl-lambda (b c))))
+                    (list a b c)))))
+
+  (should (equal (list 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-lambda (a &body `(,b ,c)))
+                    (list a b c))))))
+
+(ert-deftest pcase-tests-cl-lambda-&key-should-error ()
+  "`&key' cannot be used after `&key', `&allow-other-keys', and `&aux'."
+  (should-error (pcase (list :a 1 :b 2)
+                  ((cl-lambda (&key a &key b))
+                   (list a b)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list :a 1 :b 2)
+                  ((cl-lambda (&aux (a 1) &key b))
+                   (list a b)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list)
+
+  (should-error (pcase (list :a 1 :b 2)
+                  ((cl-lambda (&allow-other-keys &key b))
+                   (list a b)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list))
+
+(ert-deftest pcase-tests-cl-lambda-&key-exact ()
+  "`&key' doesn't match unspecified keys unless `&allow-other-keys' or `:allow-other-keys' is given."
+  (should (equal (list 1 2)
+                 (pcase (list :a 1 :b 2)
+                   ((cl-lambda (&key a b))
+                    (list a b)))))
+
+  (should (equal nil
+                 (pcase (list :a 1 :b 2 :c 3)
+                   ((cl-lambda (&key a b))
+                    (list a b)))))
+
+  (should (equal (list 1 2 nil)
+                 (pcase (list :a 1 :b 2)
+                   ((cl-lambda (&key a b c))
+                    (list a b c))))))
+
+(ert-deftest pcase-tests-cl-lambda-&key-permissive ()
+  "`&key' doesn't match unspecified keys unless `&allow-other-keys' or `:allow-other-keys' is given."
+  (should (equal (list 1 2)
+                 (pcase (list :a 1 :b 2 :c 3)
+                   ((cl-lambda (&key a b &allow-other-keys))
+                    (list a b)))))
+
+  (should (equal (list 1 2)
+                 (pcase (list :a 1 :b 2 :c 3 :allow-other-keys t)
+                   ((cl-lambda (&key a b))
+                    (list a b))))))
+
+(ert-deftest pcase-tests-cl-lambda-&key-not-first ()
+  "The plist should be after positional values and equal to `&rest'."
+  (should (equal (list 1 2 3 11 22)
+                 (pcase (list 1 2 3 :k1 11 :k2 22)
+                   ((cl-lambda (a b c &key k1 k2))
+                    (list a b c k1 k2)))))
+
+  (should (equal (list 1 2 3 (list :k1 11 :k2 22) 11 22)
+                 (pcase (list 1 2 3 :k1 11 :k2 22)
+                   ((cl-lambda (a b c &rest r1 &key k1 k2))
+                    (list a b c r1 k1 k2))))))
+
+(ert-deftest pcase-tests-cl-lambda-&key-full-form ()
+  (should (equal (list 1 2)
+                 (pcase (list :a 1 :b 2)
+                   ((cl-lambda (&key a (b 13)))
+                    (list a b)))))
+
+  (should (equal (list 1 13)
+                 (pcase (list :a 1)
+                   ((cl-lambda (&key a (b 13)))
+                    (list a b)))))
+
+  (should (equal (list 1 13 nil)
+                 (pcase (list :a 1)
+                   ((cl-lambda (&key a (b 13 b-supplied)))
+                    (list a b b-supplied)))))
+
+  (should (equal (list 1 2 t)
+                 (pcase (list :a 1 :b 2)
+                   ((cl-lambda (&key a (b 13 b-supplied)))
+                    (list a b b-supplied)))))
+
+  (should (equal (list 1 2 t)
+                 (pcase (list :a 1 :bat 2)
+                   ((cl-lambda (&key a ((:bat b) 13 b-supplied)))
+                    (list a b b-supplied)))))
+
+  (should (equal (list 1 2 t)
+                 (let ((key :bat))
+                   (pcase (list :a 1 :bat 2)
+                     ((cl-lambda (&key a ((key b) 13 b-supplied)))
+                      (list a b b-supplied)))))))
+
+(ert-deftest pcase-tests-cl-lambda-&key-sub-patterns ()
+  (should (equal '(1 2 (:c 77 :e should-ignore) nil 77 t 99 nil)
+                 (pcase '(:ab (1 2))
+                   ((cl-lambda (&key
+                                ((:ab `(,a ,b)))
+                                ((:cd (cl-lambda ( &whole cd
+                                                   &key
+                                                   (c 88 c-supp)
+                                                   ((:d d) 99 d-supp)
+                                                   &allow-other-keys)))
+                                 (list :c 77 :e 'should-ignore)
+                                 cd-supp)))
+                    (list a b cd cd-supp c c-supp d d-supp)))))
+
+  (should (equal '( 1 2 (:c 77 :e should-ignore :allow-other-keys t) nil
+                    77 t 99 nil)
+                 (pcase '(:ab (1 2))
+                   ((cl-lambda (&key
+                                ((:ab `(,a ,b)))
+                                ((:cd (cl-lambda ( &whole cd
+                                                   &key
+                                                   (c 88 c-supp)
+                                                   ((:d d) 99 d-supp))))
+                                 (list :c 77 :e 'should-ignore
+                                       :allow-other-keys t)
+                                 cd-supp)))
+                    (list a b cd cd-supp c c-supp d d-supp)))))
+
+  (should (equal nil
+                 (pcase '(:ab (1 2))
+                   ((cl-lambda (&key
+                                ((:ab `(,a ,b)))
+                                ((:cd (cl-lambda ( &whole cd
+                                                   &key
+                                                   (c 88 c-supp)
+                                                   ((:d d) 99 d-supp))))
+                                 (list :c 77 :e 'should-fail)
+                                 cd-supp)))
+                    (list a b cd cd-supp c c-supp d d-supp))))))
+
+(ert-deftest pcase-tests-cl-lambda-&aux-should-error ()
+  "`&aux' cannot be used after `&aux'."
+  (should-error (pcase nil
+                  ((cl-lambda (&aux a &aux b))
+                   (list a b)))
+                :type 'cl--pcase-lambda-list-bad-lambda-list))
+
+(ert-deftest pcase-tests-cl-lambda-&aux ()
+  (should (equal (list 1 2 nil nil)
+                 (pcase nil
+                   ((cl-lambda (&aux (a 1) (b 2) (c) d))
+                    (list a b c d)))))
+
+  (should (equal (list 0 1 2 nil nil)
+                 (pcase (list 0)
+                   ((cl-lambda (z0 &aux (a 1) (b 2) (c) d))
+                    (list z0 a b c d))))))
+
+(ert-deftest pcase-tests-cl-lambda-&aux-sub-patterns ()
+  (should (equal (list 1 2)
+                 (pcase nil
+                   ((cl-lambda (&aux (`(,a ,b) (list 1 2))))
+                    (list a b ))))))
+
+(ert-deftest pcase-tests-cl-lambda-all ()
+  (should (equal '(1 2 3 4 5 (:k1 111 :k2 222) 111 222 333 444)
+                 (pcase (list 1 2 3 4 5 :k1 111 :k2 222)
+                   ((cl-lambda ( a b c
+                                 &optional d e
+                                 &rest r
+                                 &key k1 k2
+                                 &aux (x1 333) (x2 444)))
+                    (list a b c d e r k1 k2 x1 x2))))))
+
 ;;; pcase-tests.el ends here.
-- 
2.34.1