procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* lisp/subr.el (method-files): Move function to cl-generic.el

Browse source 
* 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.
This commit is contained in:
Stefan Monnier 2017-07-28 11:28:48 -04:00
parent dc9c6a071c
commit b2225a374f
6 changed files with 46 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
etc/NEWS
View file

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

18
lisp/emacs-lisp/cl-generic.el
View file

@ -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 <val>) specializers.
;; For both the `eql' and the `head' specializers, the dispatch

4
lisp/emacs-lisp/edebug.el
View file

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

19
lisp/subr.el
View file

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

24
test/lisp/emacs-lisp/cl-generic-tests.el
View file

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

25
test/lisp/subr-tests.el
View file

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