cond*: Add support for Pcase patterns

* lisp/emacs-lisp/cond-star.el (cond*): Adjust docstring.
(match*): Prefer `_VAR` syntax.
(cond*-convert-condition): Add support for `pcase*`.
* doc/lispref/control.texi (cond* Macro): Document `pcase*`.
* test/lisp/emacs-lisp/cond-star-tests.el: New file.

4 files changed, 109 insertions, 24 deletions

diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index b996a372e28..6ad8a779d17 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -1452,12 +1452,15 @@ of the clause.  As a condition, it counts as true if the first binding's
 value is non-@code{nil}.
 
 @findex match*
+@findex pcase*
 @code{(match* @var{pattern} @var{datum})} means to match @var{datum}
 against the specified @var{pattern}.  The condition counts as true if
 @var{pattern} matches @var{datum}.  The pattern can specify variables to
 bind to the parts of @var{datum} that they match.
+@code{(pcase* @var{pattern} @var{datum})} works in the same way except it
+uses the Pcase syntax for @var{pattern}.
 
-Both @code{bind*} and @code{match*} normally bind their bindings over
+@code{bind*}, @code{match*}, and @code{pcase*} normally bind their bindings over
 the execution of the whole containing clause.  However, if the clause is
 written to specify ``non-exit'', the clause's bindings cover the whole
 rest of the @code{cond*}.
@@ -1475,6 +1478,10 @@ next clause (if any).  The bindings made in @var{condition} for the
 @var{body} of the non-exit clause are passed along to the rest of the
 clauses in this @code{cond*} construct.
 
+Note: @code{pcase*} does not support @code{:non-exit}, and when used in
+a non-exit clause, it follows the semantics of @code{pcase-let}, see
+@ref{Destructuring with pcase Patterns}.
+
 @subheading Matching clauses
 
 A matching clause looks like @code{(match* @var{pattern} @var{datum})}.
@@ -1482,7 +1489,7 @@ It evaluates the expression @var{datum} and matches the pattern
 @var{pattern} (which is not evaluated) against it.
 
 @var{pattern} allows these kinds of patterns, and those that are lists
-often include other patters within them:
+often include other patterns within them:
 
 @table @code
 @item _
diff --git a/etc/NEWS b/etc/NEWS
index 18b6678dce9..a00536607da 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -741,12 +741,14 @@ text "covered" by the overlay.
 
 +++
 ** New macro 'cond*'.
-The new macro 'cond*' is an alternative to 'pcase'.  Like 'pcase', it
-can be used to define several clauses, each one with its own condition;
-the first clause that matches will cause its body to be evaluated.
-'cond*' uses syntax that is different from that of 'pcase', which some
-users might find less cryptic.  See the Info node "(elisp) cond* Macro"
-for details.
+The new macro 'cond*' is an alternative to 'cond' and 'pcase'.
+Like them, it can be used to define several clauses, each one with its
+own condition; the first clause that matches will cause its body to be
+evaluated.
+'cond*' can use Pcase's pattern matching syntax and also provides
+another pattern matching syntax that is different from that of 'pcase',
+which some users might find less cryptic.
+See the Info node "(elisp) cond* Macro" for details.
 
 ---
 ** New function 'shell-command-do-open'.
diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el
index 9495ad96a6c..4cd8b9fd0fc 100644
--- a/lisp/emacs-lisp/cond-star.el
+++ b/lisp/emacs-lisp/cond-star.el
@@ -31,10 +31,10 @@
 ;; and, or, if, progn, let, let*, setq.
 ;; For regexp matching only, it can call string-match and match-string.
 
-;;; ??? If a clause starts with a keyword,
-;;; should the element after the keyword be treated in the usual way
-;;; as a pattern?  Currently `cond*-non-exit-clause-substance' explicitly
-;;; prevents that by adding t at the front of its value.
+;; ??? If a clause starts with a keyword,
+;; should the element after the keyword be treated in the usual way
+;; as a pattern?  Currently `cond*-non-exit-clause-substance' explicitly
+;; prevents that by adding t at the front of its value.
 
 ;;; Code:
 
@@ -44,15 +44,20 @@ A `cond*' construct is a series of clauses, and a clause
 normally has the form (CONDITION BODY...).
 
 CONDITION can be a Lisp expression, as in `cond'.
-Or it can be `(bind* BINDINGS...)' or `(match* PATTERN DATUM)'.
+Or it can be one of `(pcase* PATTERN DATUM)',
+`(bind* BINDINGS...)', or `(match* PATTERN DATUM)',
+
+`(pcase* PATTERN DATUM)' means to match DATUM against the
+pattern PATTERN, using the same pattern syntax as `pcase'.
+The condition counts as true if PATTERN matches DATUM.
 
 `(bind* BINDINGS...)' means to bind BINDINGS (as if they were in `let*')
 for the body of the clause.  As a condition, it counts as true
 if the first binding's value is non-nil.  All the bindings are made
 unconditionally for whatever scope they cover.
 
-`(match* PATTERN DATUM)' means to match DATUM against the pattern PATTERN
-The condition counts as true if PATTERN matches DATUM.
+`(match* PATTERN DATUM)' is an alternative to `pcase*' that uses another
+syntax for its patterns, see `match*'.
 
 When a clause's condition is true, and it exits the `cond*'
 or is the last clause, the value of the last expression
@@ -70,7 +75,7 @@ are passed along to the rest of the clauses in this `cond*' construct.
 \\[match*\\] for documentation of the patterns for use in `match*'."
   (cond*-convert clauses))
 
