[Emacs-diffs] master e6f64df: Make edebug-step-in work on generic methods (Bug#22294)

[Dmitry Gutov]

branch: master
commit e6f64df9c2b443d3385c2c25c29ccd5283d37e3f
Author: Gemini Lasswell <address@hidden>
Commit: Dmitry Gutov <address@hidden>

    Make edebug-step-in work on generic methods (Bug#22294)
    
    * lisp/emacs-lisp/edebug.el (edebug-match-cl-generic-method-args):
    New function to implement the edebug-form-spec property of
    the symbol cl-generic-method-args.
    (edebug-instrument-function): If the function is a generic
    function, find and instrument all of its methods. Return a list
    instead of a single symbol.
    (edebug-instrument-callee): Now returns a list. Update docstring.
    (edebug-step-in): Handle the list returned by edebug-instrument-callee.
    * lisp/emacs-lisp/cl-generic.el (cl-defmethod): Use name and
    cl-generic-method-args in its Edebug spec.
    * lisp/emacs-lisp/eieio-compat.el (defmethod): Use name and
    cl-generic-method-args in its Edebug spec.
    * lisp/subr.el (method-files): New function.
    * test/lisp/subr-tests.el (subr-tests--method-files--finds-methods)
    (subr-tests--method-files--nonexistent-methods): New tests.
---
 lisp/emacs-lisp/cl-generic.el   |  4 ++--
 lisp/emacs-lisp/edebug.el       | 53 ++++++++++++++++++++++++++++++++---------
 lisp/emacs-lisp/eieio-compat.el |  4 ++--
 lisp/subr.el                    | 19 +++++++++++++++
 test/lisp/subr-tests.el         | 24 +++++++++++++++++++
 5 files changed, 89 insertions(+), 15 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 068f4fb..c64376b 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -413,12 +413,12 @@ The set of acceptable TYPEs (also called 
\"specializers\") is defined
   (declare (doc-string 3) (indent 2)
            (debug
             (&define                    ; this means we are defining something
-             [&or symbolp ("setf" symbolp)]
+             [&or name ("setf" name :name setf)]
              ;; ^^ This is the methods symbol
              [ &rest atom ]         ; Multiple qualifiers are allowed.
                                     ; Like in CLOS spec, we support
                                     ; any non-list values.
-             listp                      ; arguments
+             cl-generic-method-args     ; arguments
              [ &optional stringp ]      ; documentation string
              def-body)))                ; part to be debugged
   (let ((qualifiers nil))
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 4116e31..65e30f8 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -1607,6 +1607,7 @@ expressions; a `progn' form will be returned enclosing 
these forms."
                ;; Less frequently used:
                ;; (function . edebug-match-function)
                (lambda-expr . edebug-match-lambda-expr)
+                (cl-generic-method-args . edebug-match-cl-generic-method-args)
                (&not . edebug-match-&not)
                (&key . edebug-match-&key)
                (place . edebug-match-place)
@@ -1900,6 +1901,16 @@ expressions; a `progn' form will be returned enclosing 
these forms."
          spec))
   nil)
 
+(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)))
+
 (defun edebug-match-arg (cursor)
   ;; set the def-args bound in edebug-defining-form
   (let ((edebug-arg (edebug-top-element-required cursor "Expected arg")))
@@ -3186,8 +3197,11 @@ go to the end of the last sexp, or if that is the same 
point, then step."
         )))))
 
 (defun edebug-instrument-function (func)
-  ;; Func should be a function symbol.
-  ;; Return the function symbol, or nil if not instrumented.
+  "Instrument the function or generic method FUNC.
+Return the list of function symbols which were instrumented.
+This may be simply (FUNC) for a normal function, or a list of
+generated symbols for methods.  If a function or method to
+instrument cannot be found, signal an error."
   (let ((func-marker (get func 'edebug)))
     (cond
      ((and (markerp func-marker) (marker-buffer func-marker))
@@ -3195,10 +3209,24 @@ go to the end of the last sexp, or if that is the same 
point, then step."
       (with-current-buffer (marker-buffer func-marker)
        (goto-char func-marker)
        (edebug-eval-top-level-form)
-       func))
+        (list func)))
      ((consp func-marker)
       (message "%s is already instrumented." func)
-      func)
+      (list func))
+     ((get func 'cl--generic)
+      (let ((method-defs (method-files func))
+            symbols)
+        (unless method-defs
+          (error "Could not find any method definitions for %s" func))
+        (pcase-dolist (`(,file . ,spec) method-defs)
+          (let* ((loc (find-function-search-for-symbol spec 'cl-defmethod 
file)))
+            (unless (cdr loc)
+              (error "Could not find the definition for %s in its file" spec))
+            (with-current-buffer (car loc)
+              (goto-char (cdr loc))
+              (edebug-eval-top-level-form)
+              (push (edebug-form-data-symbol) symbols))))
+        symbols))
      (t
       (let ((loc (find-function-noselect func t)))
        (unless (cdr loc)
@@ -3206,13 +3234,16 @@ go to the end of the last sexp, or if that is the same 
point, then step."
        (with-current-buffer (car loc)
          (goto-char (cdr loc))
          (edebug-eval-top-level-form)
-         func))))))
+          (list func)))))))
 
 (defun edebug-instrument-callee ()
   "Instrument the definition of the function or macro about to be called.
 Do this when stopped before the form or it will be too late.
 One side effect of using this command is that the next time the
-function or macro is called, Edebug will be called there as well."
+function or macro is called, Edebug will be called there as well.
+If the callee is a generic function, Edebug will instrument all
+the methods, not just the one which is about to be called.  Return
+the list of symbols which were instrumented."
   (interactive)
   (if (not (looking-at "("))
       (error "You must be before a list form")
@@ -3227,15 +3258,15 @@ function or macro is called, Edebug will be called 
there as well."
 
 
 (defun edebug-step-in ()
-  "Step into the definition of the function or macro about to be called.
+  "Step into the definition of the function, macro or method about to be 
called.
 This first does `edebug-instrument-callee' to ensure that it is
 instrumented.  Then it does `edebug-on-entry' and switches to `go' mode."
   (interactive)
-  (let ((func (edebug-instrument-callee)))
-    (if func
+  (let ((funcs (edebug-instrument-callee)))
+    (if funcs
        (progn
-         (edebug-on-entry func 'temp)
-         (edebug-go-mode nil)))))
+          (mapc (lambda (func) (edebug-on-entry func 'temp)) funcs)
+          (edebug-go-mode nil)))))
 
 (defun edebug-on-entry (function &optional flag)
   "Cause Edebug to stop when FUNCTION is called.
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index fe65ae0..e6e6d11 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -105,10 +105,10 @@ Summary:
   (declare (doc-string 3) (obsolete cl-defmethod "25.1")
            (debug
             (&define                    ; this means we are defining something
-             [&or symbolp ("setf" symbolp)]
+             [&or name ("setf" name :name setf)]
              ;; ^^ This is the methods symbol
              [ &optional symbolp ]                ; this is key :before etc
-             listp                                ; arguments
+             cl-generic-method-args               ; arguments
              [ &optional stringp ]                ; documentation string
              def-body                             ; part to be debugged
              )))
diff --git a/lisp/subr.el b/lisp/subr.el
index 02e7993..8d5d2a7 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2026,6 +2026,25 @@ definition, variable definition, or face definition 
only."
        (setq files (cdr files)))
       file)))
 
+(defun method-files (method)
+  "Return a list of files where METHOD is defined by `cl-defmethod'.
+The list will have entries of the form (FILE . (METHOD ...))
+where (METHOD ...) contains the qualifiers and specializers of
+the method and is a suitable argument for
+`find-function-search-for-symbol'.  Filenames are absolute."
+  (let ((files load-history)
+        result)
+    (while files
+      (let ((defs (cdr (car files))))
+        (while defs
+          (let ((def (car defs)))
+            (if (and (eq (car-safe def) 'cl-defmethod)
+                     (eq (cadr def) method))
+                (push (cons (car (car files)) (cdr def)) result)))
+          (setq defs (cdr defs))))
+      (setq files (cdr files)))
+    result))
+
 (defun locate-library (library &optional nosuffix path interactive-call)
   "Show the precise file name of Emacs library LIBRARY.
 LIBRARY should be a relative file name of the library, a string.
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 0d243cc..8fa258d 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -291,5 +291,29 @@ cf. Bug#25477."
   (should-error (eval '(dolist "foo") t)
                 :type 'wrong-type-argument))
 
+(require 'cl-generic)
+(cl-defgeneric subr-tests--generic (x))
+(cl-defmethod subr-tests--generic ((x string))
+  (message "%s is a string" x))
+(cl-defmethod subr-tests--generic ((x integer))
+  (message "%s is a number" x))
+(cl-defgeneric subr-tests--generic-without-methods (x y))
+(defvar subr-tests--this-file (or load-file-name buffer-file-name))
+
+(ert-deftest subr-tests--method-files--finds-methods ()
+  "`method-files' returns a list of files and methods for a generic function."
+  (let ((retval (method-files 'subr-tests--generic)))
+    (should (equal (length retval) 2))
+    (mapc (lambda (x)
+            (should (equal (car x) subr-tests--this-file))
+            (should (equal (cadr x) 'subr-tests--generic)))
+          retval)
+    (should-not (equal (nth 0 retval) (nth 1 retval)))))
+
+(ert-deftest subr-tests--method-files--nonexistent-methods ()
+  "`method-files' returns nil if asked to find a method which doesn't exist."
+  (should-not (method-files 'subr-tests--undefined-generic))
+  (should-not (method-files 'subr-tests--generic-without-methods)))
+
 (provide 'subr-tests)
 ;;; subr-tests.el ends here