(ad-get-enabled-advices, ad-special-forms)

(ad-arglist, ad-subr-arglist): Use push and match-string.
(ad-make-advised-docstring): Extract & reinsert the usage info.

1 files changed, 24 insertions, 31 deletions

diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index 1900dff4d6b..a211e1ebba1 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -2116,7 +2116,7 @@ Redefining advices affect the construction of an advised definition."
   (let (enabled-advices)
     (ad-dolist (advice (ad-get-advice-info-field function class))
       (if (ad-advice-enabled advice)
-          (setq enabled-advices (cons advice enabled-advices))))
+          (push advice enabled-advices)))
     (reverse enabled-advices)))
 
 
@@ -2475,7 +2475,7 @@ will clear the cache."
                    with-output-to-temp-buffer)))
     ;; track-mouse could be void in some configurations.
     (if (fboundp 'track-mouse)
-        (setq tem (cons 'track-mouse tem)))
+        (push 'track-mouse tem))
     (mapcar 'symbol-function tem)))
 
 (defmacro ad-special-form-p (definition)
@@ -2545,8 +2545,7 @@ supplied to make subr arglist lookup more efficient."
            ;; otherwise get it from its printed representation:
            (setq name (format "%s" definition))
            (string-match "^#<subr \\([^>]+\\)>$" name)
-           (ad-subr-arglist
-            (intern (substring name (match-beginning 1) (match-end 1))))))))
+           (ad-subr-arglist (intern (match-string 1 name)))))))
 
 ;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish
 ;; a defined empty arglist `(nil)' from an undefined arglist:
@@ -2583,19 +2582,9 @@ that property, or otherwise use `(&rest ad-subr-args)'."
                     (ad-define-subr-args
                      subr-name
                      (cdr (car (read-from-string
-                                (downcase
-                                 (substring doc
-                                            (match-beginning 1)
-                                            (match-end 1)))))))
-                    (ad-get-subr-args subr-name))
-                   ;; this is the old format used before Emacs 19.24:
-                   ((string-match
-                     "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'" doc)
-                    (ad-define-subr-args
-                     subr-name
-                     (car (read-from-string
-                           doc (match-beginning 1) (match-end 1))))
+                                (downcase (match-string 1 doc))))))
                     (ad-get-subr-args subr-name))
+                   ;; This is actually an error.
                    (t '(&rest ad-subr-args)))))))
 
 (defun ad-docstring (definition)
@@ -2999,33 +2988,37 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return
                        (capitalize (symbol-name class))
                        (ad-advice-name advice)))))))
 
+(require 'help-fns)         ;For help-split-fundoc and help-add-fundoc-usage.
+
 (defun ad-make-advised-docstring (function &optional style)
-  ;;"Constructs a documentation string for the advised FUNCTION.
-  ;;It concatenates the original documentation with the documentation
-  ;;strings of the individual pieces of advice which will be formatted
-  ;;according to STYLE.  STYLE can be `plain' or `freeze', everything else
-  ;;will be interpreted as `default'.  The order of the advice documentation
-  ;;strings corresponds to before/around/after and the individual ordering
-  ;;in any of these classes."
+  "Construct a documentation string for the advised FUNCTION.
+It concatenates the original documentation with the documentation
+strings of the individual pieces of advice which will be formatted
+according to STYLE.  STYLE can be `plain' or `freeze', everything else
+will be interpreted as `default'.  The order of the advice documentation
+strings corresponds to before/around/after and the individual ordering
+in any of these classes."
   (let* ((origdef (ad-real-orig-definition function))
          (origtype (symbol-name (ad-definition-type origdef)))
          (origdoc
           ;; Retrieve raw doc, key substitution will be taken care of later:
           (ad-real-documentation origdef t))
-         paragraphs advice-docstring)
+         (usage (help-split-fundoc origdoc function))
+         paragraphs advice-docstring ad-usage)
+    (if usage (setq origdoc (cdr usage) usage (car usage)))
     (if origdoc (setq paragraphs (list origdoc)))
-    (if (not (eq style 'plain))
-        (setq paragraphs (cons (concat "This " origtype " is advised.")
-                               paragraphs)))
+    (unless (eq style 'plain)
+      (push (concat "This " origtype " is advised.") paragraphs))
     (ad-dolist (class ad-advice-classes)
       (ad-dolist (advice (ad-get-enabled-advices function class))
         (setq advice-docstring
               (ad-make-single-advice-docstring advice class style))
         (if advice-docstring
-            (setq paragraphs (cons advice-docstring paragraphs)))))
-    (if paragraphs
-        ;; separate paragraphs with blank lines:
-        (mapconcat 'identity (nreverse paragraphs) "\n\n"))))
+            (push advice-docstring paragraphs))))
+    (setq origdoc (if paragraphs
+                      ;; separate paragraphs with blank lines:
+                      (mapconcat 'identity (nreverse paragraphs) "\n\n")))
+    (help-add-fundoc-usage origdoc usage)))
 
 (defun ad-make-plain-docstring (function)
   (ad-make-advised-docstring function 'plain))