* 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:
parent
b2225a374f
commit
bfb8d33fd1
6 changed files with 51 additions and 30 deletions
2
etc/NEWS
2
etc/NEWS
|
@ -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'.
|
||||
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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.
|
||||
|
|
57
lisp/subr.el
57
lisp/subr.el
|
@ -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.
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Add table
Reference in a new issue