;;; 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 <hans@cs.buffalo.edu>
;; Maintainer: FSF
(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)))
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)
;; 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:
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."
;; Need to turn off auto-activation
;; because `byte-compile' uses `fset':
(ad-with-auto-activation-disabled
- (let ((symbol (make-symbol "advice-compilation")))
+ (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))))))
(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))
;; 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
(provide 'advice)
+;;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0
;;; advice.el ends here