master 2007afd: * lisp/emacs-lisp/edebug.el (edebug--handle-&-spec-op <&name>): New method

[Stefan Monnier]

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

    * lisp/emacs-lisp/edebug.el (edebug--handle-&-spec-op <&name>): New method
    
    (edebug--concat-name): New function.
    (edebug-match-name, edebug-match-cl-generic-method-qualifier)
    (edebug-match-cl-generic-method-args): Delete functions.
    
    * doc/lispref/edebug.texi (Specification List): Document it.
    
    * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Use `&name`.
    (cl-generic--method-qualifier-p): New predicate.
    (cl-defmethod): Use it and `&name`.
    * lisp/emacs-lisp/cl-macs.el (cl-defun, cl-iter-defun, cl-flet):
    * lisp/emacs-lisp/eieio-compat.el (defmethod):
    * lisp/emacs-lisp/gv.el (gv-define-setter):
    * lisp/emacs-lisp/ert.el (ert-deftest): Use `&name`.
    * lisp/erc/erc-backend.el (define-erc-response-handler): Use `declare`
    and `&name`.
---
 doc/lispref/edebug.texi         | 28 +++++--------
 etc/NEWS                        |  9 ++--
 lisp/emacs-lisp/cl-generic.el   | 36 ++++++++++------
 lisp/emacs-lisp/cl-macs.el      |  9 ++--
 lisp/emacs-lisp/edebug.el       | 92 ++++++++++++++++++++++++-----------------
 lisp/emacs-lisp/eieio-compat.el |  2 +-
 lisp/emacs-lisp/ert.el          |  4 +-
 lisp/emacs-lisp/gv.el           |  3 +-
 lisp/erc/erc-backend.el         | 12 +++---
 9 files changed, 111 insertions(+), 84 deletions(-)

diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index 99d55c7..2412e84 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -1444,29 +1444,23 @@ Here is a list of additional specifications that may 
appear only after
 @code{&define}.  See the @code{defun} example.
 
 @table @code
+@item &name
+Extracts the name of the current defining form from the code.
+It takes the form @code{&name [@var{prestring}] @var{spec}
+[@var{poststring}] @var{fun} @var{args...}} and means that Edebug will
+match @var{spec} against the code and then call @var{fun} with the
+concatenation of the current name, @var{args...}, @var{prestring},
+the code that matched @code{spec}, and @var{poststring}.  If @var{fun}
+is absent, it defaults to a function that concatenates the arguments
+(with an @code{@} between the previous name and the new).
+
 @item name
 The argument, a symbol, is the name of the defining form.
+Shorthand for @code{[&name symbolp]}.
 
 A defining form is not required to have a name field; and it may have
 multiple name fields.
 
-@item :name
-This construct does not actually match an argument.  The element
-following @code{:name} should be a symbol; it is used as an additional
-name component for the definition.  You can use this to add a unique,
-static component to the name of the definition.  It may be used more
-than once.
-
-@item :unique
-This construct is like @code{:name}, but generates unique names.  It
-does not match an argument.  The element following @code{:unique}
-should be a string; it is used as the prefix for an additional name
-component for the definition.  You can use this to add a unique,
-dynamic component to the name of the definition.  This is useful for
-macros that can define the same symbol multiple times in different
-scopes, such as @code{cl-flet}; @ref{Function Bindings,,,cl}.  It may
-be used more than once.
-
 @item arg
 The argument, a symbol, is the name of an argument of the defining form.
 However, lambda-list keywords (symbols starting with @samp{&})
diff --git a/etc/NEWS b/etc/NEWS
index aead8c6..de26c01 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -936,7 +936,11 @@ To customize obsolete user options, use 'customize-option' 
or
 ** Edebug
 
 ---
-*** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'.
+*** Obsoletions
+**** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'.
+
++++
+**** The Edebug spec operator ':name NAME' is obsolete.
 
 +++
 *** New function 'def-edebug-elem-spec' to define Edebug spec elements.
@@ -954,8 +958,7 @@ declared obsolete.
 **** '&error MSG' unconditionally aborts the current edebug instrumentation.
 
 +++
