;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*-
-;; Copyright (C) 1993-1994, 2000-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1993-1994, 2000-2014 Free Software Foundation, Inc.
;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Created: 12 Dec 1992
;; Keywords: extensions, lisp, tools
;; Package: emacs
;; {<after-K-1-body-form>}*
;; ad-return-value))
-;; Macros and special forms will be redefined as macros, hence the optional
-;; [macro] in the beginning of the definition.
+;; Macros are redefined as macros, hence the optional [macro] in the
+;; beginning of the definition.
;; <arglist> is either the argument list of the original function or the
;; first argument list defined in the list of before/around/after advices.
;; Advice implements forward advice mainly via the following: 1) Separation
;; of advice definition and activation that makes it possible to accumulate
;; advice information without having the original function already defined,
-;; 2) special versions of the built-in functions `fset/defalias' which check
-;; for advice information whenever they define a function. If advice
-;; information was found then the advice will immediately get activated when
-;; the function gets defined.
+;; 2) Use of the `defalias-fset-function' symbol property which lets
+;; us advise the function when it gets defined.
;; Automatic advice activation means, that whenever a function gets defined
-;; with either `defun', `defmacro', `fset' or by loading a byte-compiled
+;; with either `defun', `defmacro', `defalias' or by loading a byte-compiled
;; file, and the function has some advice-info stored with it then that
;; advice will get activated right away.
;; problems because they get expanded at compile or load time, hence, they
;; might not have all the necessary runtime support and such advice cannot be
;; de/activated or changed as it is possible for functions.
+;;
;; Special forms cannot be advised.
;;
;; MORAL: - Only advise macros when you are absolutely sure what you are doing.
;; flexibility and effectiveness of the advice mechanism. Macros that were
;; compile-time expanded before the advice was activated will of course never
;; exhibit the advised behavior.
-;;
-;; @@ Advising special forms:
-;; ==========================
-;; Now for something that should be even more rare than advising macros:
-;; Advising special forms. Because special forms are irregular in their
-;; argument evaluation behavior (e.g., `setq' evaluates the second but not
-;; the first argument) they have to be advised into macros. A dangerous
-;; consequence of this is that the byte-compiler will not recognize them
-;; as special forms anymore (well, in most cases) and use their expansion
-;; rather than the proper byte-code. Also, because the original definition
-;; of a special form cannot be `funcall'ed, `eval' has to be used instead
-;; which is less efficient.
-;;
-;; MORAL: Do not advise special forms unless you are completely sure about
-;; what you are doing (some of the forward advice behavior is
-;; implemented via advice of the special forms `defun' and `defmacro').
-;; As a safety measure one should always do `ad-deactivate-all' before
-;; one byte-compiles a file to avoid any interference of advised
-;; special forms.
-;;
-;; Apart from the safety concerns advising special forms is not any different
-;; from advising plain functions or subrs.
-
;;; Code:
"Take a macro function DEFINITION and make a lambda out of it."
`(cdr ,definition))
-(defmacro ad-subr-p (definition)
- ;;"non-nil if DEFINITION is a subr."
- (list 'subrp definition))
-
-(defmacro ad-macro-p (definition)
- ;;"non-nil if DEFINITION is a macro."
- `(eq (car-safe ,definition) 'macro))
-
(defmacro ad-lambda-p (definition)
;;"non-nil if DEFINITION is a lambda expression."
`(eq (car-safe ,definition) 'lambda))
(defmacro ad-compiled-p (definition)
"Return non-nil if DEFINITION is a compiled byte-code object."
`(or (byte-code-function-p ,definition)
- (and (ad-macro-p ,definition)
- (byte-code-function-p (ad-lambdafy ,definition)))))
+ (and (macrop ,definition)
+ (byte-code-function-p (ad-lambdafy ,definition)))))
(defmacro ad-compiled-code (compiled-definition)
"Return the byte-code object of a COMPILED-DEFINITION."
- `(if (ad-macro-p ,compiled-definition)
+ `(if (macrop ,compiled-definition)
(ad-lambdafy ,compiled-definition)
,compiled-definition))
"Return the lambda expression of a function/macro/advice DEFINITION."
(cond ((ad-lambda-p definition)
definition)
- ((ad-macro-p definition)
+ ((macrop definition)
(ad-lambdafy definition))
((ad-advice-p definition)
(cdr definition))
"Return the argument list of DEFINITION."
(require 'help-fns)
(help-function-arglist
- (if (or (ad-macro-p definition) (ad-advice-p definition))
+ (if (or (macrop definition) (ad-advice-p definition))
(cdr definition)
definition)
'preserve-names))
(if (ad-interactive-form definition) 1 0))
(cdr (cdr (ad-lambda-expression definition)))))))
-(defun ad-make-advised-definition-docstring (_function)
- "Make an identifying docstring for the advised definition of FUNCTION.
-Put function name into the documentation string so we can infer
-the name of the advised function from the docstring. This is needed
-to generate a proper advised docstring even if we are just given a
-definition (see the code for `documentation')."
- (eval-when-compile
- (propertize "Advice function assembled by advice.el."
- 'dynamic-docstring-function
- #'ad--make-advised-docstring)))
-
-(defun ad-advised-definition-p (definition)
- "Return non-nil if DEFINITION was generated from advice information."
- (if (or (ad-lambda-p definition)
- (ad-macro-p definition)
- (ad-compiled-p definition))
- (let ((docstring (ad-docstring definition)))
- (and (stringp docstring)
- (get-text-property 0 'dynamic-docstring-function docstring)))))
-
(defun ad-definition-type (definition)
"Return symbol that describes the type of DEFINITION."
+ ;; These symbols are only ever used to check a cache entry's validity.
+ ;; The suffix `2' reflects the fact that we're using version 2 of advice
+ ;; representations, so cache entries preactivated with version
+ ;; 1 can't be used.
(cond
- ((ad-macro-p definition) 'macro)
- ((ad-subr-p definition)
- (if (special-form-p definition)
- 'special-form
- 'subr))
- ((or (ad-lambda-p definition)
- (ad-compiled-p definition))
- 'function)
- ((ad-advice-p definition) 'advice)))
+ ((macrop definition) 'macro2)
+ ((subrp definition) 'subr2)
+ ((or (ad-lambda-p definition) (ad-compiled-p definition)) 'fun2)
+ ((ad-advice-p definition) 'advice2))) ;; FIXME: Can this ever happen?
(defun ad-has-proper-definition (function)
"True if FUNCTION is a symbol with a proper definition.
"True if FUNCTION has an interpreted definition that can be compiled."
(and (ad-has-proper-definition function)
(or (ad-lambda-p (symbol-function function))
- (ad-macro-p (symbol-function function)))
+ (macrop (symbol-function function)))
(not (ad-compiled-p (symbol-function function)))))
(defvar warning-suppress-types) ;From warnings.el.
(defun ad-compile-function (function)
"Byte-compile the assembled advice function."
(require 'bytecomp)
- (require 'warnings) ;To define warning-suppress-types before we let-bind it.
(let ((byte-compile-warnings byte-compile-warnings)
;; Don't pop up windows showing byte-compiler warnings.
(warning-suppress-types '((bytecomp))))
(require 'help-fns) ;For help-split-fundoc and help-add-fundoc-usage.
-(defun ad--make-advised-docstring (origdoc function &optional style)
+(defun ad--make-advised-docstring (function &optional style)
"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', 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."
- (if (and (symbolp function)
- (string-match "\\`ad-+Advice-" (symbol-name function)))
- (setq function
- (intern (substring (symbol-name function) (match-end 0)))))
- (let* ((usage (help-split-fundoc origdoc function))
- paragraphs advice-docstring)
- (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage)))
- (if origdoc (setq paragraphs (list origdoc)))
- (dolist (class ad-advice-classes)
- (dolist (advice (ad-get-enabled-advices function class))
- (setq advice-docstring
- (ad-make-single-advice-docstring advice class style))
- (if advice-docstring
- (push advice-docstring paragraphs))))
- (setq origdoc (if paragraphs
- (propertize
- ;; separate paragraphs with blank lines:
- (mapconcat 'identity (nreverse paragraphs) "\n\n")
- ;; FIXME: what is this for?
- 'dynamic-docstring-function
- #'ad--make-advised-docstring)))
- (help-add-fundoc-usage origdoc usage)))
+Concatenate the original documentation with the documentation
+strings of the individual pieces of advice. Optional argument
+STYLE specifies how to format the pieces of advice; it can be
+`plain', or any other value which means the default formatting.
+
+The advice documentation is shown in order of before/around/after
+advice type, obeying the priority in each of these types."
+ ;; Retrieve the original function documentation
+ (let* ((fun (get function 'function-documentation))
+ (origdoc (unwind-protect
+ (progn (put function 'function-documentation nil)
+ (documentation function t))
+ (put function 'function-documentation fun))))
+ (if (and (symbolp function)
+ (string-match "\\`ad-+Advice-" (symbol-name function)))
+ (setq function
+ (intern (substring (symbol-name function) (match-end 0)))))
+ (let* ((usage (help-split-fundoc origdoc function))
+ paragraphs advice-docstring)
+ (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage)))
+ (if origdoc (setq paragraphs (list origdoc)))
+ (dolist (class ad-advice-classes)
+ (dolist (advice (ad-get-enabled-advices function class))
+ (setq advice-docstring
+ (ad-make-single-advice-docstring advice class style))
+ (if advice-docstring
+ (push advice-docstring paragraphs))))
+ (setq origdoc (if paragraphs
+ (mapconcat 'identity (nreverse paragraphs)
+ "\n\n")))
+ (help-add-fundoc-usage origdoc usage))))
;; @@@ Accessing overriding arglists and interactive forms:
(ad-has-redefining-advice function))
(let* ((origdef (ad-real-orig-definition function))
;; Construct the individual pieces that we need for assembly:
- (orig-arglist (and origdef (ad-arglist origdef)))
+ (orig-arglist (let ((args (ad-arglist origdef)))
+ ;; The arglist may still be unknown.
+ (if (listp args) args '(&rest args))))
(advised-arglist (or (ad-advised-arglist function)
orig-arglist))
(interactive-form (ad-advised-interactive-form function))
;; Finally, build the sucker:
(ad-assemble-advised-definition
advised-arglist
- (ad-make-advised-definition-docstring function)
+ nil
interactive-form
orig-form
(ad-get-enabled-advices function 'before)
(defun ad-preactivate-advice (function advice class position)
"Preactivate FUNCTION and returns the constructed cache."
- (let* ((function-defined-p (fboundp function))
- (old-definition
- (if function-defined-p
- (symbol-function function)))
+ (let* ((advicefunname (ad-get-advice-info-field function 'advicefunname))
+ (old-advice (symbol-function advicefunname))
(old-advice-info (ad-copy-advice-info function))
(ad-advised-functions ad-advised-functions))
(unwind-protect
(list (ad-get-cache-definition function)
(ad-get-cache-id function))))
(ad-set-advice-info function old-advice-info)
- ;; Don't `fset' function to nil if it was previously unbound:
- (if function-defined-p
- (fset function old-definition)
- (fmakunbound function)))))
+ (advice-remove function advicefunname)
+ (fset advicefunname old-advice)
+ (if old-advice (advice-add function :around advicefunname)))))
;; @@ Activation and definition handling:
If COMPILE is a negative number then it returns nil.
If COMPILE is nil then the result depends on the value of
`ad-default-compilation-action' (which see)."
- (if (integerp compile)
- (>= compile 0)
- (if compile
- compile
- (cond ((eq ad-default-compilation-action 'never)
- nil)
- ((eq ad-default-compilation-action 'always)
- t)
- ((eq ad-default-compilation-action 'like-original)
- (or (ad-subr-p (ad-get-orig-definition function))
- (ad-compiled-p (ad-get-orig-definition function))))
- ;; everything else means `maybe':
- (t (featurep 'byte-compile))))))
+ (cond
+ ;; Don't compile until the real function definition is known (bug#12965).
+ ((not (ad-real-orig-definition function)) nil)
+ ((integerp compile) (>= compile 0))
+ (compile)
+ ((eq ad-default-compilation-action 'never) nil)
+ ((eq ad-default-compilation-action 'always) t)
+ ((eq ad-default-compilation-action 'like-original)
+ (or (subrp (ad-get-orig-definition function))
+ (ad-compiled-p (ad-get-orig-definition function))))
+ ;; everything else means `maybe':
+ (t (featurep 'byte-compile))))
(defun ad-activate-advised-definition (function compile)
"Redefine FUNCTION with its advised definition from cache or scratch.
The resulting FUNCTION will be compiled if `ad-should-compile' returns t.
The current definition and its cache-id will be put into the cache."
- (let ((verified-cached-definition
- (if (ad-verify-cache-id function)
- (ad-get-cache-definition function)))
- (advicefunname (ad-get-advice-info-field function 'advicefunname)))
+ (let* ((verified-cached-definition
+ (if (ad-verify-cache-id function)
+ (ad-get-cache-definition function)))
+ (advicefunname (ad-get-advice-info-field function 'advicefunname))
+ (old-ispec (interactive-form advicefunname)))
(fset advicefunname
(or verified-cached-definition
(ad-make-advised-definition function)))
+ (put advicefunname 'function-documentation
+ `(ad--make-advised-docstring ',advicefunname))
+ (unless (equal (interactive-form advicefunname) old-ispec)
+ ;; If the interactive-spec of advicefunname has changed, force nadvice to
+ ;; refresh its copy.
+ (advice-remove function advicefunname))
(advice-add function :around advicefunname)
(if (ad-should-compile function compile)
- (byte-compile advicefunname))
+ (ad-compile-function function))
(if verified-cached-definition
(if (not (eq verified-cached-definition
(symbol-function advicefunname)))
(interactive
(list (ad-read-advised-function "Activate advice of")
current-prefix-arg))
- (if (not (ad-is-advised function))
- (error "ad-activate: `%s' is not advised" function)
- ;; Just return for forward advised and not yet defined functions:
- (if (ad-get-orig-definition function)
- (if (not (ad-has-any-advice function))
- (ad-unadvise function)
- ;; Otherwise activate the advice:
- (cond ((ad-has-redefining-advice function)
- (ad-activate-advised-definition function compile)
- (ad-set-advice-info-field function 'active t)
- (eval (ad-make-hook-form function 'activation))
- function)
- ;; Here we are if we have all disabled advices:
- (t (ad-deactivate function)))))))
+ (cond
+ ((not (ad-is-advised function))
+ (error "ad-activate: `%s' is not advised" function))
+ ;; Just return for forward advised and not yet defined functions:
+ ((not (ad-get-orig-definition function)) nil)
+ ((not (ad-has-any-advice function)) (ad-unadvise function))
+ ;; Otherwise activate the advice:
+ ((ad-has-redefining-advice function)
+ (ad-activate-advised-definition function compile)
+ (ad-set-advice-info-field function 'active t)
+ (eval (ad-make-hook-form function 'activation))
+ function)
+ ;; Here we are if we have all disabled advices:
+ (t (ad-deactivate function))))
(defalias 'ad-activate-on 'ad-activate)
usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
[DOCSTRING] [INTERACTIVE-FORM]
BODY...)"
- (declare (doc-string 3)
+ (declare (doc-string 3) (indent 2)
(debug (&define name ;; thing being advised.
(name ;; class is [&or "before" "around" "after"
;; "activation" "deactivation"]
`((ad-set-cache
',function
;; the function will get compiled:
- ,(cond ((ad-macro-p (car preactivation))
+ ,(cond ((macrop (car preactivation))
`(ad-macrofy
(function
,(ad-lambdafy
HCoop / bpt / emacs.git / blobdiff