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

@@ -1,3 +1,48 @@
+2015-01-17  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	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  <bruce.connor.am@gmail.com>
 
 	* emacs-lisp/package.el (package--read-pkg-desc): New

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
+(defmacro cl-generic-current-method-specializers ()
-  ;; This is let-bound during macro-expansion of method bodies, so that those
+  "List of (VAR . TYPE) where TYPE is var's specializer.
-  ;; bodies can be optimized knowing that the specializers have matched.
+This macro can only be used within the lexical scope of a cl-generic method."
-  ;; FIXME: This presumes the formal arguments aren't modified via `setq' and
+  (error "cl-generic-current-method-specializers used outside of a method"))
-  ;; 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.")
 
 (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))
+                 (push (cons name (car type)) specializers)
-                       cl-generic-current-method-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)
+    (let ((gfun (cl--generic-make-function generic))
-      (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 `<file>'" 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 "`")
+          (let* ((args (help-function-arglist method 'names))
-          (if (symbolp type)
+                 (docstring (documentation method))
-              ;; FIXME: Add support for cl-structs in help-variable.
+                 (doconly (if docstring
-              (help-insert-xref-button (symbol-name type)
+                              (let ((split (help-split-fundoc docstring nil)))
-				       'help-variable type)
+                                (if split (cdr split) docstring))))
-            (insert (format "%S" type)))
+                 (combined-args ()))
-          (insert (format "' %S %S\n"
+            (if uses-cnm (setq args (cdr args)))
-                          (car qualifier)
+            (dolist (specializer specializers)
-                          (let ((args (help-function-arglist method)))
+              (let ((arg (if (eq '&rest (car args))
-                            ;; Drop cl--generic-next arg if present.
+                             (intern (format "arg%d" (length combined-args)))
-                            (if (memq (car qualifier) '(:after :before))
+                           (pop args))))
-                                args (cdr args)))))
+                (push (if (eq specializer t) arg (list arg specializer))
-          (insert (or (documentation method) "Undocumented") "\n\n"))))))
+                      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 <val>) specializers.
 

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,37 +288,18 @@ 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)))
-
-	  ;; Save parent in child.
-          (push (eieio--class-v SC) (eieio--class-parent newc)))
-
       ;; turn this into a usable self-pointing symbol
       (when eieio-backward-compatibility
         (set cname cname)
@@ -343,16 +311,12 @@ It creates an autoload function for CNAME's constructor."
       ;; 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 (format "%s-p" cname)) filename "" nil nil)
-	(autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil)
+      (when eieio-backward-compatibility
-	(autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil)
+        (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))

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,8 +190,6 @@ 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)
@@ -190,7 +201,7 @@ but remove reference to all implementations of METHOD."
                 (eieio--defgeneric-form-primary-only-one
                  method (car entry) (cdr entry)))
             (eieio--defgeneric-form-primary-only method))
-          (eieio--defgeneric-form 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
+       (defgeneric ,method ,args)
-         ,(or (documentation code)
-              (format "Generically created method `%s'." method)))
        (eieio--defmethod ',method ',key ',class #',code))))
 
 

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,17 +285,20 @@ 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)
+	(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)))))
+                                        (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)
+	    (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
@@ -305,7 +311,7 @@ The search is done in the source for library LIBRARY."
                        (concat "^([^ ]+" find-function-space-re "['(]?"
                                (regexp-quote (symbol-name symbol))
                                "\\_>")
-		     nil t))
+                       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 (if aliases
-              (setq aliases (concat aliases
+                            (concat aliases
                                     (format ", which is an alias for `%s'"
-                                            (symbol-name def))))
+                                            (symbol-name def)))
-            (setq aliases (format "`%s' is an alias for `%s'"
+                          (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)))

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,
+If TYPE is not a symbol, search for a function definition.
- 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))
+                         ;; FIXME: Why do we have this weird "If TYPE is the
-				    type
+                         ;; value returned by `symbol-function' for a function
-				  'defun)))))
+                         ;; 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)

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

test/ChangeLog

@@ -1,3 +1,13 @@
+2015-01-17  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	* 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  <contact@jorgenschaefer.de>
 
 	* automated/package-test.el (package-test-install-prioritized):

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

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