* 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`.
This commit is contained in:
Stefan Monnier 2021-02-13 16:21:53 -05:00
parent e81cf63be1
commit 2007afd21b
9 changed files with 111 additions and 84 deletions

View file

@ -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