X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/8a9463543d5b82409a24e23905d271cdebf70059..44b254cc4f3aa7a3f14691f0098782c35c0abdab:/lisp/emacs-lisp/advice.el diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 36ae0e3388..7686722c5b 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,6 +1,6 @@ ;;; advice.el --- an overloading mechanism for Emacs Lisp functions -;; Copyright (C) 1993,1994,2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1993,1994,2000,01,2004 Free Software Foundation, Inc. ;; Author: Hans Chalupsky ;; Maintainer: FSF @@ -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 "^#]+\\)>$" 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: @@ -2564,39 +2563,31 @@ supplied to make subr arglist lookup more efficient." Either use the one stored under the `ad-subr-arglist' property, or try to retrieve it from the docstring and cache it under that property, or otherwise use `(&rest ad-subr-args)'." - (cond ((ad-subr-args-defined-p subr-name) - (ad-get-subr-args subr-name)) - ;; says jwz: Should use this for Lemacs 19.8 and above: - ;;((fboundp 'subr-min-args) - ;; ...) - ;; says hans: I guess what Jamie means is that I should use the values - ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist - ;; without having to look it up via parsing the docstring, e.g., - ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an - ;; argument list. However, that won't work because there is no - ;; way to distinguish a subr with args `(a &optional b &rest c)' from - ;; one with args `(a &rest c)' using that mechanism. Also, the argument - ;; names from the docstring are more meaningful. Hence, I'll stick with - ;; the old way of doing things. - (t (let ((doc (or (ad-real-documentation subr-name t) ""))) - (cond ((string-match "^\\(([^\)]+)\\)\n?\\'" doc) - (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)))) - (ad-get-subr-args subr-name)) - (t '(&rest ad-subr-args))))))) + (if (ad-subr-args-defined-p subr-name) + (ad-get-subr-args subr-name) + ;; says jwz: Should use this for Lemacs 19.8 and above: + ;;((fboundp 'subr-min-args) + ;; ...) + ;; says hans: I guess what Jamie means is that I should use the values + ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist + ;; without having to look it up via parsing the docstring, e.g., + ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an + ;; argument list. However, that won't work because there is no + ;; way to distinguish a subr with args `(a &optional b &rest c)' from + ;; one with args `(a &rest c)' using that mechanism. Also, the argument + ;; names from the docstring are more meaningful. Hence, I'll stick with + ;; the old way of doing things. + (let ((doc (or (ad-real-documentation subr-name t) ""))) + (if (not (string-match "\n\n\\((.+)\\)\\'" doc)) + ;; Signalling an error leads to bugs during bootstrapping because + ;; the DOC file is not yet built (which is an error, BTW). + ;; (error "The usage info is missing from the subr %s" subr-name) + '(&rest ad-subr-args) + (ad-define-subr-args + subr-name + (cdr (car (read-from-string + (downcase (match-string 1 doc)))))) + (ad-get-subr-args subr-name))))) (defun ad-docstring (definition) "Return the unexpanded docstring of DEFINITION." @@ -2698,7 +2689,17 @@ For that it has to be fbound with a non-autoload definition." ;; Need to turn off auto-activation ;; because `byte-compile' uses `fset': (ad-with-auto-activation-disabled - (byte-compile function)))) + (require 'bytecomp) + (let ((symbol (make-symbol "advice-compilation")) + (byte-compile-warnings + (if (listp byte-compile-warnings) byte-compile-warnings + byte-compile-warning-types))) + (if (featurep 'cl) + (setq byte-compile-warnings + (remq 'cl-functions byte-compile-warnings))) + (fset symbol (symbol-function function)) + (byte-compile symbol) + (fset function (symbol-function symbol)))))) ;; @@ Constructing advised definitions: @@ -2989,33 +2990,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) + (setq usage (if (null usage) t (setq origdoc (cdr 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)) @@ -3922,6 +3927,10 @@ undone on exit of this macro." ;; Use the advice mechanism to advise `documentation' to make it ;; generate proper documentation strings for advised definitions: +;; This makes sure we get the right arglist for `documentation' +;; during bootstrapping. +(ad-define-subr-args 'documentation '(function &optional raw)) + (defadvice documentation (after ad-advised-docstring first disable preact) "Builds an advised docstring if FUNCTION is advised." ;; Because we get the function name from the advised docstring @@ -3976,4 +3985,5 @@ Use only in REAL emergencies." (provide 'advice) +;;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0 ;;; advice.el ends here