[Emacs-diffs] master bfb8d33: * lisp/subr.el (define-symbol-prop): New function

[Stefan Monnier]

branch: master
commit bfb8d33fd18b1d9fd5868204d472cb19f5bcafbe
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * 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.
---
 etc/NEWS                          |  2 ++
 lisp/emacs-lisp/ert.el            | 11 ++------
 lisp/emacs-lisp/pcase.el          |  4 +--
 lisp/loadhist.el                  |  5 ++++
 lisp/subr.el                      | 57 ++++++++++++++++++++++++++-------------
 test/lisp/emacs-lisp/ert-tests.el |  2 +-
 6 files changed, 51 insertions(+), 30 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 2b7c93f..ef4c125 100644
--- a/etc/NEWS
+++ b/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'.
 
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 5186199..d7bd331 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -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)))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index b401611..253b60e 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -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."
diff --git a/lisp/loadhist.el b/lisp/loadhist.el
index b83d023..18c30f7 100644
--- a/lisp/loadhist.el
+++ b/lisp/loadhist.el
@@ -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.
diff --git a/lisp/subr.el b/lisp/subr.el
index 90a78cf..b3f9f90 100644
--- a/lisp/subr.el
+++ b/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.
diff --git a/test/lisp/emacs-lisp/ert-tests.el 
b/test/lisp/emacs-lisp/ert-tests.el
index 317838b..57463ad 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -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)