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

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

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

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

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 7c207d372fc..0e10011a506 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3825,6 +3825,349 @@ 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'.
+
+(define-error 'cl--pcase-cl-arglist-invalid-arg-list
+              "Invalid argument list used in `cl-arglist' pattern.")
+
+(defun cl--pcase-cl-arglist-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--lambda-list-keywords)))
+              (stop-processing () (setq processing-whole nil
+                                        processing-opts nil
+                                        processing-rest nil
+                                        processing-keys nil
+                                        processing-auxs nil)))
+
+      (cl-loop
+       for (first . rest) on remaining-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-cl-arglist-invalid-arg-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-cl-arglist-invalid-arg-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-cl-arglist-invalid-arg-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-cl-arglist-invalid-arg-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-cl-arglist-invalid-arg-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-cl-arglist-invalid-arg-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-cl-arglist-invalid-arg-list
+                  (list lambda-list)))
+
+         (_
+          (if (or opt-var rest-var key-var aux-var
+                  allow-other-keys)
+              (signal 'cl--pcase-cl-arglist-invalid-arg-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-arglist-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-arglist-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-arglist-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))))
+
+(defun cl--pcase-cl-arglist-&key-pattern (key-vars allow-other-keys)
+  "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."
+  ;; If we aren't checking whether all keys in EXPVAL were given,
+  ;; then we can use simpler patterns since we don't need to store the
+  ;; value of the key.
+  (cl-flet ((get-var-data (var-form)
+              (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)))))))
+                           var-form))
+                (list key var default supplied))))
+    (if allow-other-keys
+        `(and ,@(mapcar (lambda (var-form)
+                          (pcase-let ((`(,key ,var ,default ,supplied) (get-var-data var-form))
+                                      (key-found (gensym "key-found"))
+                                      (plist (gensym "plist")))
+                            (cond (supplied
+                                   `(app (lambda (,plist)
+                                           (let ((,key-found (plist-member ,plist ,key)))
+                                             (if ,key-found
+                                                 (cons t (cadr ,plist))
+                                               (cons nil ,default))))
+                                         (,'\` ((,'\, ,supplied) . (,'\, ,var)))))
+                                  (default
+                                   `(app (lambda (,plist)
+                                           (let ((,key-found (plist-member ,plist ,key)))
+                                             (if ,key-found
+                                                 (cadr ,plist)
+                                               ,default)))
+                                         ,var))
+                                  (t
+                                   `(app (pcase--flip plist-get ,key)
+                                         ,var)))))
+                        key-vars))
+      ;; If we are checking whether there are no other keys in EXPVAL,
+      ;; then we use a single function for extracting the associated
+      ;; values and performing the check, whose output we match against
+      ;; a list of patterns.
+      (let ((res (gensym "res"))
+            (keys (gensym "keys"))
+            (plist (gensym "plist"))
+            (pats nil))
+        `(app (lambda (,plist)
+                (let ((,res nil)
+                      (,keys nil))
+                  ,@(cl-loop
+                     for (key var default supplied) in (mapcar #'get-var-data key-vars)
+                     collect (macroexp-let2* ((keyval key))
+                                 nil
+                               `(progn
+                                  (push ,keyval ,keys)
+                                  ,(cond
+                                    (supplied
+                                     (push supplied pats)
+                                     (push var pats)
+                                     (cl-once-only ((key-found `(plist-member ,plist ,keyval)))
+                                       `(if ,key-found
+                                            (progn
+                                              (push t ,res)
+                                              (push (cadr ,key-found) ,res))
+                                          (push nil ,res)
+                                          (push ,default ,res))))
+                                    (default
+                                     (push var pats)
+                                     (cl-once-only ((key-found `(plist-member ,plist ,keyval)))
+                                       `(if ,key-found
+                                            (push (cadr ,key-found) ,res)
+                                          (push ,default ,res))))
+                                    (t
+                                     (push var pats)
+                                     `(push (plist-get ,plist ,keyval)
+                                            ,res))))))
+                  (push (or (plist-get ,plist :allow-other-keys)
+                            (cl-loop for (key _val) on ,plist by #'cddr
+                                     always (memq key ,keys)))
+                        ,res)
+                  ;; Reverse in case a latter pattern use a variable
+                  ;; from an earlier pattern.
+                  (nreverse ,res)))
+              (,'\` ,(cl-loop for pat in (reverse (cons '(pred (not null))
+                                                        pats))
+                              collect `(,'\, ,pat))))))))
+
+(defun cl--pcase-cl-arglist-&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-arglist (arglist)
+  "Match a CL argument list, as in `cl-defun' and `cl-defmacro'.
+
+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 ARGLIST is shorter than EXPVAL.
+
+For this `pcase' pattern, the variables in ARGLIST can
+themselves be `pcase' patterns, instead of just symbols as in a
+normal CL lambda list.  However, argument-list constructs like
+`&optional', `&key', and `&aux' use sub-lists to specify default
+values and other features.  For example,
+
+    (cl-arglist (&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-arglist (&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-arglist-var-groups arglist))
+         (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-arglist-positional-pattern
+                    pos-vars opt-vars
+                    rest-var key-vars))
+                ,(when key-vars
+                   (cond
+                    (rest-var `(app (lambda (_) ,rest-var)
+                                    ,(cl--pcase-cl-arglist-&key-pattern
+                                      key-vars allow-other-keys)))
+                    ((or pos-vars opt-vars)
+                     `(app (nthcdr ,(+ (length pos-vars)
+                                       (length opt-vars)))
+                           ,(cl--pcase-cl-arglist-&key-pattern
+                             key-vars allow-other-keys)))
+                    (t (cl--pcase-cl-arglist-&key-pattern
+                        key-vars allow-other-keys))))
+                ,(when aux-vars
+                   (cl--pcase-cl-arglist-&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..108e4b96d04 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-arglist' `pcase' pattern.
+
+(ert-deftest pcase-tests-cl-arglist-&whole-should-error ()
+  "`&whole' must come first if given, and must be followed by a patter."
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&whole))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (a b &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&rest a &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&key a &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&aux (a 1) &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&optional (a 1) &whole c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&whole whole1 &whole whole2))
+                   (list whole1 whole2)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&whole ()
+  "`&whole' can be a `pcase' pattern."
+  (should (equal (list (list 1 2 3) 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-arglist (&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-arglist (&whole `(,a0 ,b0 ,c0) a b c))
+                    (list a0 b0 c0 a b c))))))
+
+(ert-deftest pcase-tests-cl-arglist-pos ()
+  "Positional variables must match the length of EXPVAL."
+  (should (equal (list 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-arglist (a b c))
+                    (list a b c)))))
+
+  (should (equal nil
+                 (pcase (list (list 1))
+                   ((cl-arglist (a b))
+                    (list a b)))))
+
+  (should (equal nil
+                 (pcase (list (list 1 2 3))
+                   ((cl-arglist (a b))
+                    (list a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-pos-sub-patterns ()
+  (should (equal (list 1 2 3 4)
+                 (pcase (list 1 2 (list 3 4))
+                   ((cl-arglist (a b (cl-arglist (c d))))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2)
+                 (pcase (list (list 1 2))
+                   ((cl-arglist (`(,a ,b)))
+                    (list a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-&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-arglist (&rest a &optional b c))
+                          (list a b c))))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&body a &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&key a &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&allow-other-keys &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&aux (a 1) &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&optional a &optional b c))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&optional ()
+  (should (equal (list 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-arglist (a b &optional c))
+                    (list a b c)))))
+
+  (should (equal (list 1 2 nil)
+                 (pcase (list 1 2)
+                   ((cl-arglist (a b &optional c))
+                    (list a b c)))))
+
+  (should (equal (list 1 2 13)
+                 (pcase (list 1 2)
+                   ((cl-arglist (a b &optional (c 13)))
+                    (list a b c)))))
+
+  (should (equal (list 1 2 13 nil)
+                 (pcase (list 1 2)
+                   ((cl-arglist (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-arglist (a b &optional (c 13 c-supplied)))
+                    (list a b c c-supplied))))))
+
+(ert-deftest pcase-tests-cl-arglist-&optional-sub-patterns ()
+  "Test using sub-patterns in `cl-arglist' 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-arglist (a b &optional `(,c ,d)))
+                   (list a b c d))))
+
+  (should (equal (list 1 2 33)
+                 (pcase (list 1 2)
+                   ((cl-arglist (a b &optional ((and opt1
+                                                    (guard (numberp opt1)))
+                                               33)))
+                    (list a b opt1)))))
+
+  (should (equal nil
+                 (pcase (list 1 2 'not-num)
+                   ((cl-arglist (a b &optional ((and opt1
+                                                    (guard (numberp opt1)))
+                                               33)))
+                    (list a b opt1)))))
+
+  (should (equal nil
+                 (pcase (list 1 2 nil)
+                   ((cl-arglist (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-arglist (a b &optional (`(,c ,d))))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2 nil nil)
+                 (pcase (list 1 2)
+                   ((cl-arglist (a b &optional (`(,c ,d))))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2 13 14)
+                 (pcase (list 1 2)
+                   ((cl-arglist (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-arglist ( a b
+                                 &optional ((cl-arglist (c &optional (d 14)))
+                                            (list 13))))
+                    (list a b c d)))))
+
+  (should (equal (list 1 2 13 14 nil)
+                 (pcase (list 1 2)
+                   ((cl-arglist (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-arglist ( a b
+                                 &optional
+                                 ((cl-arglist (&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-arglist-&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-arglist (&rest a &rest b))
+                          (list a b c))))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (equal (list 1 2 3)
+                       (pcase (list 1 2 3)
+                         ((cl-arglist (&body a &body b))
+                          (list a b c))))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (equal (list 1 2 3)
+                       (pcase (list 1 2 3)
+                         ((cl-arglist (&body a . b))
+                          (list a b c))))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&body a &rest b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&rest a &body b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&key a &rest b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&key a &body b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&key a . b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&allow-other-keys &rest b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&allow-other-keys &body b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&allow-other-keys . b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&aux (a 1) &rest b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&aux (a 1) &body b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list 1 2 3)
+                  ((cl-arglist (&aux (a 1) . b))
+                   (list a b c)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-nonlist-cdr ()
+  (should (equal (list 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-arglist (a &rest b))
+                    (list a b)))))
+
+  (should (equal (list 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-arglist (a &body b))
+                    (list a b)))))
+
+  (should (equal (list 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-arglist (a . b))
+                    (list a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-with-&whole ()
+  (should (equal (list (cons 1 2) 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-arglist (&whole whole a &rest b))
+                    (list whole a b)))))
+
+  (should (equal (list (cons 1 2) 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-arglist (&whole whole a &body b))
+                    (list whole a b)))))
+
+  (should (equal (list (cons 1 2) 1 2)
+                 (pcase (cons 1 2)
+                   ((cl-arglist (&whole whole a . b))
+                    (list whole a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-only ()
+  "Using only `&rest' should work like `&whole'."
+  (should (equal (list (list 1 2))
+                 (pcase (list 1 2)
+                   ((cl-arglist (&rest a))
+                    (list a)))))
+
+  (should (equal (list (cons 1 2))
+                 (pcase (cons 1 2)
+                   ((cl-arglist (&body a))
+                    (list a))))))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-after-&optional ()
+  (should (equal (list 1 2 3 (list 4 5))
+                 (pcase (list 1 2 3 4 5)
+                   ((cl-arglist (&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-arglist (&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-arglist (&optional a b c . d))
+                    (list a b c d))))))
+
+(ert-deftest pcase-tests-cl-arglist-&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-arglist (a &rest (cl-arglist (b c))))
+                    (list a b c)))))
+
+  (should (equal (list 1 2 3)
+                 (pcase (list 1 2 3)
+                   ((cl-arglist (a &body `(,b ,c)))
+                    (list a b c))))))
+
+(ert-deftest pcase-tests-cl-arglist-&key-should-error ()
+  "`&key' cannot be used after `&key', `&allow-other-keys', and `&aux'."
+  (should-error (pcase (list :a 1 :b 2)
+                  ((cl-arglist (&key a &key b))
+                   (list a b)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list :a 1 :b 2)
+                  ((cl-arglist (&aux (a 1) &key b))
+                   (list a b)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+  (should-error (pcase (list :a 1 :b 2)
+                  ((cl-arglist (&allow-other-keys &key b))
+                   (list a b)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&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-arglist (&key a b))
+                    (list a b)))))
+
+  (should (equal nil
+                 (pcase (list :a 1 :b 2 :c 3)
+                   ((cl-arglist (&key a b))
+                    (list a b)))))
+
+  (should (equal (list 1 2 nil)
+                 (pcase (list :a 1 :b 2)
+                   ((cl-arglist (&key a b c))
+                    (list a b c))))))
+
+(ert-deftest pcase-tests-cl-arglist-&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-arglist (&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-arglist (&key a b))
+                    (list a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-&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-arglist (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-arglist (a b c &rest r1 &key k1 k2))
+                    (list a b c r1 k1 k2))))))
+
+(ert-deftest pcase-tests-cl-arglist-&key-full-form ()
+  (should (equal (list 1 2)
+                 (pcase (list :a 1 :b 2)
+                   ((cl-arglist (&key a (b 13)))
+                    (list a b)))))
+
+  (should (equal (list 1 13)
+                 (pcase (list :a 1)
+                   ((cl-arglist (&key a (b 13)))
+                    (list a b)))))
+
+  (should (equal (list 1 13 nil)
+                 (pcase (list :a 1)
+                   ((cl-arglist (&key a (b 13 b-supplied)))
+                    (list a b b-supplied)))))
+
+  (should (equal (list 1 2 t)
+                 (pcase (list :a 1 :b 2)
+                   ((cl-arglist (&key a (b 13 b-supplied)))
+                    (list a b b-supplied)))))
+
+  (should (equal (list 1 2 t)
+                 (pcase (list :a 1 :bat 2)
+                   ((cl-arglist (&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-arglist (&key a ((key b) 13 b-supplied)))
+                      (list a b b-supplied)))))))
+
+(ert-deftest pcase-tests-cl-arglist-&key-sub-patterns ()
+  (should (equal '(1 2 (:c 77 :e should-ignore) nil 77 t 99 nil)
+                 (pcase '(:ab (1 2))
+                   ((cl-arglist (&key
+                                 ((:ab `(,a ,b)))
+                                 ((:cd (cl-arglist ( &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-arglist (&key
+                                 ((:ab `(,a ,b)))
+                                 ((:cd (cl-arglist ( &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-arglist (&key
+                                 ((:ab `(,a ,b)))
+                                 ((:cd (cl-arglist ( &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-arglist-&aux-should-error ()
+  "`&aux' cannot be used after `&aux'."
+  (should-error (pcase nil
+                  ((cl-arglist (&aux a &aux b))
+                   (list a b)))
+                :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&aux ()
+  (should (equal (list 1 2 nil nil)
+                 (pcase nil
+                   ((cl-arglist (&aux (a 1) (b 2) (c) d))
+                    (list a b c d)))))
+
+  (should (equal (list 0 1 2 nil nil)
+                 (pcase (list 0)
+                   ((cl-arglist (z0 &aux (a 1) (b 2) (c) d))
+                    (list z0 a b c d))))))
+
+(ert-deftest pcase-tests-cl-arglist-&aux-sub-patterns ()
+  (should (equal (list 1 2)
+                 (pcase nil
+                   ((cl-arglist (&aux (`(,a ,b) (list 1 2))))
+                    (list a b ))))))
+
+(ert-deftest pcase-tests-cl-arglist-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-arglist ( 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