-(defmacro match* (pattern datum)
+(defmacro match* (pattern _datum)
   "This specifies matching DATUM against PATTERN.
 It is not really a Lisp function, and it is meaningful
 only in the CONDITION of a `cond*' clause.
@@ -133,7 +138,7 @@ ATOM (meaning any other kind of non-list not described above)
 \(constrain SYMBOL EXP)
   matches datum if the form EXP is true.
   EXP can refer to symbols bound earlier in the pattern."
-  (ignore datum)
+  ;; FIXME: `byte-compile-warn-x' is not necessarily defined here.
   (byte-compile-warn-x pattern "`match*' used other than as a `cond*' condition"))
 
 (defun cond*-non-exit-clause-p (clause)
@@ -245,8 +250,8 @@ This is used for conditional exit clauses."
                    ;; Then always go on to run the UNCONDIT-CLAUSES.
                    (if true-exps
                        `(let ((,init-gensym ,first-value))
-;;; ??? Should we make the bindings a second time for the UNCONDIT-CLAUSES.
-;;; as the doc string says, for uniformity with match*?
+;;;  ??? Should we make the bindings a second time for the UNCONDIT-CLAUSES.
+;;;  as the doc string says, for uniformity with match*?
                           (let* ,mod-bindings
                             (when ,init-gensym
                               . ,true-exps)
@@ -262,6 +267,24 @@ This is used for conditional exit clauses."
                     (let* ,mod-bindings
                       (when ,init-gensym
                         . ,true-exps)))))))
+          ((eq pat-type 'pcase*)
+           (if true-exps
+               (progn
+                 (when uncondit-clauses
+                   ;; FIXME: This happens in cases like
+                   ;;     (cond* ((match* `(,x . ,y) EXP) THEN :non-exit)
+                   ;;            (t ELSE))
+                   ;; where ELSE is supposed to run after THEN also (and
+                   ;; with access to `x' and `y').
+                   (error ":non-exit not supported with `pcase*'"))
+                 (cl-assert (or (null iffalse) rest))
+                 `(pcase ,(nth 2 condition)
+                    (,(nth 1 condition) ,@true-exps)
+                    (_ ,iffalse)))
+             (cl-assert (null iffalse))
+             (cl-assert (null rest))
+             `(pcase-let ((,(nth 1 condition) ,(nth 2 condition)))
+                (cond* . ,uncondit-clauses))))
           ((eq pat-type 'match*)
            (cond*-match condition true-exps uncondit-clauses iffalse))
           (t
@@ -369,11 +392,11 @@ as in `cond*-condition'."
     ;; because they are all gensyms anyway.
     (if (cdr backtrack-aliases)
         (setq expression
-              `(let ,(mapcar 'cdr (cdr backtrack-aliases))
+              `(let ,(mapcar #'cdr (cdr backtrack-aliases))
                  ,expression)))
     (if retrieve-value-swap-outs
         (setq expression
-              `(let ,(mapcar 'cadr retrieve-value-swap-outs)
+              `(let ,(mapcar #'cadr retrieve-value-swap-outs)
                  ,expression)))
     ;; If we used a gensym, wrap on code to bind it.
     (if gensym
@@ -397,8 +420,8 @@ This is used for the bindings specified explicitly in match* patterns."
 
 (defvar cond*-debug-pattern nil)
 
-;;; ??? Structure type patterns not implemented yet.
-;;; ??? Probably should optimize the `nth' calls in handling `list'.
+;; ??? Structure type patterns not implemented yet.
+;; ??? Probably should optimize the `nth' calls in handling `list'.
 
 (defun cond*-subpat (subpat cdr-ignore bindings inside-or backtrack-aliases data)
   "Generate code to match the subpattern within `match*'.
@@ -486,7 +509,7 @@ whether SUBPAT (as well as the subpatterns that contain/precede it) matches,"
                (unless (symbolp elt)
                  (byte-compile-warn-x vars "Non-symbol %s given as name for matched substring" elt)))
              ;; Bind these variables to nil, before the pattern.
-             (setq bindings (nconc (mapcar 'list vars) bindings))
+             (setq bindings (nconc (mapcar #'list vars) bindings))
              ;; Make the expressions to set the variables.
              (setq setqs (mapcar
                           (lambda (var)
diff --git a/test/lisp/emacs-lisp/cond-star-tests.el b/test/lisp/emacs-lisp/cond-star-tests.el
new file mode 100644
index 00000000000..7cf0a99f8db
--- /dev/null
+++ b/test/lisp/emacs-lisp/cond-star-tests.el
@@ -0,0 +1,53 @@
+;;; cond-star-tests.el --- tests for emacs-lisp/cond-star.el  -*- lexical-binding:t -*-
+
+;; Copyright (C) 2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'cond-star)
+(require 'ert)
+
+(ert-deftest cond-star-test-1 ()
+  (should (equal (cond*
+                   ((pcase* `(,x . ,y) (cons 5 4)) (list x y))
+                   (t 6))
+                 '(5 4)))
+  (should (equal (cond*
+                   ((pcase* `(,x . ,y) nil) (list x y))
+                   (t 6))
+                 6))
+  ;; FIXME: Not supported.
+  ;; (let* ((z nil)
+  ;;        (res (cond*
+  ;;              ((pcase* `(,x . ,y) (cons 5 4)) (setq z 6) :non-exit)
+  ;;              (t `(,x ,y ,z)))))
+  ;;   (should (equal res '(5 4 6))))
+  (should (equal (cond*
+                   ((pcase* `(,x . ,y) (cons 5 4)))
+                   (t (list x y)))
+                 '(5 4)))
+  (should (equal (cond*
+                   ((pcase* `(,x . ,y) nil))
+                   (t (list x y)))
+                 '(nil nil)))
+  )
+
+
+;;; cond-star-tests.el ends here