Commit 24c22ecf authored by Stefan Monnier's avatar Stefan Monnier

(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.
parent 95734598
......@@ -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))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment