* lisp/subr.el (define-symbol-prop): New function

(symbol-file): Make it find symbol property definitions.

* lisp/emacs-lisp/pcase.el (pcase-defmacro):
* lisp/emacs-lisp/ert.el (ert-set-test): Use it instead of `put'.
(ert-describe-test): Adjust call to symbol-file accordingly.
This commit is contained in:
Stefan Monnier 2017-07-28 12:02:01 -04:00
parent b2225a374f
commit bfb8d33fd1
6 changed files with 51 additions and 30 deletions

View file

@ -1175,6 +1175,8 @@ break.
* Lisp Changes in Emacs 26.1
** New function `define-symbol-prop'.
+++
** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'.

View file

@ -135,16 +135,9 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
;; Note that nil is still a valid value for the `name' slot in
;; ert-test objects. It designates an anonymous test.
(error "Attempt to define a test named nil"))
(put symbol 'ert--test definition)
;; Register in load-history, so `symbol-file' can find us, and so
;; unload-feature can unload our tests.
(cl-pushnew `(ert-deftest . ,symbol) current-load-list :test #'equal)
(define-symbol-prop symbol 'ert--test definition)
definition)
(cl-defmethod loadhist-unload-element ((x (head ert-deftest)))
(let ((name (cdr x)))
(put name 'ert--test nil)))
(defun ert-make-test-unbound (symbol)
"Make SYMBOL name no test. Return SYMBOL."
(cl-remprop symbol 'ert--test)
@ -2539,7 +2532,7 @@ To be used in the ERT results buffer."
(insert (if test-name (format "%S" test-name) "<anonymous test>"))
(insert " is a test")
(let ((file-name (and test-name
(symbol-file test-name 'ert-deftest))))
(symbol-file test-name 'ert--test))))
(when file-name
(insert (format-message " defined in `%s'"
(file-name-nondirectory file-name)))

View file

@ -418,8 +418,8 @@ to this macro."
(when decl (setq body (remove decl body)))
`(progn
(defun ,fsym ,args ,@body)
(put ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
(put ',name 'pcase-macroexpander #',fsym))))
(define-symbol-prop ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
(define-symbol-prop ',name 'pcase-macroexpander #',fsym))))
(defun pcase--match (val upat)
"Build a MATCH structure, hoisting all `or's and `and's outside."

View file

@ -221,6 +221,11 @@ restore a previous autoload if possible.")
;; Remove the struct.
(setf (cl--find-class name) nil)))
(cl-defmethod loadhist-unload-element ((x (head define-symbol-props)))
(pcase-dolist (`(,symbol . ,props) (cdr x))
(dolist (prop props)
(put symbol prop nil))))
;;;###autoload
(defun unload-feature (feature &optional force)
"Unload the library that provided FEATURE.

View file

@ -1999,6 +1999,25 @@ If TOGGLE has a `:menu-tag', that is used for the menu item's label."
;; "Return the name of the file from which AUTOLOAD will be loaded.
;; \n\(fn AUTOLOAD)")
(defun define-symbol-prop (symbol prop val)
"Define the property PROP of SYMBOL to be VAL.
This is to `put' what `defalias' is to `fset'."
;; Can't use `cl-pushnew' here (nor `push' on (cdr foo)).
;; (cl-pushnew symbol (alist-get prop
;; (alist-get 'define-symbol-props
;; current-load-list)))
(let ((sps (assq 'define-symbol-props current-load-list)))
(unless sps
(setq sps (list 'define-symbol-props))
(push sps current-load-list))
(let ((ps (assq prop sps)))
(unless ps
(setq ps (list prop))
(setcdr sps (cons ps (cdr sps))))
(unless (member symbol (cdr ps))
(setcdr ps (cons symbol (cdr ps))))))
(put symbol prop val))
(defun symbol-file (symbol &optional type)
"Return the name of the file that defined SYMBOL.
The value is normally an absolute file name. It can also be nil,
@ -2008,28 +2027,30 @@ file name without extension.
If TYPE is nil, then any kind of definition is acceptable. If
TYPE is `defun', `defvar', or `defface', that specifies function
definition, variable definition, or face definition only."
definition, variable definition, or face definition only.
Otherwise TYPE is assumed to be a symbol property."
(if (and (or (null type) (eq type 'defun))
(symbolp symbol)
(autoloadp (symbol-function symbol)))
(nth 1 (symbol-function symbol))
(let ((files load-history)
file match)
(while files
(if (if type
(if (eq type 'defvar)
;; Variables are present just as their names.
(member symbol (cdr (car files)))
;; Other types are represented as (TYPE . NAME).
(member (cons type symbol) (cdr (car files))))
;; We accept all types, so look for variable def
;; and then for any other kind.
(or (member symbol (cdr (car files)))
(and (setq match (rassq symbol (cdr (car files))))
(not (eq 'require (car match))))))
(setq file (car (car files)) files nil))
(setq files (cdr files)))
file)))
(catch 'found
(pcase-dolist (`(,file . ,elems) load-history)
(when (if type
(if (eq type 'defvar)
;; Variables are present just as their names.
(member symbol elems)
;; Many other types are represented as (TYPE . NAME).
(or (member (cons type symbol) elems)
(memq symbol (alist-get type
(alist-get 'define-symbol-props
elems)))))
;; We accept all types, so look for variable def
;; and then for any other kind.
(or (member symbol elems)
(let ((match (rassq symbol elems)))
(and match
(not (eq 'require (car match)))))))
(throw 'found file))))))
(defun locate-library (library &optional nosuffix path interactive-call)
"Show the precise file name of Emacs library LIBRARY.

View file

@ -352,7 +352,7 @@ This macro is used to test if macroexpansion in `should' works."
(let ((abc (ert-get-test 'ert-test-abc)))
(should (equal (ert-test-tags abc) '(bar)))
(should (equal (ert-test-documentation abc) "foo")))
(should (equal (symbol-file 'ert-test-deftest 'ert-deftest)
(should (equal (symbol-file 'ert-test-deftest 'ert--test)
(symbol-file 'ert-test--which-file 'defun)))
(ert-deftest ert-test-def () :expected-result ':passed)