master 806759dc0a6: (pcase): New `_` syntax in pred/app functions

[Stefan Monnier]

branch: master
commit 806759dc0a6a3b049ce35d0497011464e5fc4dcb
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    (pcase): New `_` syntax in pred/app functions
    
    The current syntax for functions in `app` and `pred` patterns
    allows a shorthand (F ARGS) where the object being matched is
    added as an extra last argument.  This is nice for things like
    (pred (< 5)) but sometimes the object needs to be at
    another position.
    Until now you had to use (pred (lambda (x) (memq x my-list)))
    or (pred (pcase--flip memq my-list)) in those cases.
    So, introduce a new shorthand where `_` can be used to indicate
    where the object should be passed: (pred (memq _ my-list))
    
    * lisp/emacs-lisp/pcase.el (pcase--split-pred): Document new syntax
    for pred/app functions.
    (pcase--funcall): Support new syntax.
    (pcase--flip): Declare obsolete.
    (pcase--u1, \`): Use `_` instead.
    (pcase--split-pred): Adjust accordingly.
    
    * doc/lispref/control.texi (pcase Macro): Document new syntax
    for pred/app functions.
    
    * lisp/progmodes/opascal.el (pcase-defmacro):
    * lisp/emacs-lisp/seq.el (seq--make-pcase-bindings):
    * lisp/emacs-lisp/eieio.el (eieio):
    * lisp/emacs-lisp/cl-macs.el (cl-struct, cl-type):
    Use _ instead of `pcase--flip`.
    (cl--pcase-mutually-exclusive-p): Adjust accordingly.
    
    * lisp/emacs-lisp/map.el (map--pcase-map-elt): Declare obsolete.
    (map--make-pcase-bindings): Use `_` instead.
---
 doc/lispref/control.texi   | 10 ++++++++++
 etc/NEWS                   |  4 ++++
 lisp/emacs-lisp/cl-macs.el | 15 ++++++++-------
 lisp/emacs-lisp/eieio.el   |  4 ++--
 lisp/emacs-lisp/map.el     |  7 ++++---
 lisp/emacs-lisp/pcase.el   | 25 ++++++++++++++++---------
 lisp/emacs-lisp/seq.el     |  4 ++--
 lisp/progmodes/opascal.el  |  2 +-
 8 files changed, 47 insertions(+), 24 deletions(-)

diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 0c6895332a0..78ad5b68a51 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -638,6 +638,16 @@ with @var{n} arguments (the other elements) and an 
additional
 Example: @code{(= 42)}@*
 In this example, the function is @code{=}, @var{n} is one, and
 the actual function call becomes: @w{@code{(= 42 @var{expval})}}.
+
+@item function call with an @code{_} arg
+Call the function (the first element of the function call)
+with the specified arguments (the other elements) and replacing
+@code{_} with @var{expval}.
+
+Example: @code{(gethash _ memo-table)}
+In this example, the function is @code{gethash}, and
+the actual function call becomes: @w{@code{(gethash @var{expval}
+memo-table)}}.
 @end table
 
 @item (app @var{function} @var{pattern})
diff --git a/etc/NEWS b/etc/NEWS
index de1f2fd9d2a..afc2c22e68b 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1526,6 +1526,10 @@ values.
 
 * Lisp Changes in Emacs 30.1
 
++++
+** Pcase's functions (in 'pred' and 'app') can specify the argument position.
+For example, instead of (pred (< 5)) you can write (pred (> _ 5)).
+
 +++
 ** 'define-advice' now sets the new advice's 'name' property to NAME.
 Named advices defined with 'define-advice' can now be removed with
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 88447203a64..06a09885c88 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3344,14 +3344,14 @@ Elements of FIELDS can be of the form (NAME PAT) in 
which case the
 contents of field NAME is matched against PAT, or they can be of
 the form NAME which is a shorthand for (NAME NAME)."
   (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp])))
-  `(and (pred (pcase--flip cl-typep ',type))
+  `(and (pred (cl-typep _ ',type))
         ,@(mapcar
            (lambda (field)
              (let* ((name (if (consp field) (car field) field))
                     (pat (if (consp field) (cadr field) field)))
                `(app ,(if (eq (cl-struct-sequence-type type) 'list)
                           `(nth ,(cl-struct-slot-offset type name))
-                        `(pcase--flip aref ,(cl-struct-slot-offset type name)))
+                        `(aref _ ,(cl-struct-slot-offset type name)))
                      ,pat)))
            fields)))
 
@@ -3368,13 +3368,13 @@ the form NAME which is a shorthand for (NAME NAME)."
   "Extra special cases for `cl-typep' predicates."
   (let* ((x1 pred1) (x2 pred2)
          (t1
-          (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1))
-               (eq 'cl-typep (car-safe x1))    (setq x1 (cdr x1))
+          (and (eq 'cl-typep (car-safe x1))    (setq x1 (cdr x1))
+               (eq '_ (car-safe x1))           (setq x1 (cdr x1))
                (null (cdr-safe x1))            (setq x1 (car x1))
                (eq 'quote (car-safe x1))       (cadr x1)))
          (t2
-          (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2))
-               (eq 'cl-typep (car-safe x2))    (setq x2 (cdr x2))
+          (and (eq 'cl-typep (car-safe x2))    (setq x2 (cdr x2))
+               (eq '_ (car-safe x2))           (setq x2 (cdr x2))
                (null (cdr-safe x2))            (setq x2 (car x2))
                (eq 'quote (car-safe x2))       (cadr x2))))
     (or
@@ -3818,7 +3818,8 @@ STRUCT-TYPE and SLOT-NAME are symbols.  INST is a 
structure instance."
 (pcase-defmacro cl-type (type)
   "Pcase pattern that matches objects of TYPE.
 TYPE is a type descriptor as accepted by `cl-typep', which see."
-  `(pred (pcase--flip cl-typep ',type)))
+  `(pred (cl-typep _ ',type)))
+
 
 ;; Local variables:
 ;; generated-autoload-file: "cl-loaddefs.el"
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index df85a64baf3..fba69a36a97 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -387,9 +387,9 @@ contents of field NAME is matched against PAT, or they can 
be of
         ,@(mapcar (lambda (field)
                     (pcase-exhaustive field
                       (`(,name ,pat)
-                       `(app (pcase--flip eieio-oref ',name) ,pat))
+                       `(app (eieio-oref _ ',name) ,pat))
                       ((pred symbolp)
-                       `(app (pcase--flip eieio-oref ',field) ,field))))
+                       `(app (eieio-oref _ ',field) ,field))))
                   fields)))
 
 ;;; Simple generators, and query functions.  None of these would do
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index ffbb29615da..95a25978d1c 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -608,18 +608,19 @@ This allows using default values for `map-elt', which 
can't be
 done using `pcase--flip'.
 
 KEY is the key sought in the map.  DEFAULT is the default value."
+  (declare (obsolete _ "30.1"))
   `(map-elt ,map ,key ,default))
 
 (defun map--make-pcase-bindings (args)
   "Return a list of pcase bindings from ARGS to the elements of a map."
   (mapcar (lambda (elt)
             (cond ((consp elt)
-                   `(app (map--pcase-map-elt ,(car elt) ,(caddr elt))
+                   `(app (map-elt _ ,(car elt) ,(caddr elt))
                          ,(cadr elt)))
                   ((keywordp elt)
                    (let ((var (intern (substring (symbol-name elt) 1))))
-                     `(app (pcase--flip map-elt ,elt) ,var)))
-                  (t `(app (pcase--flip map-elt ',elt) ,elt))))
+                     `(app (map-elt _ ,elt) ,var)))
+                  (t `(app (map-elt _ ',elt) ,elt))))
           args))
 
 (defun map--make-pcase-patterns (args)
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 880a1829265..ae9bd87997c 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -131,6 +131,8 @@ FUN in `pred' and `app' can take one of the forms:
      call it with one argument
   (F ARG1 .. ARGn)
      call F with ARG1..ARGn and EXPVAL as n+1'th argument
+  (F ARG1 .. _ .. ARGn)
+     call F, passing EXPVAL at the _ position.
 
 FUN, BOOLEXP, and subsequent PAT can refer to variables
 bound earlier in the pattern by a SYMBOL pattern.
@@ -814,10 +816,10 @@ A and B can be one of:
                     #'compiled-function-p))))
         (pcase--mutually-exclusive-p (cadr upat) otherpred))
       '(:pcase--fail . nil))
-     ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
+     ;; Since we turn (or 'a 'b 'c) into (pred (memq _ '(a b c)))
      ;; try and preserve the info we get from that memq test.
-     ((and (eq 'pcase--flip (car-safe (cadr upat)))
-           (memq (cadr (cadr upat)) '(memq member memql))
+     ((and (memq (car-safe (cadr upat)) '(memq member memql))
+           (eq (cadr (cadr upat)) '_)
            (eq 'quote (car-safe (nth 2 (cadr upat))))
            (eq 'quote (car-safe pat)))
       (let ((set (cadr (nth 2 (cadr upat)))))
@@ -865,7 +867,7 @@ A and B can be one of:
 
 (defmacro pcase--flip (fun arg1 arg2)
   "Helper function, used internally to avoid (funcall (lambda ...) ...)."
-  (declare (debug (sexp body)))
+  (declare (debug (sexp body)) (obsolete _ "30.1"))
   `(,fun ,arg2 ,arg1))
 
 (defun pcase--funcall (fun arg vars)
@@ -886,9 +888,13 @@ A and B can be one of:
                      (let ((newsym (gensym "x")))
                        (push (list newsym arg) env)
                        (setq arg newsym)))
-                   (if (or (functionp fun) (not (consp fun)))
-                       `(funcall #',fun ,arg)
-                     `(,@fun ,arg)))))
+                   (cond
+                    ((or (functionp fun) (not (consp fun)))
+                     `(funcall #',fun ,arg))
+                    ((memq '_ fun)
+                     (mapcar (lambda (x) (if (eq '_ x) arg x)) fun))
+                    (t
+                     `(,@fun ,arg))))))
       (if (null env)
           call
         ;; Let's not replace `vars' in `fun' since it's
@@ -949,7 +955,7 @@ Otherwise, it defers to REST which is a list of branches of 
the form
        ;; Yes, we can use `memql' (or `member')!
        ((> (length simples) 1)
         (pcase--u1 (cons `(match ,var
-                                 . (pred (pcase--flip ,mem-fun ',simples)))
+                                 . (pred (,mem-fun _ ',simples)))
                          (cdr matches))
                    code vars
                    (if (null others) rest
@@ -1096,12 +1102,13 @@ The predicate is the logical-AND of:
   (declare (debug (pcase-QPAT)))
   (cond
    ((eq (car-safe qpat) '\,) (cadr qpat))
+   ((eq (car-safe qpat) '\,@) (error "Unsupported QPAT: %S" qpat))
    ((vectorp qpat)
     `(and (pred vectorp)
           (app length ,(length qpat))
           ,@(let ((upats nil))
               (dotimes (i (length qpat))
-                (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
+                (push `(app (aref _ ,i) ,(list '\` (aref qpat i)))
                       upats))
               (nreverse upats))))
    ((consp qpat)
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index 4c6553972c2..20077db9e60 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -619,12 +619,12 @@ SEQUENCE must be a sequence of numbers or markers."
       (unless rest-marker
         (pcase name
           (`&rest
-           (progn (push `(app (pcase--flip seq-drop ,index)
+           (progn (push `(app (seq-drop _ ,index)
                               ,(seq--elt-safe args (1+ index)))
                         bindings)
                   (setq rest-marker t)))
           (_
-           (push `(app (pcase--flip seq--elt-safe ,index) ,name) bindings))))
+           (push `(app (seq--elt-safe _ ,index) ,name) bindings))))
       (setq index (1+ index)))
     bindings))
 
diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el
index 5e8263cb646..a80e12b8129 100644
--- a/lisp/progmodes/opascal.el
+++ b/lisp/progmodes/opascal.el
@@ -281,7 +281,7 @@ nested routine.")
 
 (eval-when-compile
   (pcase-defmacro opascal--in (set)
-    `(pred (pcase--flip memq ,set))))
+    `(pred (memq _ ,set))))
 
 (defun opascal-string-of (start end)
   ;; Returns the buffer string from start to end.