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.

1 files changed, 80 insertions, 37 deletions

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 `<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 "`")
-          (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 <val>) specializers.