From 24b7f77581c7eefe484db6cbbd661c04460c66aa Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 16 Jan 2015 22:52:15 -0500 Subject: [PATCH] Improve handling of doc-strings and describe-function for cl-generic * lisp/help-fns.el (find-lisp-object-file-name): Accept any `type' as long as it's a symbol. (help-fns-short-filename): New function. (describe-function-1): Use it. Use autoload-do-load. * lisp/help-mode.el (help-function-def): Add optional arg `type'. * lisp/emacs-lisp/cl-generic.el (cl-generic-ensure-function): It's OK to override an autoload. (cl-generic-current-method-specializers): Replace dyn-bind variable with a lexically-scoped macro. (cl--generic-lambda): Update accordingly. (cl-generic-define-method): Record manually in the load-history with type `cl-defmethod'. (cl--generic-get-dispatcher): Minor optimization. (cl--generic-search-method): New function. (find-function-regexp-alist): Add entry for `cl-defmethod' type. (cl--generic-search-method): Add hyperlinks for methods. Merge the specializers and the function's arguments. * lisp/emacs-lisp/eieio-core.el (eieio--defalias): Move to eieio-generic.el. (eieio-defclass-autoload): Don't record the superclasses any more. (eieio-defclass-internal): Reuse the old class object if it was just an autoload stub. (eieio--class-precedence-list): Load the class if it's autoloaded. * lisp/emacs-lisp/eieio-generic.el (eieio--defalias): Move from eieio-core. (eieio--defgeneric-init-form): Don't throw away a previous docstring. (eieio--method-optimize-primary): Don't mess with the docstring. (defgeneric): Keep the `args' in the docstring. (defmethod): Don't use the method's docstring for the generic function's docstring. * lisp/emacs-lisp/find-func.el: Use lexical-binding. (find-function-regexp): Don't rule out `defgeneric'. (find-function-regexp-alist): Document new possibility of including a function instead of a regexp. (find-function-search-for-symbol): Implement that new possibility. (find-function-library): Don't assume that `function' is a symbol. (find-function-do-it): Remove unused var `orig-buf'. * test/automated/cl-generic-tests.el (cl-generic-test-8-after/before): Rename from cl-generic-test-7-after/before. (cl--generic-test-advice): New function. (cl-generic-test-9-advice): New test. * test/automated/eieio-test-methodinvoke.el (eieio-test-cl-generic-1): Reset eieio-test--1. --- lisp/ChangeLog | 45 +++++++++ lisp/emacs-lisp/cl-generic.el | 117 +++++++++++++++------- lisp/emacs-lisp/eieio-core.el | 89 ++++++---------- lisp/emacs-lisp/eieio-generic.el | 51 ++++++---- lisp/emacs-lisp/find-func.el | 68 +++++++------ lisp/help-fns.el | 26 +++-- lisp/help-mode.el | 4 +- test/ChangeLog | 10 ++ test/automated/cl-generic-tests.el | 15 ++- test/automated/eieio-test-methodinvoke.el | 1 + 10 files changed, 269 insertions(+), 157 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f78714b3217..01de483a607 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,48 @@ +2015-01-17 Stefan Monnier + + Improve handling of doc-strings and describe-function for cl-generic. + + * help-mode.el (help-function-def): Add optional arg `type'. + + * help-fns.el (find-lisp-object-file-name): Accept any `type' as long + as it's a symbol. + (help-fns-short-filename): New function. + (describe-function-1): Use it. Use autoload-do-load. + + * emacs-lisp/find-func.el: Use lexical-binding. + (find-function-regexp): Don't rule out `defgeneric'. + (find-function-regexp-alist): Document new possibility of including + a function instead of a regexp. + (find-function-search-for-symbol): Implement that new possibility. + (find-function-library): Don't assume that `function' is a symbol. + (find-function-do-it): Remove unused var `orig-buf'. + + * emacs-lisp/eieio-generic.el (eieio--defalias): Move from eieio-core. + (eieio--defgeneric-init-form): Don't throw away a previous docstring. + (eieio--method-optimize-primary): Don't mess with the docstring. + (defgeneric): Keep the `args' in the docstring. + (defmethod): Don't use the method's docstring for the generic + function's docstring. + + * emacs-lisp/eieio-core.el (eieio--defalias): Move to eieio-generic.el. + (eieio-defclass-autoload): Don't record the superclasses any more. + (eieio-defclass-internal): Reuse the old class object if it was just an + autoload stub. + (eieio--class-precedence-list): Load the class if it's autoloaded. + + * emacs-lisp/cl-generic.el (cl-generic-ensure-function): It's OK to + override an autoload. + (cl-generic-current-method-specializers): Replace dyn-bind variable + with a lexically-scoped macro. + (cl--generic-lambda): Update accordingly. + (cl-generic-define-method): Record manually in the load-history with + type `cl-defmethod'. + (cl--generic-get-dispatcher): Minor optimization. + (cl--generic-search-method): New function. + (find-function-regexp-alist): Add entry for `cl-defmethod' type. + (cl--generic-search-method): Add hyperlinks for methods. Merge the + specializers and the function's arguments. + 2015-01-16 Artur Malabarba * emacs-lisp/package.el (package--read-pkg-desc): New diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 21688bef18a..ae0f129bb23 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -107,6 +107,7 @@ They should be sorted from most specific to least specific.") (symbolp (symbol-function name))) (setq name (symbol-function name))) (unless (or (not (fboundp name)) + (autoloadp (symbol-function name)) (and (functionp name) generic)) (error "%s is already defined as something else than a generic function" origname)) @@ -153,7 +154,7 @@ via (:documentation DOCSTRING)." code)) (defalias ',name (cl-generic-define ',name ',args ',options-and-methods) - ,doc)))) + ,(help-add-fundoc-usage doc args))))) (defun cl--generic-mandatory-args (args) (let ((res ())) @@ -176,15 +177,10 @@ via (:documentation DOCSTRING)." (setf (cl--generic-method-table generic) nil) (cl--generic-make-function generic))) -(defvar cl-generic-current-method-specializers nil - ;; This is let-bound during macro-expansion of method bodies, so that those - ;; bodies can be optimized knowing that the specializers have matched. - ;; FIXME: This presumes the formal arguments aren't modified via `setq' and - ;; aren't shadowed either ;-( - ;; FIXME: This might leak outside the scope of the method if, during - ;; macroexpansion of the method, something causes some other macroexpansion - ;; (e.g. an autoload). - "List of (VAR . TYPE) where TYPE is var's specializer.") +(defmacro cl-generic-current-method-specializers () + "List of (VAR . TYPE) where TYPE is var's specializer. +This macro can only be used within the lexical scope of a cl-generic method." + (error "cl-generic-current-method-specializers used outside of a method")) (eval-and-compile ;Needed while compiling the cl-defmethod calls below! (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. @@ -199,27 +195,29 @@ via (:documentation DOCSTRING)." (defun cl--generic-lambda (args body with-cnm) "Make the lambda expression for a method with ARGS and BODY." (let ((plain-args ()) - (cl-generic-current-method-specializers nil) + (specializers nil) (doc-string (if (stringp (car-safe body)) (pop body))) (mandatory t)) (dolist (arg args) (push (pcase arg ((or '&optional '&rest '&key) (setq mandatory nil) arg) ((and `(,name . ,type) (guard mandatory)) - (push (cons name (car type)) - cl-generic-current-method-specializers) + (push (cons name (car type)) specializers) name) (_ arg)) plain-args)) (setq plain-args (nreverse plain-args)) (let ((fun `(cl-function (lambda ,plain-args ,@(if doc-string (list doc-string)) - ,@body)))) + ,@body))) + (macroenv (cons `(cl-generic-current-method-specializers + . ,(lambda () specializers)) + macroexpand-all-environment))) (if (not with-cnm) - (cons nil fun) + (cons nil (macroexpand-all fun macroenv)) ;; First macroexpand away the cl-function stuff (e.g. &key and ;; destructuring args, `declare' and whatnot). - (pcase (macroexpand fun macroexpand-all-environment) + (pcase (macroexpand fun macroenv) (`#'(lambda ,args . ,body) (require 'cl-lib) ;Needed to expand `cl-flet'. (let* ((doc-string (and doc-string (stringp (car body)) @@ -228,7 +226,7 @@ via (:documentation DOCSTRING)." (nbody (macroexpand-all `(cl-flet ((cl-call-next-method ,cnm)) ,@body) - macroexpand-all-environment)) + macroenv)) ;; FIXME: Rather than `grep' after the fact, the ;; macroexpansion should directly set some flag when cnm ;; is used. @@ -309,8 +307,13 @@ which case this method will be invoked when the argument is `eql' to VAL. (setf (cl--generic-method-table generic) (cons `(,key ,uses-cnm . ,function) mt))) ;; For aliases, cl--generic-name gives us the actual name. - (defalias (cl--generic-name generic) - (cl--generic-make-function generic)))) + (let ((gfun (cl--generic-make-function generic)) + ;; Prevent `defalias' from recording this as the definition site of + ;; the generic function. + current-load-list) + (defalias (cl--generic-name generic) gfun)) + (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) + current-load-list :test #'equal))) (defmacro cl--generic-with-memoization (place &rest code) (declare (indent 1) (debug t)) @@ -327,6 +330,14 @@ which case this method will be invoked when the argument is `eql' to VAL. (cl--generic-with-memoization (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers) (let ((lexical-binding t) + (tag-exp `(or ,@(mapcar #'cdr + ;; Minor optimization: since this tag-exp is + ;; only used to lookup the method-cache, it + ;; doesn't matter if the default value is some + ;; constant or nil. + (if (macroexp-const-p (car (last tagcodes))) + (butlast tagcodes) + tagcodes)))) (extraargs ())) (dotimes (_ dispatch-arg) (push (make-symbol "arg") extraargs)) @@ -335,7 +346,7 @@ which case this method will be invoked when the argument is `eql' to VAL. (let ((method-cache (make-hash-table :test #'eql))) (lambda (,@extraargs arg &rest args) (apply (cl--generic-with-memoization - (gethash (or ,@(mapcar #'cdr tagcodes)) method-cache) + (gethash ,tag-exp method-cache) (cl--generic-cache-miss generic ',dispatch-arg dispatches-left (list ,@(mapcar #'cdr tagcodes)))) @@ -456,31 +467,63 @@ Can only be used from within the lexical body of a primary or around method." ;;; Add support for describe-function -(add-hook 'help-fns-describe-function-functions 'cl--generic-describe) +(defun cl--generic-search-method (met-name) + (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+" + (regexp-quote (format "%s\\_>" (car met-name)))))) + (or + (re-search-forward + (concat base-re "[^&\"\n]*" + (mapconcat (lambda (specializer) + (regexp-quote + (format "%S" (if (consp specializer) + (nth 1 specializer) specializer)))) + (remq t (cdr met-name)) + "[ \t\n]*)[^&\"\n]*")) + nil t) + (re-search-forward base-re nil t)))) + + +(with-eval-after-load 'find-func + (defvar find-function-regexp-alist) + (add-to-list 'find-function-regexp-alist + `(cl-defmethod . ,#'cl--generic-search-method))) + +(add-hook 'help-fns-describe-function-functions #'cl--generic-describe) (defun cl--generic-describe (function) - ;; FIXME: Fix up the main "in `'" hyperlink, and add such hyperlinks - ;; for each method. (let ((generic (if (symbolp function) (cl--generic function)))) (when generic + (require 'help-mode) ;Needed for `help-function-def' button! (save-excursion (insert "\n\nThis is a generic function.\n\n") (insert (propertize "Implementations:\n\n" 'face 'bold)) ;; Loop over fanciful generics - (pcase-dolist (`((,type . ,qualifier) . ,method) + (pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method) (cl--generic-method-table generic)) - (insert "`") - (if (symbolp type) - ;; FIXME: Add support for cl-structs in help-variable. - (help-insert-xref-button (symbol-name type) - 'help-variable type) - (insert (format "%S" type))) - (insert (format "' %S %S\n" - (car qualifier) - (let ((args (help-function-arglist method))) - ;; Drop cl--generic-next arg if present. - (if (memq (car qualifier) '(:after :before)) - args (cdr args))))) - (insert (or (documentation method) "Undocumented") "\n\n")))))) + (let* ((args (help-function-arglist method 'names)) + (docstring (documentation method)) + (doconly (if docstring + (let ((split (help-split-fundoc docstring nil))) + (if split (cdr split) docstring)))) + (combined-args ())) + (if uses-cnm (setq args (cdr args))) + (dolist (specializer specializers) + (let ((arg (if (eq '&rest (car args)) + (intern (format "arg%d" (length combined-args))) + (pop args)))) + (push (if (eq specializer t) arg (list arg specializer)) + combined-args))) + (setq combined-args (append (nreverse combined-args) args)) + ;; FIXME: Add hyperlinks for the types as well. + (insert (format "%S %S" qualifier combined-args)) + (let* ((met-name (cons function specializers)) + (file (find-lisp-object-file-name met-name 'cl-defmethod))) + (when file + (insert " in `") + (help-insert-xref-button (help-fns-short-filename file) + 'help-function-def met-name file + 'cl-defmethod) + (insert "'.\n"))) + (insert "\n" (or doconly "Undocumented") "\n\n"))))))) ;;; Support for (eql ) specializers. diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index bfa922bade6..e526a41e871 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -34,19 +34,6 @@ (require 'cl-lib) (require 'pcase) -(put 'eieio--defalias 'byte-hunk-handler - #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) -(defun eieio--defalias (name body) - "Like `defalias', but with less side-effects. -More specifically, it has no side-effects at all when the new function -definition is the same (`eq') as the old one." - (while (and (fboundp name) (symbolp (symbol-function name))) - ;; Follow aliases, so methods applied to obsolete aliases still work. - (setq name (symbol-function name))) - (unless (and (fboundp name) - (eq (symbol-function name) body)) - (defalias name body))) - ;;; ;; A few functions that are better in the official EIEIO src, but ;; used from the core. @@ -292,7 +279,7 @@ Abstract classes cannot be instantiated." ;; We autoload this because it's used in `make-autoload'. ;;;###autoload -(defun eieio-defclass-autoload (cname superclasses filename doc) +(defun eieio-defclass-autoload (cname _superclasses filename doc) "Create autoload symbols for the EIEIO class CNAME. SUPERCLASSES are the superclasses that CNAME inherits from. DOC is the docstring for CNAME. @@ -301,58 +288,35 @@ SUPERCLASSES as children. It creates an autoload function for CNAME's constructor." ;; Assume we've already debugged inputs. + ;; We used to store the list of superclasses in the `parent' slot (as a list + ;; of class names). But now this slot holds a list of class objects, and + ;; those parents may not exist yet, so the corresponding class objects may + ;; simply not exist yet. So instead we just don't store the list of parents + ;; here in eieio-defclass-autoload at all, since it seems that they're just + ;; not needed before the class is actually loaded. (let* ((oldc (when (class-p cname) (eieio--class-v cname))) (newc (eieio--class-make cname)) ) (if oldc nil ;; Do nothing if we already have this class. - (let ((clear-parent nil)) - ;; No parents? - (when (not superclasses) - (setq superclasses '(eieio-default-superclass) - clear-parent t) - ) - - ;; Hook our new class into the existing structures so we can - ;; autoload it later. - (dolist (SC superclasses) - - - ;; TODO - If we create an autoload that is in the map, that - ;; map needs to be cleared! - - - ;; Save the child in the parent. - (cl-pushnew cname (if (class-p SC) - (eieio--class-children (eieio--class-v SC)) - ;; Parent doesn't exist yet. - (gethash SC eieio-defclass-autoload-map))) + ;; turn this into a usable self-pointing symbol + (when eieio-backward-compatibility + (set cname cname) + (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) - ;; Save parent in child. - (push (eieio--class-v SC) (eieio--class-parent newc))) + ;; Store the new class vector definition into the symbol. We need to + ;; do this first so that we can call defmethod for the accessor. + ;; The vector will be updated by the following while loop and will not + ;; need to be stored a second time. + (setf (eieio--class-v cname) newc) - ;; turn this into a usable self-pointing symbol - (when eieio-backward-compatibility - (set cname cname) - (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) - - ;; Store the new class vector definition into the symbol. We need to - ;; do this first so that we can call defmethod for the accessor. - ;; The vector will be updated by the following while loop and will not - ;; need to be stored a second time. - (setf (eieio--class-v cname) newc) - - ;; Clear the parent - (if clear-parent (setf (eieio--class-parent newc) nil)) - - ;; Create an autoload on top of our constructor function. - (autoload cname filename doc nil nil) - (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) - (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) - (autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil) - - )))) + ;; Create an autoload on top of our constructor function. + (autoload cname filename doc nil nil) + (autoload (intern (format "%s-p" cname)) filename "" nil nil) + (when eieio-backward-compatibility + (autoload (intern (format "%s-child-p" cname)) filename "" nil nil) + (autoload (intern (format "%s-list-p" cname)) filename "" nil nil))))) (defsubst eieio-class-un-autoload (cname) "If class CNAME is in an autoload state, load its file." @@ -378,8 +342,13 @@ See `defclass' for more information." (setq eieio-hook nil) (let* ((pname superclasses) - (newc (eieio--class-make cname)) (oldc (when (class-p cname) (eieio--class-v cname))) + (newc (if (and oldc (not (eieio--class-default-object-cache oldc))) + ;; The oldc class is a stub setup by eieio-defclass-autoload. + ;; Reuse it instead of creating a new one, so that existing + ;; references are still valid. + oldc + (eieio--class-make cname))) (groups nil) ;; list of groups id'd from slots (clearparent nil)) @@ -1284,6 +1253,8 @@ The order, in which the parents are returned depends on the method invocation orders of the involved classes." (if (or (null class) (eq class eieio-default-superclass)) nil + (unless (eieio--class-default-object-cache class) + (eieio-class-un-autoload (eieio--class-symbol class))) (cl-case (eieio--class-method-invocation-order class) (:depth-first (eieio--class-precedence-dfs class)) diff --git a/lisp/emacs-lisp/eieio-generic.el b/lisp/emacs-lisp/eieio-generic.el index 0e90074660e..4045c038033 100644 --- a/lisp/emacs-lisp/eieio-generic.el +++ b/lisp/emacs-lisp/eieio-generic.el @@ -33,6 +33,19 @@ (require 'eieio-core) (declare-function child-of-class-p "eieio") +(put 'eieio--defalias 'byte-hunk-handler + #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) +(defun eieio--defalias (name body) + "Like `defalias', but with less side-effects. +More specifically, it has no side-effects at all when the new function +definition is the same (`eq') as the old one." + (while (and (fboundp name) (symbolp (symbol-function name))) + ;; Follow aliases, so methods applied to obsolete aliases still work. + (setq name (symbol-function name))) + (unless (and (fboundp name) + (eq (symbol-function name) body)) + (defalias name body))) + (defconst eieio--method-static 0 "Index into :static tag on a method.") (defconst eieio--method-before 1 "Index into :before tag on a method.") (defconst eieio--method-primary 2 "Index into :primary tag on a method.") @@ -101,7 +114,7 @@ Methods with only primary implementations are executed in an optimized way." ;; Make sure the method tables are installed. (eieio--mt-install method) ;; Construct the actual body of this function. - (put method 'function-documentation doc-string) + (if doc-string (put method 'function-documentation doc-string)) (eieio--defgeneric-form method)) ((generic-p method) (symbol-function method)) ;Leave it as-is. (t (error "You cannot create a generic/method over an existing symbol: %s" @@ -177,20 +190,18 @@ but remove reference to all implementations of METHOD." ;; ;; If this method, after this setup, only has primary methods, then ;; we can setup the generic that way. - (let ((doc-string (documentation method 'raw))) - (put method 'function-documentation doc-string) - ;; Use `defalias' so as to interact properly with nadvice.el. - (defalias method - (if (eieio--generic-primary-only-p method) - ;; If there is only one primary method, then we can go one more - ;; optimization step. - (if (eieio--generic-primary-only-one-p method) - (let* ((M (get method 'eieio-method-tree)) - (entry (car (aref M eieio--method-primary)))) - (eieio--defgeneric-form-primary-only-one - method (car entry) (cdr entry))) - (eieio--defgeneric-form-primary-only method)) - (eieio--defgeneric-form method)))))) + ;; Use `defalias' so as to interact properly with nadvice.el. + (defalias method + (if (eieio--generic-primary-only-p method) + ;; If there is only one primary method, then we can go one more + ;; optimization step. + (if (eieio--generic-primary-only-one-p method) + (let* ((M (get method 'eieio-method-tree)) + (entry (car (aref M eieio--method-primary)))) + (eieio--defgeneric-form-primary-only-one + method (car entry) (cdr entry))) + (eieio--defgeneric-form-primary-only method)) + (eieio--defgeneric-form method))))) (defun eieio--defmethod (method kind argclass code) "Work part of the `defmethod' macro defining METHOD with ARGS." @@ -627,7 +638,7 @@ is memorized for faster future use." ;;; CLOS methods and generics ;; -(defmacro defgeneric (method _args &optional doc-string) +(defmacro defgeneric (method args &optional doc-string) "Create a generic function METHOD. DOC-STRING is the base documentation for this class. A generic function has no body, as its purpose is to decide which method body @@ -637,7 +648,9 @@ currently ignored. You can use `defgeneric' to apply specialized top level documentation to a method." (declare (doc-string 3)) `(eieio--defalias ',method - (eieio--defgeneric-init-form ',method ,doc-string))) + (eieio--defgeneric-init-form + ',method + ,(if doc-string (help-add-fundoc-usage doc-string args))))) (defmacro defmethod (method &rest args) "Create a new METHOD through `defgeneric' with ARGS. @@ -684,9 +697,7 @@ Summary: (code `(lambda ,fargs ,@(cdr args)))) `(progn ;; Make sure there is a generic and the byte-compiler sees it. - (defgeneric ,method ,args - ,(or (documentation code) - (format "Generically created method `%s'." method))) + (defgeneric ,method ,args) (eieio--defmethod ',method ',key ',class #',code)))) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index cc7b06c35b1..6c9c798bc16 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -1,4 +1,4 @@ -;;; find-func.el --- find the definition of the Emacs Lisp function near point +;;; find-func.el --- find the definition of the Emacs Lisp function near point -*- lexical-binding:t -*- ;; Copyright (C) 1997, 1999, 2001-2015 Free Software Foundation, Inc. @@ -59,7 +59,7 @@ (concat "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ -foo\\|[^icfgv]\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ +foo\\|\\(?:[^icfv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ menu-bar-make-toggle\\)" find-function-space-re "\\('\\|\(quote \\)?%s\\(\\s-\\|$\\|\(\\|\)\\)") @@ -106,7 +106,10 @@ Please send improvements and fixes to the maintainer." (defface . find-face-regexp)) "Alist mapping definition types into regexp variables. Each regexp variable's value should actually be a format string -to be used to substitute the desired symbol name into the regexp.") +to be used to substitute the desired symbol name into the regexp. +Instead of regexp variable, types can be mapped to functions as well, +in which case the function is called with one argument (the object +we're looking for) and it should search for it.") (put 'find-function-regexp-alist 'risky-local-variable t) (defcustom find-function-source-path nil @@ -282,30 +285,33 @@ The search is done in the source for library LIBRARY." (let* ((filename (find-library-name library)) (regexp-symbol (cdr (assq type find-function-regexp-alist)))) (with-current-buffer (find-file-noselect filename) - (let ((regexp (format (symbol-value regexp-symbol) - ;; Entry for ` (backquote) macro in loaddefs.el, - ;; (defalias (quote \`)..., has a \ but - ;; (symbol-name symbol) doesn't. Add an - ;; optional \ to catch this. - (concat "\\\\?" - (regexp-quote (symbol-name symbol))))) + (let ((regexp (if (functionp regexp-symbol) regexp-symbol + (format (symbol-value regexp-symbol) + ;; Entry for ` (backquote) macro in loaddefs.el, + ;; (defalias (quote \`)..., has a \ but + ;; (symbol-name symbol) doesn't. Add an + ;; optional \ to catch this. + (concat "\\\\?" + (regexp-quote (symbol-name symbol)))))) (case-fold-search)) (with-syntax-table emacs-lisp-mode-syntax-table (goto-char (point-min)) - (if (or (re-search-forward regexp nil t) - ;; `regexp' matches definitions using known forms like - ;; `defun', or `defvar'. But some functions/variables - ;; are defined using special macros (or functions), so - ;; if `regexp' can't find the definition, we look for - ;; something of the form "(SOMETHING ...)". - ;; This fails to distinguish function definitions from - ;; variable declarations (or even uses thereof), but is - ;; a good pragmatic fallback. - (re-search-forward - (concat "^([^ ]+" find-function-space-re "['(]?" - (regexp-quote (symbol-name symbol)) - "\\_>") - nil t)) + (if (if (functionp regexp) + (funcall regexp symbol) + (or (re-search-forward regexp nil t) + ;; `regexp' matches definitions using known forms like + ;; `defun', or `defvar'. But some functions/variables + ;; are defined using special macros (or functions), so + ;; if `regexp' can't find the definition, we look for + ;; something of the form "(SOMETHING ...)". + ;; This fails to distinguish function definitions from + ;; variable declarations (or even uses thereof), but is + ;; a good pragmatic fallback. + (re-search-forward + (concat "^([^ ]+" find-function-space-re "['(]?" + (regexp-quote (symbol-name symbol)) + "\\_>") + nil t))) (progn (beginning-of-line) (cons (current-buffer) (point))) @@ -324,18 +330,19 @@ signal an error. If VERBOSE is non-nil, and FUNCTION is an alias, display a message about the whole chain of aliases." - (let ((def (symbol-function (find-function-advised-original function))) + (let ((def (if (symbolp function) + (symbol-function (find-function-advised-original function)))) aliases) ;; FIXME for completeness, it might be nice to print something like: ;; foo (which is advised), which is an alias for bar (which is advised). - (while (symbolp def) + (while (and def (symbolp def)) (or (eq def function) (not verbose) - (if aliases - (setq aliases (concat aliases + (setq aliases (if aliases + (concat aliases (format ", which is an alias for `%s'" - (symbol-name def)))) - (setq aliases (format "`%s' is an alias for `%s'" + (symbol-name def))) + (format "`%s' is an alias for `%s'" function (symbol-name def))))) (setq function (symbol-function (find-function-advised-original function)) def (symbol-function (find-function-advised-original function)))) @@ -408,7 +415,6 @@ See also `find-function-after-hook'. Set mark before moving, if the buffer already existed." (let* ((orig-point (point)) - (orig-buf (window-buffer)) (orig-buffers (buffer-list)) (buffer-point (save-excursion (find-definition-noselect symbol type))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 10c040a246c..c0d63935035 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -183,8 +183,7 @@ OBJECT should be a symbol associated with a function, variable, or face; alternatively, it can be a function definition. If TYPE is `defvar', search for a variable definition. If TYPE is `defface', search for a face definition. -If TYPE is the value returned by `symbol-function' for a function symbol, - search for a function definition. +If TYPE is not a symbol, search for a function definition. The return value is the absolute name of a readable file where OBJECT is defined. If several such files exist, preference is given to a file @@ -194,9 +193,10 @@ suitable file is found, return nil." (let* ((autoloaded (autoloadp type)) (file-name (or (and autoloaded (nth 1 type)) (symbol-file - object (if (memq type (list 'defvar 'defface)) - type - 'defun))))) + ;; FIXME: Why do we have this weird "If TYPE is the + ;; value returned by `symbol-function' for a function + ;; symbol" exception? + object (or (if (symbolp type) type) 'defun))))) (cond (autoloaded ;; An autoloaded function: Locate the file since `symbol-function' @@ -452,6 +452,18 @@ FILE is the file where FUNCTION was probably defined." (t ".")) "\n"))))) +(defun help-fns-short-filename (filename) + (let* ((abbrev (abbreviate-file-name filename)) + (short abbrev)) + (dolist (dir load-path) + (let ((rel (file-relative-name filename dir))) + (if (< (length rel) (length short)) + (setq short rel))) + (let ((rel (file-relative-name abbrev dir))) + (if (< (length rel) (length short)) + (setq short rel)))) + short)) + ;;;###autoload (defun describe-function-1 (function) (let* ((advised (and (symbolp function) @@ -543,7 +555,7 @@ FILE is the file where FUNCTION was probably defined." ;; but that's completely wrong when the user used load-file. (princ (if (eq file-name 'C-source) "C source code" - (file-name-nondirectory file-name))) + (help-fns-short-filename file-name))) (princ "'") ;; Make a hyperlink to the library. (with-current-buffer standard-output @@ -564,7 +576,7 @@ FILE is the file where FUNCTION was probably defined." help-enable-auto-load (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw) - (load (cadr real-def) t)) + (autoload-do-load real-def)) (substitute-command-keys doc-raw)))) (help-fns--key-bindings function) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index dd2030706b2..c62ddc3dcd0 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -191,7 +191,7 @@ The format is (FUNCTION ARGS...).") (define-button-type 'help-function-def :supertype 'help-xref - 'help-function (lambda (fun file) + 'help-function (lambda (fun file &optional type) (require 'find-func) (when (eq file 'C-source) (setq file @@ -199,7 +199,7 @@ The format is (FUNCTION ARGS...).") ;; Don't use find-function-noselect because it follows ;; aliases (which fails for built-in functions). (let ((location - (find-function-search-for-symbol fun nil file))) + (find-function-search-for-symbol fun type file))) (pop-to-buffer (car location)) (if (cdr location) (goto-char (cdr location)) diff --git a/test/ChangeLog b/test/ChangeLog index 8ed02ee341b..c40407f496b 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,13 @@ +2015-01-17 Stefan Monnier + + * automated/eieio-test-methodinvoke.el (eieio-test-cl-generic-1): Reset + eieio-test--1. + + * automated/cl-generic-tests.el (cl-generic-test-8-after/before): + Rename from cl-generic-test-7-after/before. + (cl--generic-test-advice): New function. + (cl-generic-test-9-advice): New test. + 2015-01-16 Jorgen Schaefer * automated/package-test.el (package-test-install-prioritized): diff --git a/test/automated/cl-generic-tests.el b/test/automated/cl-generic-tests.el index 57b17b145e8..46397fb7f51 100644 --- a/test/automated/cl-generic-tests.el +++ b/test/automated/cl-generic-tests.el @@ -129,7 +129,7 @@ (cons "x&y-int" (cl-call-next-method))) (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2)))) -(ert-deftest cl-generic-test-7-after/before () +(ert-deftest cl-generic-test-8-after/before () (let ((log ())) (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((_x t) y) (cons y log)) @@ -142,5 +142,18 @@ (should (equal (cl--generic-1 4 6) '("quatre" 6 (:before 4)))) (should (equal log '((:after 4) (:before 4)))))) +(defun cl--generic-test-advice (&rest args) (cons "advice" (apply args))) + +(ert-deftest cl-generic-test-9-advice () + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 (x y) (list x y)) + (advice-add 'cl--generic-1 :around #'cl--generic-test-advice) + (should (equal (cl--generic-1 4 5) '("advice" 4 5))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "integer" (cl-call-next-method))) + (should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5))) + (advice-remove 'cl--generic-1 #'cl--generic-test-advice) + (should (equal (cl--generic-1 4 5) '("integer" 4 5)))) + (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el index 6362fc5a8d9..1c3d9c34708 100644 --- a/test/automated/eieio-test-methodinvoke.el +++ b/test/automated/eieio-test-methodinvoke.el @@ -384,6 +384,7 @@ (cl-defgeneric eieio-test--1 (x y)) (ert-deftest eieio-test-cl-generic-1 () + (cl-defgeneric eieio-test--1 (x y)) (cl-defmethod eieio-test--1 (x y) (list x y)) (cl-defmethod eieio-test--1 ((_x CNM-0) y) (cons "CNM-0" (cl-call-next-method 7 y))) -- 2.39.2