-**** ':unique STRING' appends STRING to the Edebug name of the current
-definition to (hopefully) make it more unique.
+**** '&name SPEC FUN' extracts the current name from the code matching SPEC.
 
 ** ElDoc
 
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 8e36dbe..2296083 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -206,22 +206,29 @@ DEFAULT-BODY, if present, is used as the body of a 
default method.
 \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)"
   (declare (indent 2) (doc-string 3)
            (debug
-            (&define [&or name ("setf" name :name setf)] listp
-                     lambda-doc
+            (&define [&name sexp] ;Allow (setf ...) additionally to symbols.
+                     listp lambda-doc
                      [&rest [&or
                              ("declare" &rest sexp)
                              (":argument-precedence-order" &rest sexp)
                              (&define ":method"
-                                      ;; FIXME: The `:unique'
+                                      ;; FIXME: The `gensym'
                                       ;; construct works around
                                       ;; Bug#42672.  We'd rather want
                                       ;; names like those generated by
                                       ;; `cl-defmethod', but that
                                       ;; requires larger changes to
                                       ;; Edebug.
-                                      :unique "cl-generic-:method@"
-                                      [&rest cl-generic-method-qualifier]
-                                      cl-generic-method-args lambda-doc
+                                      [&name "cl-generic-:method@" []]
+                                      [&name [] gensym] ;Make it unique!
+                                      [&name
+                                       [[&rest cl-generic--method-qualifier-p]
+                                        ;; FIXME: We don't actually want the
+                                        ;; argument's names to be considered
+                                        ;; part of the name of the defined
+                                        ;; function.
+                                        listp]] ;Formal args
+                                      lambda-doc
                                       def-body)]]
                      def-body)))
   (let* ((doc (if (stringp (car-safe options-and-methods))
@@ -398,6 +405,9 @@ the specializer used will be the one returned by BODY."
       (let ((combined-doc (buffer-string)))
         (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
 
+(defun cl-generic--method-qualifier-p (x)
+  (not (listp x)))
+
 ;;;###autoload
 (defmacro cl-defmethod (name args &rest body)
   "Define a new method for generic function NAME.
@@ -440,15 +450,17 @@ The set of acceptable TYPEs (also called 
\"specializers\") is defined
   (declare (doc-string 3) (indent defun)
            (debug
             (&define                    ; this means we are defining something
-             [&or name ("setf" name :name setf)]
-             ;; ^^ This is the methods symbol
-             [ &rest cl-generic-method-qualifier ]
-             ;; Multiple qualifiers are allowed.
-             cl-generic-method-args     ; arguments
+             [&name [sexp   ;Allow (setf ...) additionally to symbols.
+                     ;; Multiple qualifiers are allowed.
+                     [&rest cl-generic--method-qualifier-p]
+                     ;; FIXME: We don't actually want the argument's names
+                     ;; to be considered part of the name of the
+                     ;; defined function.
+                     listp]]     ; arguments
              lambda-doc                 ; documentation string
              def-body)))                ; part to be debugged
   (let ((qualifiers nil))
-    (while (not (listp args))
+    (while (cl-generic--method-qualifier-p args)
       (push args qualifiers)
       (setq args (pop body)))
     (when (eq 'setf (car-safe name))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 5967e0d..e2faf6d 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -358,7 +358,7 @@ more details.
 \(fn NAME ARGLIST [DOCSTRING] BODY...)"
   (declare (debug
             ;; Same as defun but use cl-lambda-list.
-            (&define [&or name ("setf" :name setf name)]
+            (&define [&name sexp]   ;Allow (setf ...) additionally to symbols.
                      cl-lambda-list
                      cl-declarations-or-string
                      [&optional ("interactive" interactive)]
@@ -376,7 +376,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...).
 \(fn NAME ARGLIST [DOCSTRING] BODY...)"
   (declare (debug
             ;; Same as iter-defun but use cl-lambda-list.
-            (&define [&or name ("setf" :name setf name)]
+            (&define [&name sexp]   ;Allow (setf ...) additionally to symbols.
                      cl-lambda-list
                      cl-declarations-or-string
                      [&optional ("interactive" interactive)]
@@ -2016,8 +2016,9 @@ info node `(cl) Function Bindings' for details.
 
 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
   (declare (indent 1)
-           (debug ((&rest [&or (&define name :unique "cl-flet@" form)
-                               (&define name :unique "cl-flet@"
+           (debug ((&rest [&or (symbolp form)
+                               (&define [&name symbolp "@cl-flet@"]
+                                        [&name [] gensym] ;Make it unique!
                                         cl-lambda-list
                                         cl-declarations-or-string
                                         [&optional ("interactive" interactive)]
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index cbf2d17..867161e 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -1748,16 +1748,12 @@ contains a circular object."
 (dolist (pair '((form . edebug-match-form)
                (sexp . edebug-match-sexp)
                (body . edebug-match-body)
-               (name . edebug-match-name)
                (arg . edebug-match-arg)
                (def-body . edebug-match-def-body)
                (def-form . edebug-match-def-form)
                ;; Less frequently used:
                ;; (function . edebug-match-function)
                (lambda-expr . edebug-match-lambda-expr)
-                (cl-generic-method-qualifier
-                 . edebug-match-cl-generic-method-qualifier)
-                (cl-generic-method-args . edebug-match-cl-generic-method-args)
                 (cl-macrolet-expr . edebug-match-cl-macrolet-expr)
                 (cl-macrolet-name . edebug-match-cl-macrolet-name)
                 (cl-macrolet-body . edebug-match-cl-macrolet-body)
@@ -2056,19 +2052,61 @@ and then matches the rest against the output of (FUN 
ARGS... HEAD)."
       )))
 
 
-(defun edebug-match-name (cursor)
-  ;; Set the edebug-def-name bound in edebug-defining-form.
-  (let ((name (edebug-top-element-required cursor "Expected name")))
-    ;; Maybe strings and numbers could be used.
-    (if (not (symbolp name))
-       (edebug-no-match cursor "Symbol expected for name of definition"))
-    (setq edebug-def-name
-         (if edebug-def-name
-             ;; Construct a new name by appending to previous name.
-             (intern (format "%s@%s" edebug-def-name name))
-           name))
-    (edebug-move-cursor cursor)
-    (list name)))
+(cl-defmethod edebug--handle-&-spec-op ((_ (eql &name)) cursor specs)
+  "Compute the name for `&name SPEC FUN` spec operator.
+
+The full syntax of that operator is:
+    &name [PRESTRING] SPEC [POSTSTRING] FUN ARGS...
+
+Extracts the head of the data by matching it against SPEC,
+and then get the new name to use by calling
+  (FUN ARGS... OLDNAME [PRESTRING] HEAD [POSTSTRING])
+FUN should return either a string or a symbol.
+FUN can be missing in which case it defaults to concatenating
+the new name to the end of the old with an \"@\" char between the two.
+PRESTRING and POSTSTRING are optional strings that get prepended
+or appended to the actual name."
+  (pcase-let*
+      ((`(,spec ,fun . ,args) specs)
+       (prestrings (when (stringp spec)
+                     (prog1 (list spec) (setq spec fun fun (pop args)))))
+       (poststrings (when (stringp fun)
+                      (prog1 (list fun) (setq fun (pop args)))))
+       (exps (edebug-cursor-expressions cursor))
+       (instrumented (edebug-match-one-spec cursor spec))
+       (consumed (- (length exps)
+                    (length (edebug-cursor-expressions cursor))))
+       (newname (apply (or fun #'edebug--concat-name)
+                       `(,@args ,edebug-def-name
+                                ,@prestrings
+                                ,@(seq-subseq exps 0 consumed)
+                                ,@poststrings))))
+    (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps)))
+    (setq edebug-def-name (if (stringp newname) (intern newname) newname))
+    instrumented))
+
+(defun edebug--concat-name (oldname &rest newnames)
+  (let ((newname (if (null (cdr newnames))
+                     (car newnames)
+                   ;; Put spaces between each name, but not for the
+                   ;; leading and trailing strings, if any.
+                   (let (beg mid end)
+                     (dolist (name newnames)
+                       (if (stringp name)
+                           (push name (if mid end beg))
+                         (when end (setq mid (nconc end mid) end nil))
+                         (push name mid)))
+                     (apply #'concat `(,@(nreverse beg)
+                                       ,(mapconcat (lambda (x) (format "%s" x))
+                                                   (nreverse mid) " ")
+                                       ,@(nreverse end)))))))
+    (if (null oldname)
+        (if (or (stringp newname) (symbolp newname))
+            newname
+          (format "%s" newname))
+      (format "%s@%s" edebug-def-name newname))))
+
+(def-edebug-elem-spec 'name '(&name symbolp))
 
 (cl-defgeneric edebug--handle-:-spec-op (op cursor spec)
   "Handle :foo spec operators.
@@ -2094,26 +2132,6 @@ SPEC is the symbol name prefix for `gensym'."
            suffix)))
   nil)
 
-(defun edebug-match-cl-generic-method-qualifier (cursor)
-  "Match a QUALIFIER for `cl-defmethod' at CURSOR."
-  (let ((args (edebug-top-element-required cursor "Expected qualifier")))
-    ;; Like in CLOS spec, we support any non-list values.
-    (unless (atom args) (edebug-no-match cursor "Atom expected"))
-    ;; Append the arguments to `edebug-def-name' (Bug#42671).
-    (setq edebug-def-name (intern (format "%s %s" edebug-def-name args)))
-    (edebug-move-cursor cursor)
-    (list args)))
-
-(defun edebug-match-cl-generic-method-args (cursor)
-  (let ((args (edebug-top-element-required cursor "Expected arguments")))
-    (if (not (consp args))
-        (edebug-no-match cursor "List expected"))
-    ;; Append the arguments to edebug-def-name.
-    (setq edebug-def-name
-          (intern (format "%s %s" edebug-def-name args)))
-    (edebug-move-cursor cursor)
-    (list args)))
-
 (defvar edebug--cl-macrolet-defs nil
   "List of symbols found within the bindings of enclosing `cl-macrolet' 
forms.")
 (defvar edebug--current-cl-macrolet-defs nil
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index db97d4c..6d84839 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -105,7 +105,7 @@ Summary:
   (declare (doc-string 3) (obsolete cl-defmethod "25.1")
            (debug
             (&define                    ; this means we are defining something
-             [&or name ("setf" name :name setf)]
+             [&name sexp]   ;Allow (setf ...) additionally to symbols.
              ;; ^^ This is the methods symbol
              [ &optional symbolp ]                ; this is key :before etc
              cl-generic-method-args               ; arguments
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index fdbf953..e08fa7a 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -196,8 +196,8 @@ it has to be wrapped in `(eval (quote ...))'.
 
 \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
 [:tags \\='(TAG...)] BODY...)"
-  (declare (debug (&define :name test
-                           name sexp [&optional stringp]
+  (declare (debug (&define [&name "test@" symbolp]
+                          sexp [&optional stringp]
                           [&rest keywordp sexp] def-body))
            (doc-string 3)
            (indent 2))
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index edacdf7..3200b1c 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -229,7 +229,8 @@ The first arg in ARGLIST (the one that receives VAL) 
receives an expression
 which can do arbitrary things, whereas the other arguments are all guaranteed
 to be pure and copyable.  Example use:
   (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))"
-  (declare (indent 2) (debug (&define name :name gv-setter sexp def-body)))
+  (declare (indent 2)
+           (debug (&define [&name symbolp "@gv-setter"] sexp def-body)))
   `(gv-define-expander ,name
      (lambda (do &rest args)
        (declare-function
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index 6f1193c..73c2b56 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -1079,14 +1079,12 @@ Finds hooks by looking in the `erc-server-responses' 
hash table."
     (erc-display-message parsed 'notice proc line)))
 
 
-(put 'define-erc-response-handler 'edebug-form-spec
-     '(&define :name erc-response-handler
-               (name &rest name)
-               &optional sexp sexp def-body))
-
 (cl-defmacro define-erc-response-handler ((name &rest aliases)
-                                        &optional extra-fn-doc extra-var-doc
-                                        &rest fn-body)
+                                          &optional extra-fn-doc extra-var-doc
+                                          &rest fn-body)
+  (declare (debug (&define [&name "erc-response-handler@"
+                                  (symbolp &rest symbolp)]
+                           &optional sexp sexp def-body)))
   "Define an ERC handler hook/function pair.
 NAME is the response name as sent by the server (see the IRC RFC for
 meanings).