From: Stefan Monnier Date: Fri, 28 Jul 2017 15:28:48 +0000 (-0400) Subject: * lisp/subr.el (method-files): Move function to cl-generic.el X-Git-Tag: emacs-26.0.90~517^2~85 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=b2225a374f24f1ee1a881bfd5d3c1f7b57447e47;p=emacs.git * lisp/subr.el (method-files): Move function to cl-generic.el * lisp/emacs-lisp/cl-generic.el (cl-generic-p): New function. (cl--generic-method-files): New function, moved from subr.el. * lisp/emacs-lisp/edebug.el (edebug-instrument-function): Use them. * test/lisp/emacs-lisp/cl-generic-tests.el: * test/lisp/subr-tests.el: Move and adjust method-files tests accordingly. --- diff --git a/etc/NEWS b/etc/NEWS index a7800feed1f..2b7c93fda10 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -604,6 +604,8 @@ paragraphs, for the purposes of bidirectional display. * Changes in Specialized Modes and Packages in Emacs 26.1 +** New function `cl-generic-p'. + ** Dired +++ diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 114468239a5..1a3f8e1f4d5 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -166,6 +166,10 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG (defmacro cl--generic (name) `(get ,name 'cl--generic)) +(defun cl-generic-p (f) + "Return non-nil if F is a generic function." + (and (symbolp f) (cl--generic f))) + (defun cl-generic-ensure-function (name &optional noerror) (let (generic (origname name)) @@ -1023,6 +1027,20 @@ The value returned is a list of elements of the form (push (cl--generic-method-info method) docs)))) docs)) +(defun cl--generic-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 (result) + (pcase-dolist (`(,file . ,defs) load-history) + (dolist (def defs) + (when (and (eq (car-safe def) 'cl-defmethod) + (eq (cadr def) method)) + (push (cons file (cdr def)) result)))) + result)) + ;;; Support for (head ) specializers. ;; For both the `eql' and the `head' specializers, the dispatch diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 1494ed1d9c3..c6ef8d7a99c 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -3213,8 +3213,8 @@ instrument cannot be found, signal an error." ((consp func-marker) (message "%s is already instrumented." func) (list func)) - ((get func 'cl--generic) - (let ((method-defs (method-files func)) + ((cl-generic-p func) + (let ((method-defs (cl--generic-method-files func)) symbols) (unless method-defs (error "Could not find any method definitions for %s" func)) diff --git a/lisp/subr.el b/lisp/subr.el index 79a28d301e7..90a78cf68a0 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2031,25 +2031,6 @@ 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/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 0768e31f7e6..31f65413c88 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -219,5 +219,29 @@ (should (equal (cl--generic-1 '(5) nil) '("cinq" (5)))) (should (equal (cl--generic-1 '(6) nil) '("six" a)))) +(cl-defgeneric cl-generic-tests--generic (x)) +(cl-defmethod cl-generic-tests--generic ((x string)) + (message "%s is a string" x)) +(cl-defmethod cl-generic-tests--generic ((x integer)) + (message "%s is a number" x)) +(cl-defgeneric cl-generic-tests--generic-without-methods (x y)) +(defvar cl-generic-tests--this-file + (file-truename (or load-file-name buffer-file-name))) + +(ert-deftest cl-generic-tests--method-files--finds-methods () + "`method-files' returns a list of files and methods for a generic function." + (let ((retval (cl--generic-method-files 'cl-generic-tests--generic))) + (should (equal (length retval) 2)) + (mapc (lambda (x) + (should (equal (car x) cl-generic-tests--this-file)) + (should (equal (cadr x) 'cl-generic-tests--generic))) + retval) + (should-not (equal (nth 0 retval) (nth 1 retval))))) + +(ert-deftest cl-generic-tests--method-files--nonexistent-methods () + "`method-files' returns nil if asked to find a method which doesn't exist." + (should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic)) + (should-not (cl--generic-method-files 'cl-generic-tests--generic-without-methods))) + (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 7e50429a5bf..a59f0ca90e1 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -292,31 +292,6 @@ 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 - (file-truename (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))) - (ert-deftest subr-tests-bug22027 () "Test for http://debbugs.gnu.org/22027 ." (let ((default "foo") res)