-;;; advice.el --- advice mechanism for Emacs Lisp functions
+;;; advice.el --- an overloading mechanism for Emacs Lisp functions
-;; Copyright (C) 1993 Free Software Foundation, Inc.
+;; Copyright (C) 1993,1994,2000, 2001 Free Software Foundation, Inc.
;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
+;; Maintainer: FSF
;; Created: 12 Dec 1992
-;; Version: advice.el,v 2.1 1993/05/26 00:07:58 hans Exp
-;; Keywords: extensions
+;; Keywords: extensions, lisp, tools
;; This file is part of GNU Emacs.
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;; LCD Archive Entry:
;; advice|Hans Chalupsky|hans@cs.buffalo.edu|
-;; Advice mechanism for Emacs Lisp functions|
-;; 1993/05/26 00:07:58|2.1|~/packages/advice.el.Z|
+;; Overloading mechanism for Emacs Lisp functions|
+;; 1994/08/05 03:42:04|2.14|~/packages/advice.el.Z|
;;; Commentary:
+;; NOTE: This documentation is slightly out of date. In particular, all the
+;; references to Emacs-18 are obsolete now, because it is not any longer
+;; supported by this version of Advice.
+
+;; Advice is documented in the Emacs Lisp Manual.
+
;; @ Introduction:
;; ===============
;; This package implements a full-fledged Lisp-style advice mechanism
-;; for Emacs Lisp. Advice is a clean and efficient way to modify the
+;; for Emacs Lisp. Advice is a clean and efficient way to modify the
;; behavior of Emacs Lisp functions without having to keep personal
-;; modified copies of such functions around. A great number of such
-;; modifications can be achieved by treating the original function as a
-;; black box and specifying a different execution environment for it
+;; modified copies of such functions around. A great number of such
+;; modifications can be achieved by treating the original function as a
+;; black box and specifying a different execution environment for it
;; with a piece of advice. Think of a piece of advice as a kind of fancy
;; hook that you can attach to any function/macro/subr.
;; the binding environment in which it will be executed, as well as the
;; value it will return.
;; - Allows re/definition of interactive behavior for functions and subrs
-;; - Every piece of advice can have its documentation string which will be
+;; - Every piece of advice can have its documentation string which will be
;; combined with the original documentation of the advised function at
;; call-time of `documentation' for proper command-key substitution.
;; - The execution of every piece of advice can be protected against error
;; - Advised functions can be byte-compiled either at file-compile time
;; (see preactivation) or activation time.
;; - Separation of advice definition and activation
-;; - Provides generally accessible function definition (after) hooks
-;; - Forward advice is possible (an application of definition hooks), that is
+;; - Forward advice is possible, that is
;; as yet undefined or autoload functions can be advised without having to
-;; preload the file in which they are defined.
+;; preload the file in which they are defined.
;; - Forward redefinition is possible because around advice can be used to
;; completely redefine a function.
;; - A caching mechanism for advised definition provides for cheap deactivation
;; the advice mechanism.
;; - En/disablement mechanism allows the use of different "views" of advised
;; functions depending on what pieces of advice are currently en/disabled
-;; - Provides manipulation mechanisms for sets of advised functions via
+;; - Provides manipulation mechanisms for sets of advised functions via
;; regular expressions that match advice names
-;; - Allows definition of load-hooks for arbitrary Emacs Lisp files without
-;; modification of these files
-;; @ How to get the latest advice.el:
-;; ==================================
-;; You can get the latest version of this package either via anonymous ftp
-;; from ftp.cs.buffalo.edu (128.205.32.9) with pathname /pub/Emacs/advice.el,
-;; or send email to hans@cs.buffalo.edu and I'll mail it to you.
+;; @ How to get Advice for Emacs-18:
+;; =================================
+;; `advice18.el', a version of Advice that also works in Emacs-18 is available
+;; either via anonymous ftp from `ftp.cs.buffalo.edu (128.205.32.9)' with
+;; pathname `/pub/Emacs/advice18.el', or from one of the Emacs Lisp archive
+;; sites, or send email to <hans@cs.buffalo.edu> and I'll mail it to you.
;; @ Overview, or how to read this file:
;; =====================================
-;; Advice has enough features now to justify an info file, however, I
-;; didn't have the time yet to do all the necessary formatting. So,
-;; until I do have the time or some kind soul does it for me I crammed
-;; everything into the source file. Because about 50% of this file is
-;; documentation it should be in outline-mode by default, but it is not.
-;; If you choose to use outline-mode set `outline-regexp' to `";; @+"'
-;; and use `M-x hide-body' to see just the headings. Use the various
-;; other outline-mode functions to move around in the text. If you use
-;; Lucid Emacs, you'll just have to wait until `selective-display'
-;; works properly in order to be able to use outline-mode, sorry.
-;;
-;; And yes, I know: Documentation is for wimps.
+;; NOTE: This documentation is slightly out of date. In particular, all the
+;; references to Emacs-18 are obsolete now, because it is not any longer
+;; supported by this version of Advice. An up-to-date version will soon be
+;; available as an info file (thanks to the kind help of Jack Vinson and
+;; David M. Smith). Until then you can use `outline-mode' to help you read
+;; this documentation (set `outline-regexp' to `";; @+"').
;;
;; The four major sections of this file are:
;;
;; @ This initial information ...installation, customization etc.
;; @ Advice documentation: ...general documentation
-;; @ Foo games: An advice tutorial ...teaches about advice by example
+;; @ Foo games: An advice tutorial ...teaches about Advice by example
;; @ Advice implementation: ...actual code, yeah!!
;;
;; The latter three are actual headings which you can search for
-;; directly in case outline-mode doesn't work for you.
+;; directly in case `outline-mode' doesn't work for you.
;; @ Restrictions:
;; ===============
+;; - This version of Advice only works for Emacs 19.26 and later. It uses
+;; new versions of the built-in functions `fset/defalias' which are not
+;; yet available in Lucid Emacs, hence, it won't work there.
;; - Advised functions/macros/subrs will only exhibit their advised behavior
;; when they are invoked via their function cell. This means that advice will
;; not work for the following:
-;; + advised subrs that are called directly from other subrs or C-code
-;; + advised subrs that got replaced with their byte-code during
+;; + advised subrs that are called directly from other subrs or C-code
+;; + advised subrs that got replaced with their byte-code during
;; byte-compilation (e.g., car)
;; + advised macros which were expanded during byte-compilation before
;; their advice was activated.
-;; - This package was developed under GNU Emacs 18.59 and Lucid Emacs 19.6.
-;; It was adapted and tested for GNU Emacs 19.8 and seems to work ok for
-;; Epoch 4.2. For different Emacs environments your mileage may vary.
;; @ Credits:
;; ==========
;; =====================================
;; If you find any bugs, have suggestions for new advice features, find the
;; documentation wrong, confusing, incomplete, or otherwise unsatisfactory,
-;; have any questions about advice.el, or have otherwise enlightening
+;; have any questions about Advice, or have otherwise enlightening
;; comments feel free to send me email at <hans@cs.buffalo.edu>.
;; @ Safety Rules and Emergency Exits:
;; ===================================
;; Before we begin: CAUTION!!
-;; advice.el provides you with a lot of rope to hang yourself on very
+;; Advice provides you with a lot of rope to hang yourself on very
;; easily accessible trees, so, here are a few important things you
-;; should know: Once advice has been started with `ad-start-advice' it
-;; generates advised definitions of the `documentation' function, and,
-;; if definition hooks are enabled (e.g., for forward advice), also of
-;; `defun', `defmacro' and `fset' (if you use Jamie Zawinski's (jwz)
-;; optimizing byte-compiler as standardly used in GNU Emacs-19 and
-;; Lucid Emacs-19 (Lemacs), then enabling definition hooks will also
-;; redefine the `byte-code' subr). All these changes can be undone at
-;; any time with `M-x ad-stop-advice'.
-;;
+;; should know: Once Advice has been started with `ad-start-advice'
+;; (which happens automatically when you load this file), it
+;; generates an advised definition of the `documentation' function, and
+;; it will enable automatic advice activation when functions get defined.
+;; All of this can be undone at any time with `M-x ad-stop-advice'.
+;;
;; If you experience any strange behavior/errors etc. that you attribute to
-;; advice.el or to some ill-advised function do one of the following:
+;; Advice or to some ill-advised function do one of the following:
;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what
;; function gives you problems)
;; - M-x ad-deactivate-all (if you don't have a clue what's going wrong)
;; - M-x ad-stop-advice (if you think the problem is related to the
-;; advised functions used by advice.el itself)
+;; advised functions used by Advice itself)
;; - M-x ad-recover-normality (for real emergencies)
-;; - If none of the above solves your advice related problem go to another
+;; - If none of the above solves your Advice-related problem go to another
;; terminal, kill your Emacs process and send me some hate mail.
;; The first three measures have restarts, i.e., once you've figured out
;; everything so you won't be able to reactivate any advised functions, you'll
;; have to stick with their standard incarnations for the rest of the session.
-;; IMPORTANT: With advice.el loaded always do `M-x ad-deactivate-all' before
+;; IMPORTANT: With Advice loaded always do `M-x ad-deactivate-all' before
;; you byte-compile a file, because advised special forms and macros can lead
;; to unwanted compilation results. When you are done compiling use
-;; `M-x ad-activate-all' to go back to the advised state of all your
+;; `M-x ad-activate-all' to go back to the advised state of all your
;; advised functions.
-;; RELAX: advice.el is pretty safe even if you are oblivious to the above.
+;; RELAX: Advice is pretty safe even if you are oblivious to the above.
;; I use it extensively and haven't run into any serious trouble in a long
;; time. Just wanted you to be warned.
-;; @ Installation:
-;; ===============
-;; Put this file somewhere into your Emacs `load-path' and byte-compile it.
-;; Both steps are mandatory! You cannot (and would not want to) run advice
-;; uncompiled, and because there is bootstrapping going on the byte-compiler
-;; needs to preload advice in order to compile it, hence, it has to find it
-;; in your `load-path' (you can preload advice.el "by hand" before you compile
-;; it if you don't want to put it into your `load-path'). Once you have
-;; compiled advice put the following autoload declarations into your .emacs
-;; to load it on demand
-;;
-;; (autoload 'defadvice "advice" "Define a piece of advice" nil t)
-;; (autoload 'ad-add-advice "advice" "Add a piece of advice")
-;; (autoload 'ad-start-advice "advice" "Start advice magic" t)
-;;
-;; or explicitly load it with (require 'advice) or (load "advice").
-
-;; @@ Preloading:
-;; ==============
-;; If you preload the complete advice.el or its autoloads into a dumped Emacs
-;; image and you use jwz's byte-compiler make sure advice gets loaded after the
-;; byte-compiler runtime support is loaded so that `ad-use-jwz-byte-compiler'
-;; receives the proper initial value.
-
;; @ Customization:
;; ================
-;; Part of the advice magic does not start until you call `ad-start-advice'
-;; which you can either do interactively, explicitly in your .emacs, or by
-;; putting
-;;
-;; (setq ad-start-advice-on-load t)
-;;
-;; into your .emacs which will automatically start advice when the file gets
-;; loaded.
-
-;; If you want to be able to forward advise functions, that is to advise them
-;; when they are not yet defined or defined as autoloads, then you should put
-;; the following into your .emacs
-;;
-;; (setq ad-activate-on-definition t)
-;;
-;; which will activate all advice at the time the function gets actually
-;; defined/loaded. The value of this variable will not have any effect until
-;; `ad-start-advice' gets executed.
-
-;; If you use a v18 Emacs but use jwz's byte-compiler and want to use
-;; forward advice make sure that `ad-use-jwz-byte-compiler' has a non-NIL
-;; value after advice.el got loaded. If it doesn't set it explicitly in
-;; your .emacs with
-;;
-;; (setq ad-use-jwz-byte-compiler t)
-;;
-;; Also make sure that you read the paragraph on forward advice below to
-;; find out about the trade-offs involved for this combination of features.
;; Look at the documentation of `ad-redefinition-action' for possible values
;; of this variable. Its default value is `warn' which will print a warning
;; message when an already defined advised function gets redefined with a
;; new original definition and de/activated.
+;; Look at the documentation of `ad-default-compilation-action' for possible
+;; values of this variable. Its default value is `maybe' which will compile
+;; advised definitions during activation in case the byte-compiler is already
+;; loaded. Otherwise, it will leave them uncompiled.
+
;; @ Motivation:
;; =============
;; Before I go on explaining how advice works, here are four simple examples
;; is just a joke:
;;(defadvice switch-to-buffer (before existing-buffers-only activate)
-;; "When called interactively switch to existing buffers only, unless
+;; "When called interactively switch to existing buffers only, unless
;;when called with a prefix argument."
-;; (interactive
-;; (list (read-buffer "Switch to buffer: " (other-buffer)
+;; (interactive
+;; (list (read-buffer "Switch to buffer: " (other-buffer)
;; (null current-prefix-arg)))))
;;
;;(defadvice switch-to-buffer (around confirm-non-existing-buffers activate)
;; @@ Terminology:
;; ===============
-;; - GNU Emacs-19: GNU's version of Emacs with major version 19
+;; - Emacs, Emacs-19: Emacs as released by the GNU Project
;; - Lemacs: Lucid's version of Emacs with major version 19
;; - v18: Any Emacs with major version 18 or built as an extension to that
;; (such as Epoch)
;; - v19: Any Emacs with major version 19
-;; - jwz: Jamie Zawinski - keeper of Lemacs and creator of the optimizing
+;; - jwz: Jamie Zawinski - former keeper of Lemacs and creator of the optimizing
;; byte-compiler used in v19s.
+;; - Advice: The name of this package.
;; - advices: Short for "pieces of advice".
;; @@ Defining a piece of advice with `defadvice':
;; `around', `after', `activation' or `deactivation' (the last two allow
;; definition of special act/deactivation hooks).
-;; <name> is the name of the advice which has to be a non-NIL symbol.
+;; <name> is the name of the advice which has to be a non-nil symbol.
;; Names uniquely identify a piece of advice in a certain advice class,
;; hence, advices can be redefined by defining an advice with the same class
;; and name. Advice names are global symbols, hence, the same name space
;; advice. All flags can be specified with unambiguous initial substrings.
;; `activate': Specifies that the advice information of the advised
;; function should be activated right after this advice has been
-;; defined. In forward advices `activate' will be ignored.
+;; defined. In forward advices `activate' will be ignored.
;; `protect': Specifies that this advice should be protected against
;; non-local exits and errors in preceding code/advices.
;; `compile': Specifies that the advised function should be byte-compiled.
;; A possibly empty list of <body-forms> specifies the body of the advice in
;; an implicit progn. The body of an advice can access/change arguments,
-;; the return value, the binding environment, and can have all sorts of
+;; the return value, the binding environment, and can have all sorts of
;; other side effects.
;; @@ Assembling advised definitions:
;; If this is a problem one can always specify an interactive form in a
;; before/around/after advice to gain control over argument values that
;; were supplied interactively.
-;;
+;;
;; Then the body forms of the various advices in the various classes of advice
;; are assembled in order. The forms of around advice L are normally part of
;; one of the forms of around advice L-1. An around advice can specify where
;; keyword `ad-do-it', which will be substituted with a `progn' containing the
;; forms of the surrounded code.
-;; The innermost part of the around advice onion is
+;; The innermost part of the around advice onion is
;; <apply original definition to <arglist>>
;; whose form depends on the type of the original function. The variable
;; `ad-return-value' will be set to its result. This variable is visible to
;; all pieces of advice which can access and modify it before it gets returned.
-;;
+;;
;; The semantic structure of advised functions that contain protected pieces
;; of advice is the same. The only difference is that `unwind-protect' forms
;; make sure that the protected advice gets executed even if some previous
;; `(&rest ad-subr-args)' as the argument list of the original function
;; (depending on what Emacs version is used). Hence SYM and NEWDEF have to
;; be properly mapped onto the &rest variable when the original definition is
-;; called. Advice automatically takes care of that mapping, hence, the advice
+;; called. Advice automatically takes care of that mapping, hence, the advice
;; programmer can specify an argument list without having to know about the
;; exact structure of the original argument list as long as the new argument
;; list takes a compatible number/magnitude of actual arguments.
;; know the argument list of the original function. For functions and macros
;; the argument list can be determined from the actual definition, however,
;; for subrs there is no such direct access available. In Lemacs and for some
-;; subrs in GNU Emacs-19 the argument list of a subr can be determined from
+;; subrs in Emacs-19 the argument list of a subr can be determined from
;; its documentation string, in a v18 Emacs even that is not possible. If
;; advice cannot at all determine the argument list of a subr it uses
;; `(&rest ad-subr-args)' which will always work but is inefficient because
;; The advised definition will get compiled either if `ad-activate' was called
;; interactively with a prefix argument, or called explicitly with its second
-;; argument as t, or, if this was a case of forward advice if the original
-;; definition of the function was compiled. If the advised definition was
+;; argument as t, or, if `ad-default-compilation-action' justifies it according
+;; to the current system state. If the advised definition was
;; constructed during "preactivation" (see below) then that definition will
;; be already compiled because it was constructed during byte-compilation of
;; the file that contained the `defadvice' with the `preactivate' flag.
;; match for the regular expression. To enable ange-ftp again we would use
;; `ad-enable-regexp' and then activate or update again.
-;; @@ Forward advice, function definition hooks:
-;; =============================================
+;; @@ Forward advice, automatic advice activation:
+;; ===============================================
;; Because most Emacs Lisp packages are loaded on demand via an autoload
;; mechanism it is essential to be able to "forward advise" functions.
;; Otherwise, proper advice definition and activation would make it necessary
;; 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 function defining functions `defun', `defmacro'
-;; and `fset' that check for advice information whenever they define a
-;; function. If advice information was found and forward advice is enabled
-;; then the advice will immediately get activated when the function gets
-;; 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.
-;; @@@ Enabling forward advice:
-;; ============================
-;; Forward advice is enabled by setting `ad-activate-on-definition' to t
-;; and then calling `ad-start-advice' which can either be done interactively,
-;; directly with `(ad-start-advice)' in your .emacs, or by setting
-;; `ad-start-advice-on-load' to t before advice gets loaded. For example,
-;; putting the following into your .emacs will enable forward advice:
-;;
-;; (setq ad-start-advice-on-load t)
-;; (setq ad-activate-on-definition t)
-;;
-;; "Activation on definition" means, that whenever a function gets defined
+;; Automatic advice activation means, that whenever a function gets defined
;; with either `defun', `defmacro', `fset' 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.
-;; If jwz's byte-compiler is used then `ad-use-jwz-byte-compiler' should
-;; be t in order to make forward advice work with functions defined in
-;; compiled files generated by that compiler. In v19s which use this
-;; compiler the value of this variable will be correct automatically.
-;; If you use a v18 Emacs in conjunction with jwz's compiler and you want
-;; to use forward advice then you should check its value after loading
-;; advice. If it is nil set it explicitly with
-;;
-;; (setq ad-use-jwz-byte-compiler t)
-;;
-;; along with `ad-activate-on-definition' before you start advice (see above).
-
-;; IMPORTANT: A v18 Emacs + jwz's compiler + forward advice means performance
-;; tradeoffs which are described below.
-
-;; @@@ Forward advice with compiled files generated by jwz's byte-compiler:
-;; ========================================================================
-;; The v18 byte-compiler only uses `defun/defmacro' to define compiled
-;; functions, hence, providing advised versions of these functions was
-;; sufficient to achieve forward advice. With the advent of Jamie Zawinski's
-;; optimizing byte-compiler which is now standardly used in GNU Emacs-19 and
-;; Lemacs things became more complicated. jwz's compiler defines functions
-;; in hunks of byte-code without explicit usage of `defun/defmacro'. To
-;; still provide forward advice even in this scenario, advice defines an
-;; advised version of the `byte-code' subr that scans its arguments for
-;; function definitions during the loading of compiled files. While this is
-;; no problem in a v19 Emacs, because it uses a new datatype for compiled
-;; code objects and the `byte-code' subr is only rarely used at all, it
-;; presents a major problem in a v18 Emacs because there calls to
-;; `byte-code' are the only means of executing compiled code (every body of
-;; a compiled function contains a call to `byte-code'). Because the advised
-;; `byte-code' has to perform some extra checks every call to a compiled
-;; function becomes more expensive.
-
-;; Enabling forward advice leads to performance degradation in the following
-;; situations:
-;; - A v18 Emacs is used and the value of `ad-use-jwz-byte-compiler' is t
-;; (either because jwz's byte-compiler is used instead of the standard v18
-;; compiler, or some compiled files generated by jwz's compiler are used).
-;; - A v19 Emacs is used with some old-style v18 compiled files.
-;; Some performance experiments I conducted showed that function call intensive
-;; code (such as the highly recursive byte-compiler itself) slows down by a
-;; factor of 1.8. Function call intensive code that runs while a file gets
-;; loaded can slow down by a factor of 6! For the v19 scenario this performance
-;; lossage would only apply to code that was loaded from old v18 compiled
-;; files.
-
-;; MORAL: If you use a v18 Emacs in conjunction with jwz's byte-compiler you
-;; should think twice whether you really need forward advice. There are some
-;; alternatives to forward advice described below that might give you what
-;; you need without the loss of performance (that performance loss probably
-;; outweighs by far any performance gain due to the optimizing nature of jwz's
-;; compiler).
-
-;; @@@ Alternatives to automatic activation of forward advice:
-;; ===========================================================
-;; If you use a v18 Emacs in conjunction with jwz's compiler, or you simply
-;; don't trust the automatic activation mechanism of forward advice, then
-;; you can use some of the following alternatives to get around that:
-;; - Preload the file that contains the definition of the function that you
-;; want to advice. Inelegant and wasteful, but it works.
-;; - If the package that contains the definition of the function you want to
-;; advise has any mode hooks, and the advised function is only used once such
-;; a mode has been entered, then you can activate the advice in the mode
-;; hook. Just put a form like `(ad-activate 'my-advised-fn t)' into the
-;; hook definition. The caching mechanism will reuse advised definitions,
-;; so calling that mode hook over and over again will not construct
-;; advised definitions over and over again, so you won't loose any
-;; performance.
-;; - If your Emacs comes with file load hooks (such as v19's
-;; `after-load-alist' mechanism), then you can put the activation form
-;; into that, for example, add `("myfile" (ad-activate 'my-advised-fn t))'
-;; to it to activate the advice right ater "myfile" got loaded.
-
-;; @@@ Function definition hooks:
-;; ==============================
-;; Automatic activation of forward advice is implemented as an application
-;; of a more general function definition hook mechanism. After a function
-;; gets re/defined with `defun/defmacro/fset' or via a hunk of byte-code
-;; during the loading of a byte-compiled file, and function definition hooks
-;; are enabled, then all hook functions stored in `ad-definition-hooks' are
-;; run with the variable `ad-defined-function' bound to the name of the
-;; currently defined function.
-
-;; Function definition hooks can be enabled with
-;;
-;; (setq ad-enable-definition-hooks t)
-;;
-;; before advice gets started with `ad-start-advice'. Setting
-;; `ad-activate-on-definition' to t automatically enables definition hooks
-;; regardless of the value of `ad-enable-definition-hooks'.
-
-;; @@@ Wish list:
-;; ==============
-;; - The implementation of definition hooks for v19 compiled files would be
-;; safer if jwz's byte-compiler used something like `byte-code-tl' instead
-;; of `byte-code' to execute hunks of function defining byte-code at the
-;; top level of compiled files.
-;; - Definition hooks should be implemented directly as part of the C-code
-;; that implements `fset', because then advice.el wouldn't have to use all
-;; these dirty hacks to achieve this functionality.
+;; @@@ Enabling automatic advice activation:
+;; =========================================
+;; Automatic advice activation is enabled by default. It can be disabled by
+;; doint `M-x ad-stop-advice' and enabled again with `M-x ad-start-advice'.
;; @@ Caching of advised definitions:
;; ==================================
;; verification failed which should give you enough information to
;; fix your preactivation/compile/load/activation sequence.
-;; IMPORTANT: There is one case (that I am aware of) that can make
+;; IMPORTANT: There is one case (that I am aware of) that can make
;; preactivation fail, i.e., a preconstructed advised definition that does
;; NOT match the current state of advice gets used nevertheless. That case
;; arises if one package defines a certain piece of advice which gets used
-;; during preactivation, and another package incompatibly redefines that
+;; during preactivation, and another package incompatibly redefines that
;; very advice (i.e., same function/class/name), and it is the second advice
;; that is available when the preconstructed definition gets activated, and
-;; that was the only definition of that advice so far (`ad-add-advice'
-;; catches advice redefinitions and clears the cache in such a case).
+;; that was the only definition of that advice so far (`ad-add-advice'
+;; catches advice redefinitions and clears the cache in such a case).
;; Catching that would make the cache verification too expensive.
;; MORAL-II: Redefining somebody else's advice is BAAAAD (to speak with
;; George Walker Bush), and why would you redefine your own advice anyway?
;; Advice is a mechanism to facilitate function redefinition, not advice
-;; redefinition (wait until I write meta-advice.el :-). If you really have
+;; redefinition (wait until I write Meta-Advice :-). If you really have
;; to undo somebody else's advice try to write a "neutralizing" advice.
;; @@ Advising macros and special forms and other dangerous things:
;; - Deactivation:
;; Back-define an advised function to its original definition.
;; - Update:
-;; Reactivate an advised function but only if its advice is currently
+;; Reactivate an advised function but only if its advice is currently
;; active. This can be used to bring all currently advised function up
;; to date with the current state of advice without also activating
;; currently deactivated functions.
;; - ad-deactivate to deactivate the advice of a FUNCTION
;; - ad-update to activate the advice of a FUNCTION unless it was not
;; yet activated or is currently deactivated.
-;; - ad-unadvise deactivates a FUNCTION and removes all of its advice
+;; - ad-unadvise deactivates a FUNCTION and removes all of its advice
;; information, hence, it cannot be activated again
;; - ad-recover tries to redefine a FUNCTION to its original definition and
;; discards all advice information (a low-level `ad-unadvise').
;; @ Foo games: An advice tutorial
;; ===============================
-;; The following tutorial was created in GNU Emacs 18.59. Left-justified
+;; The following tutorial was created in Emacs 18.59. Left-justified
;; s-expressions are input forms followed by one or more result forms.
;; First we have to start the advice magic:
;;
;;
;; We start by defining an innocent looking function `foo' that simply
;; adds 1 to its argument X:
-;;
+;;
;; (defun foo (x)
;; "Add 1 to X."
;; (1+ x))
;; (call-interactively 'foo)
;; 6
;;
-;; Let's have a look at what the definition of `foo' looks like now
+;; Let's have a look at what the definition of `foo' looks like now
;; (indentation added by hand for legibility):
;;
;; (symbol-function 'foo)
;; (lambda (x)
;; "$ad-doc: foo$"
;; (interactive (list 5))
-;; (let (ad-return-value)
-;; (setq x (1- x))
-;; (setq x (1+ x))
-;; (setq ad-return-value (ad-Orig-foo x))
+;; (let (ad-return-value)
+;; (setq x (1- x))
+;; (setq x (1+ x))
+;; (setq ad-return-value (ad-Orig-foo x))
;; ad-return-value))
;;
;; @@ Around advices:
;; specifies where the code of the original function will be executed. The
;; keyword can appear multiple times which will result in multiple calls of
;; the original function in the resulting advised code. Note, that if we don't
-;; specify a position argument (i.e., `first', `last' or a number), then
+;; specify a position argument (i.e., `first', `last' or a number), then
;; `first' (or 0) is the default):
;;
;; (defadvice foo (around fg-times-2 act)
;; Again, let's see what the definition of `foo' looks like so far:
;;
;; (symbol-function 'foo)
-;; (lambda (x)
+;; (lambda (x)
;; "$ad-doc: foo$"
-;; (interactive (list 5))
-;; (let (ad-return-value)
-;; (setq x (1- x))
-;; (setq x (1+ x))
-;; (let ((x (* x 2)))
-;; (let ((x (1+ x)))
-;; (setq ad-return-value (ad-Orig-foo x))))
+;; (interactive (list 5))
+;; (let (ad-return-value)
+;; (setq x (1- x))
+;; (setq x (1+ x))
+;; (let ((x (* x 2)))
+;; (let ((x (1+ x)))
+;; (setq ad-return-value (ad-Orig-foo x))))
;; ad-return-value))
;;
;; @@ Controlling advice activation:
;;
;; @@ Protecting advice execution:
;; ===============================
-;; Once in a while we define an advice to perform some cleanup action,
+;; Once in a while we define an advice to perform some cleanup action,
;; for example:
;;
;; (defadvice foo (after fg-cleanup last act)
;; Again, let's see what `foo' looks like:
;;
;; (symbol-function 'foo)
-;; (lambda (x)
+;; (lambda (x)
;; "$ad-doc: foo$"
-;; (interactive (list 5))
-;; (let (ad-return-value)
-;; (unwind-protect
-;; (progn (setq x (1- x))
-;; (setq x (1+ x))
-;; (let ((x (* x 2)))
-;; (let ((x (1+ x)))
-;; (setq ad-return-value (ad-Orig-foo x))))
-;; (setq ad-return-value (* ad-return-value x))
-;; (setq ad-return-value (* ad-return-value x)))
-;; (print "Let's clean up now!"))
+;; (interactive (list 5))
+;; (let (ad-return-value)
+;; (unwind-protect
+;; (progn (setq x (1- x))
+;; (setq x (1+ x))
+;; (let ((x (* x 2)))
+;; (let ((x (1+ x)))
+;; (setq ad-return-value (ad-Orig-foo x))))
+;; (setq ad-return-value (* ad-return-value x))
+;; (setq ad-return-value (* ad-return-value x)))
+;; (print "Let's clean up now!"))
;; ad-return-value))
;;
;; @@ Compilation of advised definitions:
;; Now `foo' is byte-compiled:
;;
;; (symbol-function 'foo)
-;; (lambda (x)
+;; (lambda (x)
;; "$ad-doc: foo$"
-;; (interactive (byte-code "....." [5] 1))
+;; (interactive (byte-code "....." [5] 1))
;; (byte-code "....." [ad-return-value x nil ((byte-code "....." [print "Let's clean up now!"] 2)) * 2 ad-Orig-foo] 6))
;;
;; (foo 3)
;; (fie 2)
;; 8
;;
-;; If you put a preactivating `defadvice' into an elisp file that gets byte-
+;; If you put a preactivating `defadvice' into a Lisp file that gets byte-
;; compiled then the constructed advised definition will get compiled by
;; the byte-compiler. For that to occur in a v18 emacs you have to put the
;; `defadvice' inside a `defun' because the v18 compiler does not compile
;; the `compile' flag:
;;
;; (symbol-function 'fum)
-;; (lambda (x)
+;; (lambda (x)
;; "$ad-doc: fum$"
;; (byte-code "....." [ad-return-value x nil * 2 ad-Orig-fum] 4))
;;
;; give it an extra argument that controls the advised code, for example, one
;; might want to make an interactive function sensitive to a prefix argument.
;; For such cases `defadvice' allows the specification of an argument list
-;; for the advised function. Similar to the redefinition of interactive
+;; for the advised function. Similar to the redefinition of interactive
;; behavior, the first argument list specification found in the list of before/
;; around/after advices will be used. Of course, the specified argument list
;; should be downward compatible with the original argument list, otherwise
;; @@ Specifying argument lists of subrs:
;; ======================================
;; The argument lists of subrs cannot be determined directly from Lisp.
-;; This means that advice.el has to use `(&rest ad-subr-args)' as the
+;; This means that Advice has to use `(&rest ad-subr-args)' as the
;; argument list of the advised subr which is not very efficient. In Lemacs
;; subr argument lists can be determined from their documentation string, in
-;; GNU Emacs-19 this is the case for some but not all subrs. To accommodate
+;; Emacs-19 this is the case for some but not all subrs. To accommodate
;; for the cases where the argument lists cannot be determined (e.g., in a
-;; v18 Emacs) advice.el comes with a specification mechanism that allows the
+;; v18 Emacs) Advice comes with a specification mechanism that allows the
;; advice programmer to tell advice what the argument list of a certain subr
;; really is.
;;
;; (quote (a))
;; (list (quote (a)))
;;
-;; If we want it to happen during evaluation time we have to do the
+;; If we want it to happen during evaluation time we have to do the
;; following (first remove the old advice):
;;
;; (ad-remove-advice 'foom 'before 'fg-print-x)
;; from advising plain functions or subrs.
-;;; Change Log:
-
-;; advice.el,v
-;; Revision 2.1 1993/05/26 00:07:58 hans
-;; * advise `defalias' and `define-function' to properly handle forward
-;; advice in GNU Emacs-19.7 and later
-;; * fix minor bug in `ad-preactivate-advice'
-;; * merge with FSF installation of version 2.0
-;;
-;; Revision 2.0 1993/05/18 01:29:02 hans
-;; * Totally revamped: Now also works with v19s, function indirection
-;; instead of body copying for original function calls, caching of
-;; advised definitions, en/disable mechanism, more and better
-;; interactive functions, forward advice support for jwz's compiler,
-;; definition hooks, portable argument access, argument list definition
-;; for advised functions, preactivation mechanism, pretty comprehensive
-;; docs (still no info file)
-;;
-;; Revision 1.8 1992/12/15 22:54:45 hans
-;; * Replaced non-standard `member' with `memq'.
-;;
-;; Revision 1.7 1992/12/14 22:41:49 hans
-;; * First publicly released version
-;;
-;; Revision 1.1 1992/12/12 05:37:33 hans
-;; * Created
-
-
;;; Code:
;; @ Advice implementation:
;; ==============================
;; `defadvice' expansion needs quite a few advice functions and variables,
-;; hence, I need to preload the file before it can be compiled. To avoid
+;; hence, I need to preload the file before it can be compiled. To avoid
;; interference of bogus compiled files I always preload the source file:
(provide 'advice-preload)
;; During a normal load this is a noop:
(require 'advice-preload "advice.el")
-;; For the odd case that ``' does not have an autoload definition in some
-;; Emacs we autoload it here. It is only needed for compilation, hence,
-;; I don't want to unconditionally `require' it (re-autoloading ``' after
-;; this file got preloaded will properly redefine this autoload):
-(if (not (fboundp '`)) (autoload '` "backquote"))
-
;; @@ Variable definitions:
;; ========================
-(defconst ad-version "2.1")
-
-(defconst ad-emacs19-p
- (not (or (and (boundp 'epoch::version) epoch::version)
- (string-lessp emacs-version "19")))
- "Non-NIL if we run Emacs version 19 or higher.
-This will be true for GNU Emacs-19 as well as Lemacs.")
+(defgroup advice nil
+ "An overloading mechanism for Emacs Lisp functions."
+ :prefix "ad-"
+ :link '(custom-manual "(elisp)Advising Functions")
+ :group 'lisp)
-(defconst ad-lemacs-p
- (and ad-emacs19-p (string-match "Lucid" emacs-version))
- "Non-NIL if we run Lucid's version of Emacs-19.")
+(defconst ad-version "2.14")
;;;###autoload
-(defvar ad-start-advice-on-load t
- "*Non-NIL will start advice magic when this file gets loaded.
-Also see function `ad-start-advice'.")
-
-;;;###autoload
-(defvar ad-activate-on-definition nil
- "*Non-NIL means automatic advice activation at function definition.
-Set this variable to t if you want to enable forward advice (which is
-automatic advice activation of a previously undefined function at the
-point the function gets defined/loaded/autoloaded). The value of this
-variable takes effect only during the execution of `ad-start-advice'.
-If non-NIL it will enable definition hooks regardless of the value
-of `ad-enable-definition-hooks'.")
-
-;;;###autoload
-(defvar ad-redefinition-action 'warn
- "*Defines what to do with redefinitions during de/activation.
+(defcustom ad-redefinition-action 'warn
+ "*Defines what to do with redefinitions during Advice de/activation.
Redefinition occurs if a previously activated function that already has an
original definition associated with it gets redefined and then de/activated.
In such a case we can either accept the current definition as the new
original definition, discard the current definition and replace it with the
-old original, or keep it and raise an error. The values `accept', `discard',
-`error' or `warn' govern what will be done. `warn' is just like `accept' but
-it additionally prints a warning message. All other values will be
-interpreted as `error'.")
-
-;;;###autoload
-(defvar ad-definition-hooks nil
- "*List of hooks to be run after a function definition.
-The variable `ad-defined-function' will be bound to the name of
-the currently defined function when the hook function is run.")
-
-;;;###autoload
-(defvar ad-enable-definition-hooks nil
- "*Non-NIL will enable hooks to be run on function definition.
-Setting this variable is a noop unless the value of
-`ad-activate-on-definition' (which see) is NIL.")
-
-;; The following autoload depends on proper preloading of the runtime
-;; support of jwz's byte-compiler for accurate initialization:
+old original, or keep it and raise an error. The values `accept', `discard',
+`error' or `warn' govern what will be done. `warn' is just like `accept' but
+it additionally prints a warning message. All other values will be
+interpreted as `error'."
+ :type '(choice (const accept) (const discard) (const warn)
+ (other :tag "error" error))
+ :group 'advice)
;;;###autoload
-(defvar ad-use-jwz-byte-compiler
- ;; True if jwz's bytecomp-runtime is loaded:
- (fboundp 'eval-when-compile)
- "*Non-NIL means Jamie Zawinski's v19 byte-compiler will be used.
-If you use a v18 Emacs and don't use jwz's optimizing byte-compiler (the
-normal case) then this variable should be NIL, because otherwise
-enabling definition hooks (e.g., for forward advice) will redefine the
-`byte-code' subr which will lead to some performance degradation for
-byte-compiled code.")
-
-
-;; @@ `fset/byte-code' hack for jwz's byte-compiler:
-;; =================================================
-;; Because byte-compiled files that were generated by jwz's byte-compiler
-;; (as standardly used in v19s) define compiled functions and macros via
-;; `fset' and `byte-code' instead of `defun/defmacro' we have to advise
-;; `fset' similar to `defun/defmacro' and redefine `byte-code' to allow
-;; proper forward advice; hence, we have to make sure that there are
-;; proper primitive versions around that can be used by the advice package
-;; itself.
-;;
-;; Wish: A `byte-code-tl' function to be used at the top level of byte-
-;; compiled files which could be advised for the purpose of forward
-;; advice without creating all that trouble caused by redefining
-;; `byte-code'.
+(defcustom ad-default-compilation-action 'maybe
+ "*Defines whether to compile advised definitions during activation.
+A value of `always' will result in unconditional compilation, `never' will
+always avoid compilation, `maybe' will compile if the byte-compiler is already
+loaded, and `like-original' will compile if the original definition of the
+advised function is compiled or a built-in function. Every other value will
+be interpreted as `maybe'. This variable will only be considered if the
+COMPILE argument of `ad-activate' was supplied as nil."
+ :type '(choice (const always) (const never) (const like-original)
+ (other :tag "maybe" maybe))
+ :group 'advice)
-(if (not (fboundp 'ad-real-fset))
- (progn (fset 'ad-real-fset (symbol-function 'fset))
- ;; Copy byte-compiler properties:
- (put 'ad-real-fset 'byte-compile (get 'fset 'byte-compile))
- (put 'ad-real-fset 'byte-opcode (get 'fset 'byte-opcode))))
-
-(if (not (fboundp 'ad-real-byte-code))
- (fset 'ad-real-byte-code (symbol-function 'byte-code)))
;; @@ Some utilities:
;; We don't want the local arguments to interfere with anything
;; referenced in the supplied functions => the cryptic casing:
(defun ad-substitute-tree (sUbTrEe-TeSt fUnCtIoN tReE)
- ;;"Substitutes qualifying subTREEs with result of FUNCTION(subTREE).
- ;;Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4)
- ;;then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are
- ;;allowed too. Once a qualifying subtree has been found its subtrees will
- ;;not be considered anymore. (ad-substitute-tree 'atom 'identity tree)
- ;;generates a copy of TREE."
+ "Substitute qualifying subTREEs with result of FUNCTION(subTREE).
+Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4)
+then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are
+allowed too. Once a qualifying subtree has been found its subtrees will
+not be considered anymore. (ad-substitute-tree 'atom 'identity tree)
+generates a copy of TREE."
(cond ((consp tReE)
(cons (if (funcall sUbTrEe-TeSt (car tReE))
(funcall fUnCtIoN (car tReE))
;; this is just faster than `ad-substitute-tree':
(defun ad-copy-tree (tree)
- ;;"Returns a copy of the list structure of TREE."
+ "Return a copy of the list structure of TREE."
(cond ((consp tree)
(cons (ad-copy-tree (car tree))
(ad-copy-tree (cdr tree))))
(defmacro ad-dolist (varform &rest body)
"A Common-Lisp-style dolist iterator with the following syntax:
- (ad-dolist (<var> <init-form> [<result-form>])
- {body-form}*)
+ (ad-dolist (VAR INIT-FORM [RESULT-FORM])
+ BODY-FORM...)
-which will iterate over the list yielded by <init-form> binding <var> to the
-current head at every iteration. If <result-form> is supplied its value will
-be returned at the end of the iteration, NIL otherwise. The iteration can be
-exited prematurely with (ad-do-return [<value>])."
+which will iterate over the list yielded by INIT-FORM binding VAR to the
+current head at every iteration. If RESULT-FORM is supplied its value will
+be returned at the end of the iteration, nil otherwise. The iteration can be
+exited prematurely with `(ad-do-return [VALUE])'."
(let ((expansion
- (` (let ((ad-dO-vAr (, (car (cdr varform))))
- (, (car varform)))
- (while ad-dO-vAr
- (setq (, (car varform)) (car ad-dO-vAr))
- (,@ body)
- ;;work around a backquote bug:
- ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong
- ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar)))
- (, '(setq ad-dO-vAr (cdr ad-dO-vAr))))
- (, (car (cdr (cdr varform))))))))
+ `(let ((ad-dO-vAr ,(car (cdr varform)))
+ ,(car varform))
+ (while ad-dO-vAr
+ (setq ,(car varform) (car ad-dO-vAr))
+ ,@body
+ ;;work around a backquote bug:
+ ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong
+ ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar)))
+ ,'(setq ad-dO-vAr (cdr ad-dO-vAr)))
+ ,(car (cdr (cdr varform))))))
;;ok, this wastes some cons cells but only during compilation:
(if (catch 'contains-return
(ad-substitute-tree
(function (lambda (subtree)
- (cond ((eq (car-safe subtree) 'ad-dolist))
- ((eq (car-safe subtree) 'ad-do-return)
- (throw 'contains-return t)))))
+ (cond ((eq (car-safe subtree) 'ad-dolist))
+ ((eq (car-safe subtree) 'ad-do-return)
+ (throw 'contains-return t)))))
'identity body)
nil)
- (` (catch 'ad-dO-eXiT (, expansion)))
- expansion)))
+ `(catch 'ad-dO-eXiT ,expansion)
+ expansion)))
(defmacro ad-do-return (value)
- (` (throw 'ad-dO-eXiT (, value))))
+ `(throw 'ad-dO-eXiT ,value))
(if (not (get 'ad-dolist 'lisp-indent-hook))
(put 'ad-dolist 'lisp-indent-hook 1))
+;; @@ Save real definitions of subrs used by Advice:
+;; =================================================
+;; Advice depends on the real, unmodified functionality of various subrs,
+;; we save them here so advised versions will not interfere (eventually,
+;; we will save all subrs used in code generated by Advice):
+
+(defmacro ad-save-real-definition (function)
+ (let ((saved-function (intern (format "ad-real-%s" function))))
+ ;; Make sure the compiler is loaded during macro expansion:
+ (require 'byte-compile "bytecomp")
+ `(if (not (fboundp ',saved-function))
+ (progn (fset ',saved-function (symbol-function ',function))
+ ;; Copy byte-compiler properties:
+ ,@(if (get function 'byte-compile)
+ `((put ',saved-function 'byte-compile
+ ',(get function 'byte-compile))))
+ ,@(if (get function 'byte-opcode)
+ `((put ',saved-function 'byte-opcode
+ ',(get function 'byte-opcode))))))))
+
+(defun ad-save-real-definitions ()
+ ;; Macro expansion will hardcode the values of the various byte-compiler
+ ;; properties into the compiled version of this function such that the
+ ;; proper values will be available at runtime without loading the compiler:
+ (ad-save-real-definition fset)
+ (ad-save-real-definition documentation))
+
+(ad-save-real-definitions)
+
+
;; @@ Advice info access fns:
;; ==========================
;; Advice information for a particular function is stored on the
-;; advice-info property of the function symbol. It is stored as an
+;; advice-info property of the function symbol. It is stored as an
;; alist of the following format:
;;
;; ((active . t/nil)
(defvar ad-advised-functions nil)
(defmacro ad-pushnew-advised-function (function)
- ;;"Add FUNCTION to `ad-advised-functions' unless its already there."
- (` (if (not (assoc (symbol-name (, function)) ad-advised-functions))
- (setq ad-advised-functions
- (cons (list (symbol-name (, function)))
- ad-advised-functions)))))
+ "Add FUNCTION to `ad-advised-functions' unless its already there."
+ `(if (not (assoc (symbol-name ,function) ad-advised-functions))
+ (setq ad-advised-functions
+ (cons (list (symbol-name ,function))
+ ad-advised-functions))))
(defmacro ad-pop-advised-function (function)
- ;;"Remove FUNCTION from `ad-advised-functions'."
- (` (setq ad-advised-functions
- (delq (assoc (symbol-name (, function)) ad-advised-functions)
- ad-advised-functions))))
+ "Remove FUNCTION from `ad-advised-functions'."
+ `(setq ad-advised-functions
+ (delq (assoc (symbol-name ,function) ad-advised-functions)
+ ad-advised-functions)))
(defmacro ad-do-advised-functions (varform &rest body)
- ;;"`ad-dolist'-style iterator that maps over `ad-advised-functions'.
- ;; (ad-do-advised-functions (<var> [<result-form>])
- ;; {body-form}*)
- ;;Also see `ad-dolist'. On each iteration <var> will be bound to the
- ;;name of an advised function (a symbol)."
- (` (ad-dolist ((, (car varform))
- ad-advised-functions
- (, (car (cdr varform))))
- (setq (, (car varform)) (intern (car (, (car varform)))))
- (,@ body))))
+ "`ad-dolist'-style iterator that maps over `ad-advised-functions'.
+\(ad-do-advised-functions (VAR [RESULT-FORM])
+ BODY-FORM...)
+On each iteration VAR will be bound to the name of an advised function
+\(a symbol)."
+ `(ad-dolist (,(car varform)
+ ad-advised-functions
+ ,(car (cdr varform)))
+ (setq ,(car varform) (intern (car ,(car varform))))
+ ,@body))
(if (not (get 'ad-do-advised-functions 'lisp-indent-hook))
(put 'ad-do-advised-functions 'lisp-indent-hook 1))
(defmacro ad-get-advice-info (function)
- (` (get (, function) 'ad-advice-info)))
+ `(get ,function 'ad-advice-info))
(defmacro ad-set-advice-info (function advice-info)
- (` (put (, function) 'ad-advice-info (, advice-info))))
+ `(put ,function 'ad-advice-info ,advice-info))
(defmacro ad-copy-advice-info (function)
- (` (ad-copy-tree (get (, function) 'ad-advice-info))))
+ `(ad-copy-tree (get ,function 'ad-advice-info)))
(defmacro ad-is-advised (function)
- ;;"Returns non-NIL if FUNCTION has any advice info associated with it.
- ;;This does not mean that the advice is also active."
+ "Return non-nil if FUNCTION has any advice info associated with it.
+This does not mean that the advice is also active."
(list 'ad-get-advice-info function))
(defun ad-initialize-advice-info (function)
- ;;"Initializes the advice info for FUNCTION.
- ;;Assumes that FUNCTION has not yet been advised."
+ "Initialize the advice info for FUNCTION.
+Assumes that FUNCTION has not yet been advised."
(ad-pushnew-advised-function function)
(ad-set-advice-info function (list (cons 'active nil))))
(defmacro ad-get-advice-info-field (function field)
- ;;"Retrieves the value of the advice info FIELD of FUNCTION."
- (` (cdr (assq (, field) (ad-get-advice-info (, function))))))
+ "Retrieve the value of the advice info FIELD of FUNCTION."
+ `(cdr (assq ,field (ad-get-advice-info ,function))))
(defun ad-set-advice-info-field (function field value)
- ;;"Destructively modifies VALUE of the advice info FIELD of FUNCTION."
+ "Destructively modify VALUE of the advice info FIELD of FUNCTION."
(and (ad-is-advised function)
(cond ((assq field (ad-get-advice-info function))
;; A field with that name is already present:
;; Don't make this a macro so we can use it as a predicate:
(defun ad-is-active (function)
- ;;"non-NIL if FUNCTION is advised and activated."
+ "Return non-nil if FUNCTION is advised and activated."
(ad-get-advice-info-field function 'active))
(defun ad-make-advice (name protect enable definition)
"Constructs single piece of advice to be stored in some advice-info.
-NAME should be a non-NIL symbol, PROTECT and ENABLE should each be
+NAME should be a non-nil symbol, PROTECT and ENABLE should each be
either t or nil, and DEFINITION should be a list of the form
- (advice lambda ({<arg>}*) [docstring] [(interactive ...)] {body-form}*)"
+`(advice lambda ARGLIST [DOCSTRING] [INTERACTIVE-FORM] BODY...)'."
(list name protect enable definition))
;; ad-find-advice uses the alist structure directly ->
(defvar ad-advice-classes '(before around after activation deactivation))
(defun ad-has-enabled-advice (function class)
- ;;"True if at least one of FUNCTION's advices in CLASS is enabled."
+ "True if at least one of FUNCTION's advices in CLASS is enabled."
(ad-dolist (advice (ad-get-advice-info-field function class))
(if (ad-advice-enabled advice) (ad-do-return t))))
(defun ad-has-redefining-advice (function)
- ;;"True if FUNCTION's advice info defines at least 1 redefining advice.
- ;;Redefining advices affect the construction of an advised definition."
+ "True if FUNCTION's advice info defines at least 1 redefining advice.
+Redefining advices affect the construction of an advised definition."
(and (ad-is-advised function)
(or (ad-has-enabled-advice function 'before)
(ad-has-enabled-advice function 'around)
(ad-has-enabled-advice function 'after))))
(defun ad-has-any-advice (function)
- ;;"True if the advice info of FUNCTION defines at least one advice."
+ "True if the advice info of FUNCTION defines at least one advice."
(and (ad-is-advised function)
(ad-dolist (class ad-advice-classes nil)
(if (ad-get-advice-info-field function class)
(ad-do-return t)))))
(defun ad-get-enabled-advices (function class)
- ;;"Returns the list of enabled advices of FUNCTION in CLASS."
+ "Return the list of enabled advices of FUNCTION in CLASS."
(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)))
+;; @@ Dealing with automatic advice activation via `fset/defalias':
+;; ================================================================
+
+;; Since Emacs 19.26 the built-in versions of `fset' and `defalias'
+;; take care of automatic advice activation, hence, we don't have to
+;; hack it anymore by advising `fset/defun/defmacro/byte-code/etc'.
+
+;; The functionality of the new `fset' is as follows:
+;;
+;; fset(sym,newdef)
+;; assign NEWDEF to SYM
+;; if (get SYM 'ad-advice-info)
+;; ad-activate-internal(SYM, nil)
+;; return (symbol-function SYM)
+;;
+;; Whether advised definitions created by automatic activations will be
+;; compiled depends on the value of `ad-default-compilation-action'.
+
+;; Since calling `ad-activate-internal' in the built-in definition of `fset' can
+;; create major disasters we have to be a bit careful. One precaution is
+;; to provide a dummy definition for `ad-activate-internal' which can be used to
+;; turn off automatic advice activation (e.g., when `ad-stop-advice' or
+;; `ad-recover-normality' are called). Another is to avoid recursive calls
+;; to `ad-activate' by using `ad-with-auto-activation-disabled' where
+;; appropriate, especially in a safe version of `fset'.
+
+;; For now define `ad-activate-internal' to the dummy definition:
+(defun ad-activate-internal (function &optional compile)
+ "Automatic advice activation is disabled. `ad-start-advice' enables it."
+ nil)
+
+;; This is just a copy of the above:
+(defun ad-activate-internal-off (function &optional compile)
+ "Automatic advice activation is disabled. `ad-start-advice' enables it."
+ nil)
+
+;; This will be t for top-level calls to `ad-activate-internal-on':
+(defvar ad-activate-on-top-level t)
+
+(defmacro ad-with-auto-activation-disabled (&rest body)
+ `(let ((ad-activate-on-top-level nil))
+ ,@body))
+
+(defun ad-safe-fset (symbol definition)
+ "A safe `fset' which will never call `ad-activate-internal' recursively."
+ (ad-with-auto-activation-disabled
+ (ad-real-fset symbol definition)))
+
+
;; @@ Access functions for original definitions:
;; ============================================
;; The advice-info of an advised function contains its `origname' which is
;; a symbol that is fbound to the original definition available at the first
-;; proper activation of the function after a legal re/definition. If the
+;; proper activation of the function after a legal re/definition. If the
;; original was defined via fcell indirection then `origname' will be defined
-;; just so. Hence, to get hold of the actual original definition of a function
+;; just so. Hence, to get hold of the actual original definition of a function
;; we need to use `ad-real-orig-definition'.
(defun ad-make-origname (function)
- ;;"Makes name to be used to call the original FUNCTION."
+ "Make name to be used to call the original FUNCTION."
(intern (format "ad-Orig-%s" function)))
(defmacro ad-get-orig-definition (function)
- (` (let ((origname (ad-get-advice-info-field (, function) 'origname)))
- (if (fboundp origname)
- (symbol-function origname)))))
+ `(let ((origname (ad-get-advice-info-field ,function 'origname)))
+ (if (fboundp origname)
+ (symbol-function origname))))
(defmacro ad-set-orig-definition (function definition)
- (` (ad-real-fset
- (ad-get-advice-info-field function 'origname) (, definition))))
+ `(ad-safe-fset
+ (ad-get-advice-info-field function 'origname) ,definition))
(defmacro ad-clear-orig-definition (function)
- (` (fmakunbound (ad-get-advice-info-field (, function) 'origname))))
+ `(fmakunbound (ad-get-advice-info-field ,function 'origname)))
;; @@ Interactive input functions:
;; ===============================
(defun ad-read-advised-function (&optional prompt predicate default)
- ;;"Reads name of advised function with completion from the minibuffer.
- ;;An optional PROMPT will be used to prompt for the function. PREDICATE
- ;;plays the same role as for `try-completion' (which see). DEFAULT will
- ;;be returned on empty input (defaults to the first advised function for
- ;;which PREDICATE returns non-NIL)."
+ "Read name of advised function with completion from the minibuffer.
+An optional PROMPT will be used to prompt for the function. PREDICATE
+plays the same role as for `try-completion' (which see). DEFAULT will
+be returned on empty input (defaults to the first advised function for
+which PREDICATE returns non-nil)."
(if (null ad-advised-functions)
(error "ad-read-advised-function: There are no advised functions"))
(setq default
(intern function))))
(defvar ad-advice-class-completion-table
- (mapcar '(lambda (class) (list (symbol-name class)))
+ (mapcar (lambda (class) (list (symbol-name class)))
ad-advice-classes))
(defun ad-read-advice-class (function &optional prompt default)
- ;;"Reads a legal advice class with completion from the minibuffer.
- ;;An optional PROMPT will be used to prompt for the class. DEFAULT will
- ;;be returned on empty input (defaults to the first non-empty advice
- ;;class of FUNCTION)."
+ "Read a legal advice class with completion from the minibuffer.
+An optional PROMPT will be used to prompt for the class. DEFAULT will
+be returned on empty input (defaults to the first non-empty advice
+class of FUNCTION)."
(setq default
(or default
(ad-dolist (class ad-advice-classes)
(intern class))))
(defun ad-read-advice-name (function class &optional prompt)
- ;;"Reads name of existing advice of CLASS for FUNCTION with completion.
- ;;An optional PROMPT is used to prompt for the name."
+ "Read name of existing advice of CLASS for FUNCTION with completion.
+An optional PROMPT is used to prompt for the name."
(let* ((name-completion-table
(mapcar (function (lambda (advice)
(list (symbol-name (ad-advice-name advice)))))
(intern name))))
(defun ad-read-advice-specification (&optional prompt)
- ;;"Reads a complete function/class/name specification from minibuffer.
- ;;The list of read symbols will be returned. The optional PROMPT will
- ;;be used to prompt for the function."
+ "Read a complete function/class/name specification from minibuffer.
+The list of read symbols will be returned. The optional PROMPT will
+be used to prompt for the function."
(let* ((function (ad-read-advised-function prompt))
(class (ad-read-advice-class function))
(name (ad-read-advice-name function class)))
(defvar ad-last-regexp "")
(defun ad-read-regexp (&optional prompt)
- ;;"Reads a regular expression from the minibuffer."
+ "Read a regular expression from the minibuffer."
(let ((regexp (read-from-minibuffer
(concat (or prompt "Regular expression: ")
(if (equal ad-last-regexp "") ""
;; ===========================================================
(defmacro ad-find-advice (function class name)
- ;;"Finds the first advice of FUNCTION in CLASS with NAME."
- (` (assq (, name) (ad-get-advice-info-field (, function) (, class)))))
+ "Find the first advice of FUNCTION in CLASS with NAME."
+ `(assq ,name (ad-get-advice-info-field ,function ,class)))
(defun ad-advice-position (function class name)
- ;;"Returns position of first advice of FUNCTION in CLASS with NAME."
+ "Return position of first advice of FUNCTION in CLASS with NAME."
(let* ((found-advice (ad-find-advice function class name))
(advices (ad-get-advice-info-field function class)))
(if found-advice
(- (length advices) (length (memq found-advice advices))))))
(defun ad-find-some-advice (function class name)
- "Finds the first of FUNCTION's advices in CLASS matching NAME.
+ "Find the first of FUNCTION's advices in CLASS matching NAME.
NAME can be a symbol or a regular expression matching part of an advice name.
If CLASS is `any' all legal advice classes will be checked."
(if (ad-is-advised function)
(if found-advice (ad-do-return found-advice))))))
(defun ad-enable-advice-internal (function class name flag)
- ;;"Sets enable FLAG of FUNCTION's advices in CLASS matching NAME.
- ;;If NAME is a string rather than a symbol then it's interpreted as a regular
- ;;expression and all advices whose name contain a match for it will be
- ;;affected. If CLASS is `any' advices in all legal advice classes will be
- ;;considered. The number of changed advices will be returned (or NIL if
- ;;FUNCTION was not advised)."
+ "Set enable FLAG of FUNCTION's advices in CLASS matching NAME.
+If NAME is a string rather than a symbol then it's interpreted as a regular
+expression and all advices whose name contain a match for it will be
+affected. If CLASS is `any' advices in all legal advice classes will be
+considered. The number of changed advices will be returned (or nil if
+FUNCTION was not advised)."
(if (ad-is-advised function)
(let ((matched-advices 0))
(ad-dolist (advice-class ad-advice-classes)
(error "ad-enable-advice: `%s' is not advised" function)))
(defun ad-disable-advice (function class name)
- "Disables the advice of FUNCTION with CLASS and NAME."
+ "Disable the advice of FUNCTION with CLASS and NAME."
(interactive (ad-read-advice-specification "Disable advice of: "))
(if (ad-is-advised function)
(if (eq (ad-enable-advice-internal function class name nil) 0)
(error "ad-disable-advice: `%s' is not advised" function)))
(defun ad-enable-regexp-internal (regexp class flag)
- ;;"Sets enable FLAGs of all CLASS advices whose name contains a REGEXP match.
- ;;If CLASS is `any' all legal advice classes are considered. The number of
- ;;affected advices will be returned."
+ "Set enable FLAGs of all CLASS advices whose name contains a REGEXP match.
+If CLASS is `any' all legal advice classes are considered. The number of
+affected advices will be returned."
(let ((matched-advices 0))
(ad-do-advised-functions (advised-function)
(setq matched-advices
matched-advices))
(defun ad-disable-regexp (regexp)
- "Disables all advices with names that contain a match for REGEXP.
+ "Disable all advices with names that contain a match for REGEXP.
All currently advised functions will be considered."
(interactive
(list (ad-read-regexp "Disable advices via regexp: ")))
matched-advices))
(defun ad-remove-advice (function class name)
- "Removes FUNCTION's advice with NAME from its advices in CLASS.
+ "Remove FUNCTION's advice with NAME from its advices in CLASS.
If such an advice was found it will be removed from the list of advices
in that CLASS."
(interactive (ad-read-advice-specification "Remove advice of: "))
;;;###autoload
(defun ad-add-advice (function advice class position)
- "Adds a piece of ADVICE to FUNCTION's list of advices in CLASS.
+ "Add a piece of ADVICE to FUNCTION's list of advices in CLASS.
If FUNCTION already has one or more pieces of advice of the specified
-CLASS then POSITION determines where the new piece will go. The value
+CLASS then POSITION determines where the new piece will go. The value
of POSITION can either be `first', `last' or a number where 0 corresponds
-to `first'. Numbers outside the range will be mapped to the closest
-extreme position. If there was already a piece of ADVICE with the same
+to `first'. Numbers outside the range will be mapped to the closest
+extreme position. If there was already a piece of ADVICE with the same
name, then the position argument will be ignored and the old advice
will be overwritten with the new one.
- If the FUNCTION was not advised already, then its advice info will be
-initialized. Redefining a piece of advice whose name is part of the cache-id
+ If the FUNCTION was not advised already, then its advice info will be
+initialized. Redefining a piece of advice whose name is part of the cache-id
will clear the cache."
(cond ((not (ad-is-advised function))
(ad-initialize-advice-info function)
;; ===================================================
(defmacro ad-macrofy (definition)
- ;;"Takes a lambda function DEFINITION and makes a macro out of it."
- (` (cons 'macro (, definition))))
+ "Take a lambda function DEFINITION and make a macro out of it."
+ `(cons 'macro ,definition))
(defmacro ad-lambdafy (definition)
- ;;"Takes a macro function DEFINITION and makes a lambda out of it."
- (` (cdr (, definition))))
+ "Take a macro function DEFINITION and make a lambda out of it."
+ `(cdr ,definition))
;; There is no way to determine whether some subr is a special form or not,
-;; hence we need this list (which is the same for v18s and v19s):
+;; hence we need this list (which is probably out of date):
(defvar ad-special-forms
- (mapcar 'symbol-function
- '(and catch cond condition-case defconst defmacro
- defun defvar function if interactive let let*
- or prog1 prog2 progn quote save-excursion
- save-restriction save-window-excursion setq
- setq-default unwind-protect while
- with-output-to-temp-buffer)))
+ (let ((tem '(and catch cond condition-case defconst defmacro
+ defun defvar function if interactive let let*
+ or prog1 prog2 progn quote save-current-buffer
+ save-excursion save-restriction save-window-excursion
+ setq setq-default unwind-protect while
+ with-output-to-temp-buffer)))
+ ;; track-mouse could be void in some configurations.
+ (if (fboundp 'track-mouse)
+ (push 'track-mouse tem))
+ (mapcar 'symbol-function tem)))
(defmacro ad-special-form-p (definition)
- ;;"non-NIL if DEFINITION is a special form."
+ ;;"non-nil if DEFINITION is a special form."
(list 'memq definition 'ad-special-forms))
(defmacro ad-interactive-p (definition)
- ;;"non-NIL if DEFINITION can be called interactively."
+ ;;"non-nil if DEFINITION can be called interactively."
(list 'commandp definition))
(defmacro ad-subr-p (definition)
- ;;"non-NIL if DEFINITION is a subr."
+ ;;"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)))
+ ;;"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)))
+ ;;"non-nil if DEFINITION is a lambda expression."
+ `(eq (car-safe ,definition) 'lambda))
;; see ad-make-advice for the format of advice definitions:
(defmacro ad-advice-p (definition)
- ;;"non-NIL if DEFINITION is a piece of advice."
- (` (eq (car-safe (, definition)) 'advice)))
+ ;;"non-nil if DEFINITION is a piece of advice."
+ `(eq (car-safe ,definition) 'advice))
-;; GNU Emacs-19/Lemacs cross-compatibility
-;; (compiled-function-p is an obsolete function in GNU Emacs-19):
+;; Emacs/Lemacs cross-compatibility
+;; (compiled-function-p is an obsolete function in Emacs):
(if (and (not (fboundp 'byte-code-function-p))
(fboundp 'compiled-function-p))
- (ad-real-fset 'byte-code-function-p 'compiled-function-p))
+ (ad-safe-fset 'byte-code-function-p 'compiled-function-p))
-(defmacro ad-v19-compiled-p (definition)
- ;;"non-NIL if DEFINITION is a compiled object of a v19 Emacs."
- (` (and ad-emacs19-p
- (or (byte-code-function-p (, definition))
- (and (ad-macro-p (, definition))
- (byte-code-function-p (ad-lambdafy (, definition))))))))
+(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)))))
-(defmacro ad-v19-compiled-code (compiled-definition)
- ;;"Returns the byte-code object of a v19 COMPILED-DEFINITION."
- (` (if (ad-macro-p (, compiled-definition))
- (ad-lambdafy (, compiled-definition))
- (, compiled-definition))))
+(defmacro ad-compiled-code (compiled-definition)
+ "Return the byte-code object of a COMPILED-DEFINITION."
+ `(if (ad-macro-p ,compiled-definition)
+ (ad-lambdafy ,compiled-definition)
+ ,compiled-definition))
(defun ad-lambda-expression (definition)
- ;;"Returns the lambda expression of a function/macro/advice DEFINITION."
+ "Return the lambda expression of a function/macro/advice DEFINITION."
(cond ((ad-lambda-p definition)
definition)
((ad-macro-p definition)
(t nil)))
(defun ad-arglist (definition &optional name)
- ;;"Returns the argument list of DEFINITION.
- ;;If DEFINITION could be from a subr then its NAME should be
- ;;supplied to make subr arglist lookup more efficient."
- (cond ((ad-v19-compiled-p definition)
- (aref (ad-v19-compiled-code definition) 0))
+ "Return the argument list of DEFINITION.
+If DEFINITION could be from a subr then its NAME should be
+supplied to make subr arglist lookup more efficient."
+ (cond ((ad-compiled-p definition)
+ (aref (ad-compiled-code definition) 0))
((consp definition)
(car (cdr (ad-lambda-expression definition))))
((ad-subr-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:
(defmacro ad-define-subr-args (subr arglist)
- (` (put (, subr) 'ad-subr-arglist (list (, arglist)))))
+ `(put ,subr 'ad-subr-arglist (list ,arglist)))
(defmacro ad-undefine-subr-args (subr)
- (` (put (, subr) 'ad-subr-arglist nil)))
+ `(put ,subr 'ad-subr-arglist nil))
(defmacro ad-subr-args-defined-p (subr)
- (` (get (, subr) 'ad-subr-arglist)))
+ `(get ,subr 'ad-subr-arglist))
(defmacro ad-get-subr-args (subr)
- (` (car (get (, subr) 'ad-subr-arglist))))
+ `(car (get ,subr 'ad-subr-arglist)))
(defun ad-subr-arglist (subr-name)
- ;;"Retrieve arglist of the subr with SUBR-NAME.
- ;;Either use the one stored under the `ad-subr-arglist' property, or, if we
- ;;have a v19 Emacs try to retrieve it from the docstring and cache it under
- ;;that property, or otherwise use `(&rest ad-subr-args)'."
- (if (ad-subr-args-defined-p subr-name)
- (ad-get-subr-args subr-name)
- (let ((doc (if ad-emacs19-p
- (documentation subr-name))))
- (cond ((and doc
- (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))))))
+ "Retrieve arglist of the subr with SUBR-NAME.
+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 (match-string 1 doc))))))
+ (ad-get-subr-args subr-name))
+ ;; This is actually an error.
+ (t '(&rest ad-subr-args)))))))
(defun ad-docstring (definition)
- ;;"Returns the unexpanded docstring of DEFINITION."
+ "Return the unexpanded docstring of DEFINITION."
(let ((docstring
- (if (ad-v19-compiled-p definition)
- (condition-case nodoc
- (aref (ad-v19-compiled-code definition) 4)
- (error nil))
+ (if (ad-compiled-p definition)
+ (ad-real-documentation definition t)
(car (cdr (cdr (ad-lambda-expression definition)))))))
(if (or (stringp docstring)
(natnump docstring))
docstring)))
(defun ad-interactive-form (definition)
- ;;"Returns the interactive form of DEFINITION."
- (cond ((ad-v19-compiled-p definition)
+ "Return the interactive form of DEFINITION."
+ (cond ((ad-compiled-p definition)
(and (commandp definition)
- (list 'interactive (aref (ad-v19-compiled-code definition) 5))))
+ (list 'interactive (aref (ad-compiled-code definition) 5))))
((or (ad-advice-p definition)
(ad-lambda-p definition))
(commandp (ad-lambda-expression definition)))))
(defun ad-body-forms (definition)
- ;;"Returns the list of body forms of DEFINITION."
- (cond ((ad-v19-compiled-p definition)
- (setq definition (ad-v19-compiled-code definition))
- ;; build a standard (byte-code ...) form from the v19 code
- ;; (I don't think I ever use this):
- (list (list 'byte-code
- (aref definition 1)
- (aref definition 2)
- (aref definition 3))))
+ "Return the list of body forms of DEFINITION."
+ (cond ((ad-compiled-p definition)
+ nil)
((consp definition)
(nthcdr (+ (if (ad-docstring definition) 1 0)
(if (ad-interactive-form definition) 1 0))
(cdr (cdr (ad-lambda-expression definition)))))))
-(defun ad-compiled-p (definition)
- ;;"non-NIL if DEFINITION is byte-compiled."
- (or (ad-v19-compiled-p definition)
- (memq (car-safe (car (ad-body-forms definition)))
- '(byte-code ad-real-byte-code))))
-
;; Matches the docstring of an advised definition.
;; The first group of the regexp matches the function name:
(defvar ad-advised-definition-docstring-regexp "^\\$ad-doc: \\(.+\\)\\$$")
(defun ad-make-advised-definition-docstring (function)
- ;; Makes 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 (also see the defadvice for `documentation'):
+ "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 (also see the defadvice for `documentation')."
(format "$ad-doc: %s$" (prin1-to-string function)))
(defun ad-advised-definition-p (definition)
- ;;"non-NIL if DEFINITION was generated from advice information."
+ "Return non-nil if DEFINITION was generated from advice information."
(if (or (ad-lambda-p definition)
(ad-macro-p definition)
(ad-compiled-p definition))
ad-advised-definition-docstring-regexp docstring)))))
(defun ad-definition-type (definition)
- ;;"Returns symbol that describes the type of DEFINITION."
+ "Return symbol that describes the type of DEFINITION."
(if (ad-macro-p definition)
'macro
(if (ad-subr-p definition)
'advice)))))
(defun ad-has-proper-definition (function)
- ;;"True if FUNCTION is a symbol with a proper definition.
- ;;For that it has to be fbound with a non-autoload definition."
+ "True if FUNCTION is a symbol with a proper definition.
+For that it has to be fbound with a non-autoload definition."
(and (symbolp function)
(fboundp function)
(not (eq (car-safe (symbol-function function)) 'autoload))))
;; The following two are necessary for the sake of packages such as
;; ange-ftp which redefine functions via fcell indirection:
(defun ad-real-definition (function)
- ;;"Finds FUNCTION's definition at the end of function cell indirection."
+ "Find FUNCTION's definition at the end of function cell indirection."
(if (ad-has-proper-definition function)
(let ((definition (symbol-function function)))
(if (symbolp definition)
definition))))
(defun ad-real-orig-definition (function)
- ;;"Finds FUNCTION's real original definition starting from its `origname'."
+ "Find FUNCTION's real original definition starting from its `origname'."
(if (ad-is-advised function)
(ad-real-definition (ad-get-advice-info-field function 'origname))))
(defun ad-is-compilable (function)
- ;;"True if FUNCTION has an interpreted definition that can be compiled."
+ "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)))
(not (ad-compiled-p (symbol-function function)))))
-;; Need this because the v18 `byte-compile' can't compile macros:
(defun ad-compile-function (function)
"Byte-compiles FUNCTION (or macro) if it is not yet compiled."
(interactive "aByte-compile function: ")
(if (ad-is-compilable function)
- (or (progn
- (require 'byte-compile "bytecomp")
- (byte-compile function))
- ;; If we get here we must have a macro and a
- ;; standard non-optimizing v18 byte-compiler:
- (and (ad-macro-p (symbol-function function))
- (ad-real-fset
- function (ad-macrofy
- (byte-compile-lambda
- (ad-lambda-expression
- (symbol-function function)))))))))
-
-(defun ad-real-byte-codify (function)
- ;;"Compile FUNCTION and use `ad-real-byte-code' in the compiled body.
- ;;This is needed when forward advice with jwz-byte-compiled files is used in
- ;;order to avoid infinite recursion and keep efficiency as high as possible."
- (ad-compile-function function)
- (let ((definition (symbol-function function)))
- (cond ((ad-v19-compiled-p definition))
- ((ad-compiled-p definition)
- ;; Use ad-real-byte-code in the body of function:
- (setcar (car (ad-body-forms definition))
- 'ad-real-byte-code)))))
+ ;; Need to turn off auto-activation
+ ;; because `byte-compile' uses `fset':
+ (ad-with-auto-activation-disabled
+ (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:
;; I chose to use function indirection for all four types of original
;; definitions (functions, macros, subrs and special forms), i.e., create
;; a unique symbol `ad-Orig-<name>' which is fbound to the original
-;; definition and call it according to type and arguments. Functions and
+;; definition and call it according to type and arguments. Functions and
;; subrs that don't have any &rest arguments can be called directly in a
-;; `(ad-Orig-<name> ....)' form. If they have a &rest argument we have to
-;; use `apply'. Macros will be called with
+;; `(ad-Orig-<name> ....)' form. If they have a &rest argument we have to
+;; use `apply'. Macros will be called with
;; `(macroexpand '(ad-Orig-<name> ....))', and special forms also need a
;; form like that with `eval' instead of `macroexpand'.
;;
;; =============================
(defun ad-parse-arglist (arglist)
- ;;"Parses ARGLIST into its required, optional and rest parameters.
- ;;A three-element list is returned, where the 1st element is the list of
- ;;required arguments, the 2nd is the list of optional arguments, and the 3rd
- ;;is the name of an optional rest parameter (or NIL)."
+ "Parse ARGLIST into its required, optional and rest parameters.
+A three-element list is returned, where the 1st element is the list of
+required arguments, the 2nd is the list of optional arguments, and the 3rd
+is the name of an optional rest parameter (or nil)."
(let* (required optional rest)
(setq rest (car (cdr (memq '&rest arglist))))
(if rest (setq arglist (reverse (cdr (memq '&rest (reverse arglist))))))
(list required optional rest)))
(defun ad-retrieve-args-form (arglist)
- ;;"Generates a form which evaluates into names/values/types of ARGLIST.
- ;;When the form gets evaluated within a function with that argument list
- ;;it will result in a list with one entry for each argument, where the
- ;;first element of each entry is the name of the argument, the second
- ;;element is its actual current value, and the third element is either
- ;;`required', `optional' or `rest' depending on the type of the argument."
+ "Generate a form which evaluates into names/values/types of ARGLIST.
+When the form gets evaluated within a function with that argument list
+it will result in a list with one entry for each argument, where the
+first element of each entry is the name of the argument, the second
+element is its actual current value, and the third element is either
+`required', `optional' or `rest' depending on the type of the argument."
(let* ((parsed-arglist (ad-parse-arglist arglist))
(rest (nth 2 parsed-arglist)))
- (` (list
- (,@ (mapcar (function
- (lambda (req)
- (` (list '(, req) (, req) 'required))))
- (nth 0 parsed-arglist)))
- (,@ (mapcar (function
- (lambda (opt)
- (` (list '(, opt) (, opt) 'optional))))
- (nth 1 parsed-arglist)))
- (,@ (if rest (list (` (list '(, rest) (, rest) 'rest)))))
- ))))
+ `(list
+ ,@(mapcar (function
+ (lambda (req)
+ `(list ',req ,req 'required)))
+ (nth 0 parsed-arglist))
+ ,@(mapcar (function
+ (lambda (opt)
+ `(list ',opt ,opt 'optional)))
+ (nth 1 parsed-arglist))
+ ,@(if rest (list `(list ',rest ,rest 'rest))))))
(defun ad-arg-binding-field (binding field)
(cond ((eq field 'name) (car binding))
(defun ad-element-access (position list)
(cond ((= position 0) (list 'car list))
- ((= position 1) (` (car (cdr (, list)))))
+ ((= position 1) `(car (cdr ,list)))
(t (list 'nth position list))))
(defun ad-access-argument (arglist index)
- ;;"Tells how to access ARGLIST's actual argument at position INDEX.
- ;;For a required/optional arg it simply returns it, if a rest argument has
- ;;to be accessed, it returns a list with the index and name."
+ "Tell how to access ARGLIST's actual argument at position INDEX.
+For a required/optional arg it simply returns it, if a rest argument has
+to be accessed, it returns a list with the index and name."
(let* ((parsed-arglist (ad-parse-arglist arglist))
(reqopt-args (append (nth 0 parsed-arglist)
(nth 1 parsed-arglist)))
(list (- index (length reqopt-args)) rest-arg)))))
(defun ad-get-argument (arglist index)
- ;;"Returns form to access ARGLIST's actual argument at position INDEX."
+ "Return form to access ARGLIST's actual argument at position INDEX."
(let ((argument-access (ad-access-argument arglist index)))
(cond ((consp argument-access)
(ad-element-access
(argument-access))))
(defun ad-set-argument (arglist index value-form)
- ;;"Returns form to set ARGLIST's actual arg at INDEX to VALUE-FORM."
+ "Return form to set ARGLIST's actual arg at INDEX to VALUE-FORM."
(let ((argument-access (ad-access-argument arglist index)))
(cond ((consp argument-access)
;; should this check whether there actually is something to set?
- (` (setcar (, (ad-list-access
- (car argument-access) (car (cdr argument-access))))
- (, value-form))))
+ `(setcar ,(ad-list-access
+ (car argument-access) (car (cdr argument-access)))
+ ,value-form))
(argument-access
- (` (setq (, argument-access) (, value-form))))
+ `(setq ,argument-access ,value-form))
(t (error "ad-set-argument: No argument at position %d of `%s'"
index arglist)))))
(defun ad-get-arguments (arglist index)
- ;;"Returns form to access all actual arguments starting at position INDEX."
+ "Return form to access all actual arguments starting at position INDEX."
(let* ((parsed-arglist (ad-parse-arglist arglist))
(reqopt-args (append (nth 0 parsed-arglist)
(nth 1 parsed-arglist)))
(rest-arg (nth 2 parsed-arglist))
args-form)
(if (< index (length reqopt-args))
- (setq args-form (` (list (,@ (nthcdr index reqopt-args))))))
+ (setq args-form `(list ,@(nthcdr index reqopt-args))))
(if rest-arg
(if args-form
- (setq args-form (` (nconc (, args-form) (, rest-arg))))
- (setq args-form (ad-list-access (- index (length reqopt-args))
- rest-arg))))
+ (setq args-form `(nconc ,args-form ,rest-arg))
+ (setq args-form (ad-list-access (- index (length reqopt-args))
+ rest-arg))))
args-form))
(defun ad-set-arguments (arglist index values-form)
- ;;"Makes form to assign elements of VALUES-FORM as actual ARGLIST args.
- ;;The assignment starts at position INDEX."
+ "Make form to assign elements of VALUES-FORM as actual ARGLIST args.
+The assignment starts at position INDEX."
(let ((values-index 0)
argument-access set-forms)
(while (setq argument-access (ad-access-argument arglist index))
arglist index
(ad-element-access values-index 'ad-vAlUeS))
set-forms))
- (setq set-forms
- (cons (if (= (car argument-access) 0)
- (list 'setq
- (car (cdr argument-access))
- (ad-list-access values-index 'ad-vAlUeS))
- (list 'setcdr
- (ad-list-access (1- (car argument-access))
- (car (cdr argument-access)))
- (ad-list-access values-index 'ad-vAlUeS)))
- set-forms))
- ;; terminate loop
- (setq arglist nil))
+ (setq set-forms
+ (cons (if (= (car argument-access) 0)
+ (list 'setq
+ (car (cdr argument-access))
+ (ad-list-access values-index 'ad-vAlUeS))
+ (list 'setcdr
+ (ad-list-access (1- (car argument-access))
+ (car (cdr argument-access)))
+ (ad-list-access values-index 'ad-vAlUeS)))
+ set-forms))
+ ;; terminate loop
+ (setq arglist nil))
(setq index (1+ index))
(setq values-index (1+ values-index)))
(if (null set-forms)
(error "ad-set-arguments: No argument at position %d of `%s'"
index arglist)
- (if (= (length set-forms) 1)
- ;; For exactly one set-form we can use values-form directly,...
- (ad-substitute-tree
- (function (lambda (form) (eq form 'ad-vAlUeS)))
- (function (lambda (form) values-form))
- (car set-forms))
- ;; ...if we have more we have to bind it to a variable:
- (` (let ((ad-vAlUeS (, values-form)))
- (,@ (reverse set-forms))
- ;; work around the old backquote bug:
- (, 'ad-vAlUeS)))))))
+ (if (= (length set-forms) 1)
+ ;; For exactly one set-form we can use values-form directly,...
+ (ad-substitute-tree
+ (function (lambda (form) (eq form 'ad-vAlUeS)))
+ (function (lambda (form) values-form))
+ (car set-forms))
+ ;; ...if we have more we have to bind it to a variable:
+ `(let ((ad-vAlUeS ,values-form))
+ ,@(reverse set-forms)
+ ;; work around the old backquote bug:
+ ,'ad-vAlUeS)))))
(defun ad-insert-argument-access-forms (definition arglist)
- ;;"Expands arg-access text macros in DEFINITION according to ARGLIST."
+ "Expands arg-access text macros in DEFINITION according to ARGLIST."
(ad-substitute-tree
(function
(lambda (form)
;; Suppose function foo was called with (foo 1 2 3 4 5), and foo has the
;; argument list (x y &rest z), and we want to call the function bar which
;; has argument list (a &rest b) with a combination of x, y and z so that
-;; the effect is just as if we had called (bar 1 2 3 4 5) directly.
+;; the effect is just as if we had called (bar 1 2 3 4 5) directly.
;; The mapping should work for any two argument lists.
(defun ad-map-arglists (source-arglist target-arglist)
- "Makes funcall/apply form to map SOURCE-ARGLIST to TARGET-ARGLIST.
+ "Make `funcall/apply' form to map SOURCE-ARGLIST to TARGET-ARGLIST.
The arguments supplied to TARGET-ARGLIST will be taken from SOURCE-ARGLIST just
-as if they had been supplied to a function with TARGET-ARGLIST directly.
-Excess source arguments will be neglected, missing source arguments will be
-supplied as NIL. Returns a funcall or apply form with the second element being
-`function' which has to be replaced by an actual function argument.
-Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return
- (funcall function a (car args) (car (cdr args)) (nth 2 args))"
+as if they had been supplied to a function with TARGET-ARGLIST directly.
+Excess source arguments will be neglected, missing source arguments will be
+supplied as nil. Returns a `funcall' or `apply' form with the second element
+being `function' which has to be replaced by an actual function argument.
+Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return
+ `(funcall function a (car args) (car (cdr args)) (nth 2 args))'."
(let* ((parsed-source-arglist (ad-parse-arglist source-arglist))
(source-reqopt-args (append (nth 0 parsed-source-arglist)
(nth 1 parsed-source-arglist)))
source-reqopt-args)))))))))
(defun ad-make-mapped-call (source-arglist target-arglist target-function)
- ;;"Makes form to call TARGET-FUNCTION with args from SOURCE-ARGLIST."
+ "Make form to call TARGET-FUNCTION with args from SOURCE-ARGLIST."
(let* ((mapped-form (ad-map-arglists source-arglist target-arglist)))
(if (eq (car mapped-form) 'funcall)
(cons target-function (cdr (cdr mapped-form)))
;; @@@ Making an advised documentation string:
;; ===========================================
;; New policy: The documentation string for an advised function will be built
-;; at the time the advised `documentation' function is called. This has the
+;; at the time the advised `documentation' function is called. This has the
;; following advantages:
;; 1) command-key substitutions will automatically be correct
;; 2) No wasted string space due to big advised docstrings in caches or
;; The overall overhead for this should be negligible because people normally
;; don't lookup documentation for the same function over and over again.
-(defun ad-make-single-advice-docstring (advice class)
+(defun ad-make-single-advice-docstring (advice class &optional style)
(let ((advice-docstring (ad-docstring (ad-advice-definition advice))))
- ;; Always show advice name/class even if there is no docstring:
- (format "%s (%s):%s%s"
- (ad-advice-name advice) class
- (if advice-docstring "\n" "")
- (or advice-docstring ""))))
-
-(defun ad-make-advised-docstring (function)
- ;;"Constructs a documentation string for the advised FUNCTION.
- ;;It concatenates the original documentation with the documentation
- ;;strings of the individual pieces of advice. Name and class of every
- ;;advice will be displayed too. The order of the advice documentation
- ;;strings corresponds to before/around/after and the individual ordering
- ;;in any of these classes."
+ (cond ((eq style 'plain)
+ advice-docstring)
+ ((eq style 'freeze)
+ (format "Permanent %s-advice `%s':%s%s"
+ class (ad-advice-name advice)
+ (if advice-docstring "\n" "")
+ (or advice-docstring "")))
+ (t (if advice-docstring
+ (format "%s-advice `%s':\n%s"
+ (capitalize (symbol-name class))
+ (ad-advice-name advice)
+ advice-docstring)
+ (format "%s-advice `%s'."
+ (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)
+ "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
- ;; Use this wacky apply construction to avoid an Lemacs compiler
- ;; warning (its `documentation' has only 1 arg as opposed to GNU
- ;; Emacs-19's version which has an optional `raw' arg):
- (apply 'documentation
- origdef
- (if (and ad-emacs19-p (not ad-lemacs-p))
- ;; If we have GNU Emacs-19 retrieve raw doc, because
- ;; key substitution will be taken care of later anyway:
- '(t)))))
- (concat (or origdoc "")
- (if origdoc "\n\n" "\n")
- ;; Always inform about advice even if there is no origdoc:
- "This " (symbol-name (ad-definition-type origdef))
- " is advised with the following advice(s):"
- ;; Combine advice docstrings:
- (mapconcat
- (function
- (lambda (class)
- (mapconcat
- (function
- (lambda (advice)
- (concat
- "\n\n" (ad-make-single-advice-docstring advice class))))
- (ad-get-enabled-advices function class) "")))
- ad-advice-classes ""))))
+ ;; Retrieve raw doc, key substitution will be taken care of later:
+ (ad-real-documentation origdef t))
+ (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)))
+ (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
+ (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))
+(defun ad-make-freeze-docstring (function)
+ (ad-make-advised-docstring function 'freeze))
;; @@@ Accessing overriding arglists and interactive forms:
;; ========================================================
(defun ad-advised-arglist (function)
- ;;"Finds first defined arglist in FUNCTION's redefining advices."
+ "Find first defined arglist in FUNCTION's redefining advices."
(ad-dolist (advice (append (ad-get-enabled-advices function 'before)
(ad-get-enabled-advices function 'around)
(ad-get-enabled-advices function 'after)))
(ad-do-return arglist)))))
(defun ad-advised-interactive-form (function)
- ;;"Finds first interactive form in FUNCTION's redefining advices."
+ "Find first interactive form in FUNCTION's redefining advices."
(ad-dolist (advice (append (ad-get-enabled-advices function 'before)
(ad-get-enabled-advices function 'around)
(ad-get-enabled-advices function 'after)))
;; ============================
(defun ad-make-advised-definition (function)
- ;;"Generates an advised definition of FUNCTION from its advice info."
+ "Generate an advised definition of FUNCTION from its advice info."
(if (and (ad-is-advised function)
(ad-has-redefining-advice function))
(let* ((origdef (ad-real-orig-definition function))
(interactive-form
(cond (orig-macro-p nil)
(advised-interactive-form)
- ((ad-interactive-form origdef))
+ ((ad-interactive-form origdef)
+ (if (and (symbolp function) (get function 'elp-info))
+ (interactive-form (aref (get function 'elp-info) 2))
+ (ad-interactive-form origdef)))
;; Otherwise we must have a subr: make it interactive if
;; we have to and initialize required arguments in case
;; it is called interactively:
(orig-interactive-p
- (let ((reqargs (car (ad-parse-arglist advised-arglist))))
- (if reqargs
- (` (interactive
- '(, (make-list (length reqargs) nil))))
- '(interactive))))))
+ (interactive-form origdef))))
(orig-form
(cond ((or orig-special-form-p orig-macro-p)
;; Special forms and macros will be advised into macros.
;; expansion time and return the result. The moral of that
;; is that one should always deactivate advised special
;; forms before one byte-compiles a file.
- (` ((, (if orig-macro-p
- 'macroexpand
- 'eval))
- (cons '(, origname)
- (, (ad-get-arguments advised-arglist 0))))))
+ `(,(if orig-macro-p 'macroexpand 'eval)
+ (cons ',origname
+ ,(ad-get-arguments advised-arglist 0))))
((and orig-subr-p
orig-interactive-p
+ (not interactive-form)
(not advised-interactive-form))
;; Check whether we were called interactively
;; in order to do proper prompting:
- (` (if (interactive-p)
- (call-interactively '(, origname))
- (, (ad-make-mapped-call
- orig-arglist advised-arglist origname)))))
+ `(if (interactive-p)
+ (call-interactively ',origname)
+ ,(ad-make-mapped-call orig-arglist
+ advised-arglist
+ origname)))
;; And now for normal functions and non-interactive subrs
;; (or subrs whose interactive behavior was advised):
(t (ad-make-mapped-call
(ad-get-enabled-advices function 'after)))))
(defun ad-assemble-advised-definition
- (type args docstring interactive orig &optional befores arounds afters)
+ (type args docstring interactive orig &optional befores arounds afters)
- ;;"Assembles an original and its advices into an advised function.
- ;;It constructs a function or macro definition according to TYPE which has to
- ;;be either `macro', `function' or `special-form'. ARGS is the argument list
- ;;that has to be used, DOCSTRING if non-NIL defines the documentation of the
- ;;definition, INTERACTIVE if non-NIL is the interactive form to be used,
- ;;ORIG is a form that calls the body of the original unadvised function,
- ;;and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG
- ;;should be modified. The assembled function will be returned."
+ "Assembles an original and its advices into an advised function.
+It constructs a function or macro definition according to TYPE which has to
+be either `macro', `function' or `special-form'. ARGS is the argument list
+that has to be used, DOCSTRING if non-nil defines the documentation of the
+definition, INTERACTIVE if non-nil is the interactive form to be used,
+ORIG is a form that calls the body of the original unadvised function,
+and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG
+should be modified. The assembled function will be returned."
(let (before-forms around-form around-form-protected after-forms definition)
(ad-dolist (advice befores)
- (cond ((and (ad-advice-protected advice)
- before-forms)
- (setq before-forms
- (` ((unwind-protect
- (, (ad-prognify before-forms))
- (,@ (ad-body-forms
- (ad-advice-definition advice))))))))
- (t (setq before-forms
- (append before-forms
- (ad-body-forms (ad-advice-definition advice)))))))
-
- (setq around-form (` (setq ad-return-value (, orig))))
+ (cond ((and (ad-advice-protected advice)
+ before-forms)
+ (setq before-forms
+ `((unwind-protect
+ ,(ad-prognify before-forms)
+ ,@(ad-body-forms
+ (ad-advice-definition advice))))))
+ (t (setq before-forms
+ (append before-forms
+ (ad-body-forms (ad-advice-definition advice)))))))
+
+ (setq around-form `(setq ad-return-value ,orig))
(ad-dolist (advice (reverse arounds))
- ;; If any of the around advices is protected then we
- ;; protect the complete around advice onion:
- (if (ad-advice-protected advice)
- (setq around-form-protected t))
- (setq around-form
- (ad-substitute-tree
- (function (lambda (form) (eq form 'ad-do-it)))
- (function (lambda (form) around-form))
- (ad-prognify (ad-body-forms (ad-advice-definition advice))))))
+ ;; If any of the around advices is protected then we
+ ;; protect the complete around advice onion:
+ (if (ad-advice-protected advice)
+ (setq around-form-protected t))
+ (setq around-form
+ (ad-substitute-tree
+ (function (lambda (form) (eq form 'ad-do-it)))
+ (function (lambda (form) around-form))
+ (ad-prognify (ad-body-forms (ad-advice-definition advice))))))
(setq after-forms
(if (and around-form-protected before-forms)
- (` ((unwind-protect
- (, (ad-prognify before-forms))
- (, around-form))))
- (append before-forms (list around-form))))
+ `((unwind-protect
+ ,(ad-prognify before-forms)
+ ,around-form))
+ (append before-forms (list around-form))))
(ad-dolist (advice afters)
- (cond ((and (ad-advice-protected advice)
- after-forms)
- (setq after-forms
- (` ((unwind-protect
- (, (ad-prognify after-forms))
- (,@ (ad-body-forms
- (ad-advice-definition advice))))))))
- (t (setq after-forms
- (append after-forms
- (ad-body-forms (ad-advice-definition advice)))))))
+ (cond ((and (ad-advice-protected advice)
+ after-forms)
+ (setq after-forms
+ `((unwind-protect
+ ,(ad-prognify after-forms)
+ ,@(ad-body-forms
+ (ad-advice-definition advice))))))
+ (t (setq after-forms
+ (append after-forms
+ (ad-body-forms (ad-advice-definition advice)))))))
(setq definition
- (` ((,@ (if (memq type '(macro special-form)) '(macro)))
- lambda
- (, args)
- (,@ (if docstring (list docstring)))
- (,@ (if interactive (list interactive)))
- (let (ad-return-value)
- (,@ after-forms)
- (, (if (eq type 'special-form)
- '(list 'quote ad-return-value)
- 'ad-return-value))))))
+ `(,@(if (memq type '(macro special-form)) '(macro))
+ lambda
+ ,args
+ ,@(if docstring (list docstring))
+ ,@(if interactive (list interactive))
+ (let (ad-return-value)
+ ,@after-forms
+ ,(if (eq type 'special-form)
+ '(list 'quote ad-return-value)
+ 'ad-return-value))))
(ad-insert-argument-access-forms definition args)))
;; This is needed for activation/deactivation hooks:
(defun ad-make-hook-form (function hook-name)
- ;;"Makes hook-form from FUNCTION's advice bodies in class HOOK-NAME."
+ "Make hook-form from FUNCTION's advice bodies in class HOOK-NAME."
(let ((hook-forms
(mapcar (function (lambda (advice)
(ad-body-forms (ad-advice-definition advice))))
;; definition if the current advice and function definition state is the
;; same as it was at the time when the cached definition was generated.
;; For that purpose we associate every cache with an id so we can verify
-;; if it is still valid at a certain point in time. This id mechanism
+;; if it is still valid at a certain point in time. This id mechanism
;; makes it possible to preactivate advised functions, write the compiled
;; advised definitions to a file and reuse them during the actual
;; activation without having to risk that the resulting definition will be
;; F) a piece of advice used in the cache got redefined before the
;; defadvice with the cached definition got loaded: This is a PROBLEM!
;;
-;; Cases A and B are the normal ones. A is taken care of by `ad-add-advice'
+;; Cases A and B are the normal ones. A is taken care of by `ad-add-advice'
;; which clears the cache in such a case, B is easily checked during
;; verification at activation time.
;;
;; if one considers the case that the original function could be different
;; from the one available at caching time (e.g., for forward advice of
;; functions that get redefined by some packages - such as `eval-region' gets
-;; redefined by edebug). All these cases can be easily checked during
-;; verification. Element 4 of the id lets one check case C, element 5 takes
+;; redefined by edebug). All these cases can be easily checked during
+;; verification. Element 4 of the id lets one check case C, element 5 takes
;; care of case D (using t in the equality case saves some space, because the
;; arglist can be recovered at validation time from the cached definition),
;; and element 6 takes care of case E which is only a problem if the original
;;
;; The cache-id of a typical advised function with one piece of advice and
;; no arglist redefinition takes 7 conses which is a small price to pay for
-;; the added efficiency. The validation itself is also pretty cheap, certainly
+;; the added efficiency. The validation itself is also pretty cheap, certainly
;; a lot cheaper than reconstructing an advised definition.
(defmacro ad-get-cache-definition (function)
- (` (car (ad-get-advice-info-field (, function) 'cache))))
+ `(car (ad-get-advice-info-field ,function 'cache)))
(defmacro ad-get-cache-id (function)
- (` (cdr (ad-get-advice-info-field (, function) 'cache))))
+ `(cdr (ad-get-advice-info-field ,function 'cache)))
(defmacro ad-set-cache (function definition id)
- (` (ad-set-advice-info-field
- (, function) 'cache (cons (, definition) (, id)))))
+ `(ad-set-advice-info-field
+ ,function 'cache (cons ,definition ,id)))
(defun ad-clear-cache (function)
"Clears a previously cached advised definition of FUNCTION.
(ad-set-advice-info-field function 'cache nil))
(defun ad-make-cache-id (function)
- ;;"Generates an identifying image of the current advices of FUNCTION."
+ "Generate an identifying image of the current advices of FUNCTION."
(let ((original-definition (ad-real-orig-definition function))
(cached-definition (ad-get-cache-definition function)))
(list (mapcar (function (lambda (advice) (ad-advice-name advice)))
(ad-interactive-form cached-definition))))))
(defun ad-get-cache-class-id (function class)
- ;;"Returns the part of FUNCTION's cache id that identifies CLASS."
+ "Return the part of FUNCTION's cache id that identifies CLASS."
(let ((cache-id (ad-get-cache-id function)))
(if (eq class 'before)
(car cache-id)
;; There should be a way to monitor if and why a cache verification failed
;; in order to determine whether a certain preactivation could be used or
-;; not. Right now the only way to find out is to trace
-;; `ad-cache-id-verification-code'. The code it returns indicates where the
-;; verification failed. Tracing `ad-verify-cache-class-id' might provide
+;; not. Right now the only way to find out is to trace
+;; `ad-cache-id-verification-code'. The code it returns indicates where the
+;; verification failed. Tracing `ad-verify-cache-class-id' might provide
;; some additional useful information.
(defun ad-cache-id-verification-code (function)
code))
(defun ad-verify-cache-id (function)
- ;;"True if FUNCTION's cache-id is compatible with its current advices."
+ "True if FUNCTION's cache-id is compatible with its current advices."
(eq (ad-cache-id-verification-code function) 'verified))
;; =================
;; Preactivation can be used to generate compiled advised definitions
;; at compile time without having to give up the dynamic runtime flexibility
-;; of the advice mechanism. Preactivation is a special feature of `defadvice',
+;; of the advice mechanism. Preactivation is a special feature of `defadvice',
;; it involves the following steps:
;; - remembering the function's current state (definition and advice-info)
;; - advising it with the defined piece of advice
;; before the preactivation
;; - Returning the saved definition and its id to be used in the expansion of
;; `defadvice' to assign it as an initial cache, hence it will be compiled
-;; at time the `defadvice' gets compiled (for v18 byte-compilers the
-;; `defadvice' needs to be in the body of a `defun' for that to occur).
+;; at time the `defadvice' gets compiled.
;; Naturally, for preactivation to be effective it has to be applied/compiled
;; at the right time, i.e., when the current state of advices and function
-;; definition exactly reflects the state at activation time. Should that not
+;; definition exactly reflects the state at activation time. Should that not
;; be the case, the precompiled definition will just be discarded and a new
;; advised definition will be generated.
(defun ad-preactivate-advice (function advice class position)
- ;;"Preactivates FUNCTION and returns the constructed cache."
+ "Preactivate FUNCTION and returns the constructed cache."
(let* ((function-defined-p (fboundp function))
(old-definition
(if function-defined-p
(ad-add-advice function advice class position)
(ad-enable-advice function class (ad-advice-name advice))
(ad-clear-cache function)
- (ad-activate function nil)
+ (ad-activate function -1)
(if (and (ad-is-active function)
(ad-get-cache-definition function))
(list (ad-get-cache-definition function)
(ad-set-advice-info function old-advice-info)
;; Don't `fset' function to nil if it was previously unbound:
(if function-defined-p
- (ad-real-fset function old-definition)
+ (ad-safe-fset function old-definition)
(fmakunbound function)))))
+
+;; @@ Freezing:
+;; ============
+;; Freezing transforms a `defadvice' into a redefining `defun/defmacro'
+;; for the advised function without keeping any advice information. This
+;; feature was jwz's idea: It generates a dumpable function definition
+;; whose documentation can be written to the DOC file, and the generated
+;; code does not need any Advice runtime support. Of course, frozen advices
+;; cannot be undone.
+
+;; Freezing only considers the advice of the particular `defadvice', other
+;; already existing advices for the same function will be ignored. To ensure
+;; proper interaction when an already advised function gets redefined with
+;; a frozen advice, frozen advices always use the actual original definition
+;; of the function, i.e., they are always at the core of the onion. E.g., if
+;; an already advised function gets redefined with a frozen advice and then
+;; unadvised, the frozen advice remains as the new definition of the function.
+
+;; While multiple freeze advices for a single function or freeze-advising
+;; of an already advised function are possible, they are better avoided,
+;; because definition/compile/load ordering is relevant, and it becomes
+;; incomprehensible pretty quickly.
+
+(defun ad-make-freeze-definition (function advice class position)
+ (if (not (ad-has-proper-definition function))
+ (error
+ "ad-make-freeze-definition: `%s' is not yet defined"
+ function))
+ (let* ((name (ad-advice-name advice))
+ ;; With a unique origname we can have multiple freeze advices
+ ;; for the same function, each overloading the previous one:
+ (unique-origname
+ (intern (format "%s-%s-%s" (ad-make-origname function) class name)))
+ (orig-definition
+ ;; If FUNCTION is already advised, we'll use its current origdef
+ ;; as the original definition of the frozen advice:
+ (or (ad-get-orig-definition function)
+ (symbol-function function)))
+ (old-advice-info
+ (if (ad-is-advised function)
+ (ad-copy-advice-info function)))
+ (real-docstring-fn
+ (symbol-function 'ad-make-advised-definition-docstring))
+ (real-origname-fn
+ (symbol-function 'ad-make-origname))
+ (frozen-definition
+ (unwind-protect
+ (progn
+ ;; Make sure we construct a proper docstring:
+ (ad-safe-fset 'ad-make-advised-definition-docstring
+ 'ad-make-freeze-docstring)
+ ;; Make sure `unique-origname' is used as the origname:
+ (ad-safe-fset 'ad-make-origname (lambda (x) unique-origname))
+ ;; No we reset all current advice information to nil and
+ ;; generate an advised definition that's solely determined
+ ;; by ADVICE and the current origdef of FUNCTION:
+ (ad-set-advice-info function nil)
+ (ad-add-advice function advice class position)
+ ;; The following will provide proper real docstrings as
+ ;; well as a definition that will make the compiler happy:
+ (ad-set-orig-definition function orig-definition)
+ (ad-make-advised-definition function))
+ ;; Restore the old advice state:
+ (ad-set-advice-info function old-advice-info)
+ ;; Restore functions:
+ (ad-safe-fset
+ 'ad-make-advised-definition-docstring real-docstring-fn)
+ (ad-safe-fset 'ad-make-origname real-origname-fn))))
+ (if frozen-definition
+ (let* ((macro-p (ad-macro-p frozen-definition))
+ (body (cdr (if macro-p
+ (ad-lambdafy frozen-definition)
+ frozen-definition))))
+ `(progn
+ (if (not (fboundp ',unique-origname))
+ (fset ',unique-origname
+ ;; avoid infinite recursion in case the function
+ ;; we want to freeze is already advised:
+ (or (ad-get-orig-definition ',function)
+ (symbol-function ',function))))
+ (,(if macro-p 'defmacro 'defun)
+ ,function
+ ,@body))))))
+
+
+;; @@ Activation and definition handling:
+;; ======================================
+
+(defun ad-should-compile (function compile)
+ "Return non-nil if the advised FUNCTION should be compiled.
+If COMPILE is non-nil and not a negative number then it returns t.
+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))))))
+
(defun ad-activate-advised-definition (function compile)
- ;;"Redefines FUNCTION with its advised definition from cache or scratch.
- ;;If COMPILE is true the resulting FUNCTION will be compiled. The current
- ;;definition and its cache-id will be put into the cache."
+ "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))))
- (ad-real-fset function
+ (ad-safe-fset function
(or verified-cached-definition
(ad-make-advised-definition function)))
- (if compile (ad-compile-function function))
+ (if (ad-should-compile function compile)
+ (ad-compile-function function))
(if verified-cached-definition
(if (not (eq verified-cached-definition (symbol-function function)))
;; we must have compiled, cache the compiled definition:
function (symbol-function function) (ad-make-cache-id function)))))
(defun ad-handle-definition (function)
- "Handles re/definition of an advised FUNCTION during de/activation.
+ "Handle re/definition of an advised FUNCTION during de/activation.
If FUNCTION does not have an original definition associated with it and
the current definition is usable, then it will be stored as FUNCTION's
-original definition. If no current definition is available (even in the
-case of undefinition) nothing will be done. In the case of redefinition
+original definition. If no current definition is available (even in the
+case of undefinition) nothing will be done. In the case of redefinition
the action taken depends on the value of `ad-redefinition-action' (which
-see). Redefinition occurs when FUNCTION already has an original definition
+see). Redefinition occurs when FUNCTION already has an original definition
associated with it but got redefined with a new definition and then
-de/activated. If you do not like the current redefinition action change
+de/activated. If you do not like the current redefinition action change
the value of `ad-redefinition-action' and de/activate again."
(let ((original-definition (ad-get-orig-definition function))
(current-definition (if (ad-real-definition function)
;; we have a redefinition:
(if (not (memq ad-redefinition-action '(accept discard warn)))
(error "ad-handle-definition (see its doc): `%s' %s"
- function "illegally redefined")
+ function "invalidly redefined")
(if (eq ad-redefinition-action 'discard)
- (ad-real-fset function original-definition)
+ (ad-safe-fset function original-definition)
(ad-set-orig-definition function current-definition)
(if (eq ad-redefinition-action 'warn)
(message "ad-handle-definition: `%s' got redefined"
;; ==================================
(defun ad-activate (function &optional compile)
- "Activates all the advice information of an advised FUNCTION.
+ "Activate all the advice information of an advised FUNCTION.
If FUNCTION has a proper original definition then an advised
definition will be generated from FUNCTION's advice info and the
-definition of FUNCTION will be replaced with it. If a previously
-cached advised definition was available, it will be used. With an
-argument (compile is non-NIL) the resulting function (or a compilable
-cached definition) will also be compiled. Activation of an advised
-function that has an advice info but no actual pieces of advice is
-equivalent to a call to `ad-unadvise'. Activation of an advised
-function that has actual pieces of advice but none of them are enabled
-is equivalent to a call to `ad-deactivate'. The current advised
+definition of FUNCTION will be replaced with it. If a previously
+cached advised definition was available, it will be used.
+The optional COMPILE argument determines whether the resulting function
+or a compilable cached definition will be compiled. If it is negative
+no compilation will be performed, if it is positive or otherwise non-nil
+the resulting function will be compiled, if it is nil the behavior depends
+on the value of `ad-default-compilation-action' (which see).
+Activation of an advised function that has an advice info but no actual
+pieces of advice is equivalent to a call to `ad-unadvise'. Activation of
+an advised function that has actual pieces of advice but none of them are
+enabled is equivalent to a call to `ad-deactivate'. The current advised
definition will always be cached for later usage."
(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)
- (ad-handle-definition 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)))))))
+ (if ad-activate-on-top-level
+ ;; avoid recursive calls to `ad-activate':
+ (ad-with-auto-activation-disabled
+ (if (not (ad-is-advised function))
+ (error "ad-activate: `%s' is not advised" function)
+ (ad-handle-definition 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)))))))))
+
+(defalias 'ad-activate-on 'ad-activate)
(defun ad-deactivate (function)
- "Deactivates the advice of an actively advised FUNCTION.
+ "Deactivate the advice of an actively advised FUNCTION.
If FUNCTION has a proper original definition, then the current
-definition of FUNCTION will be replaced with it. All the advice
+definition of FUNCTION will be replaced with it. All the advice
information will still be available so it can be activated again with
a call to `ad-activate'."
(interactive
(if (not (ad-get-orig-definition function))
(error "ad-deactivate: `%s' has no original definition"
function)
- (ad-real-fset function (ad-get-orig-definition function))
+ (ad-safe-fset function (ad-get-orig-definition function))
(ad-set-advice-info-field function 'active nil)
(eval (ad-make-hook-form function 'deactivation))
function)))))
(defun ad-update (function &optional compile)
"Update the advised definition of FUNCTION if its advice is active.
-With a prefix argument or if the current definition is compiled compile the
-resulting advised definition."
+See `ad-activate' for documentation on the optional COMPILE argument."
(interactive
(list (ad-read-advised-function
"Update advised definition of: " 'ad-is-active)))
(if (ad-is-active function)
- (ad-activate
- function (or compile (ad-compiled-p (symbol-function function))))))
+ (ad-activate function compile)))
(defun ad-unadvise (function)
- "Deactivates FUNCTION and then removes all its advice information.
+ "Deactivate FUNCTION and then remove all its advice information.
If FUNCTION was not advised this will be a noop."
(interactive
(list (ad-read-advised-function "Unadvise function: ")))
(ad-pop-advised-function function))))
(defun ad-recover (function)
- "Tries to recover FUNCTION's original definition and unadvises it.
-This is more low-level than `ad-unadvise' because it does not do any
-deactivation which might run hooks and get into other trouble.
+ "Try to recover FUNCTION's original definition, and unadvise it.
+This is more low-level than `ad-unadvise' in that it does not do
+deactivation, which might run hooks and get into other trouble.
Use in emergencies."
;; Use more primitive interactive behavior here: Accept any symbol that's
;; currently defined in obarray, not necessarily with a function definition:
(completing-read "Recover advised function: " obarray nil t))))
(cond ((ad-is-advised function)
(cond ((ad-get-orig-definition function)
- (ad-real-fset function (ad-get-orig-definition function))
+ (ad-safe-fset function (ad-get-orig-definition function))
(ad-clear-orig-definition function)))
(ad-set-advice-info function nil)
(ad-pop-advised-function function))))
(defun ad-activate-regexp (regexp &optional compile)
- "Activates functions with an advice name containing a REGEXP match.
-With prefix argument compiles resulting advised definitions."
+ "Activate functions with an advice name containing a REGEXP match.
+This activates the advice for each function
+that has at least one piece of advice whose name includes a match for REGEXP.
+See `ad-activate' for documentation on the optional COMPILE argument."
(interactive
(list (ad-read-regexp "Activate via advice regexp: ")
current-prefix-arg))
(ad-activate function compile))))
(defun ad-deactivate-regexp (regexp)
- "Deactivates functions with an advice name containing REGEXP match."
+ "Deactivate functions with an advice name containing REGEXP match.
+This deactivates the advice for each function
+that has at least one piece of advice whose name includes a match for REGEXP."
(interactive
(list (ad-read-regexp "Deactivate via advice regexp: ")))
(ad-do-advised-functions (function)
(ad-deactivate function))))
(defun ad-update-regexp (regexp &optional compile)
- "Updates functions with an advice name containing a REGEXP match.
-With prefix argument compiles resulting advised definitions."
+ "Update functions with an advice name containing a REGEXP match.
+This reactivates the advice for each function
+that has at least one piece of advice whose name includes a match for REGEXP.
+See `ad-activate' for documentation on the optional COMPILE argument."
(interactive
(list (ad-read-regexp "Update via advice regexp: ")
current-prefix-arg))
(ad-update function compile))))
(defun ad-activate-all (&optional compile)
- "Activates all currently advised functions.
-With prefix argument compiles resulting advised definitions."
+ "Activate all currently advised functions.
+See `ad-activate' for documentation on the optional COMPILE argument."
(interactive "P")
(ad-do-advised-functions (function)
- (ad-activate function)))
+ (ad-activate function compile)))
(defun ad-deactivate-all ()
- "Deactivates all currently advised functions."
+ "Deactivate all currently advised functions."
(interactive)
(ad-do-advised-functions (function)
(ad-deactivate function)))
(defun ad-update-all (&optional compile)
- "Updates all currently advised functions.
-With prefix argument compiles resulting advised definitions."
+ "Update all currently advised functions.
+With prefix argument, COMPILE resulting advised definitions."
(interactive "P")
(ad-do-advised-functions (function)
(ad-update function compile)))
(defun ad-unadvise-all ()
- "Unadvises all currently advised functions."
+ "Unadvise all currently advised functions."
(interactive)
(ad-do-advised-functions (function)
(ad-unadvise function)))
(defun ad-recover-all ()
- "Recovers all currently advised functions. Use in emergencies."
+ "Recover all currently advised functions. Use in emergencies.
+To recover a function means to try to find its original (pre-advice)
+definition, and delete all advice.
+This is more low-level than `ad-unadvise' in that it does not do
+deactivation, which might run hooks and get into other trouble."
(interactive)
(ad-do-advised-functions (function)
- (condition-case ignore-errors
+ (condition-case nil
(ad-recover function)
(error nil))))
;; Completion alist of legal `defadvice' flags
(defvar ad-defadvice-flags
- '(("protect") ("disable") ("activate") ("compile") ("preactivate")))
+ '(("protect") ("disable") ("activate")
+ ("compile") ("preactivate") ("freeze")))
;;;###autoload
(defmacro defadvice (function args &rest body)
- "Defines a piece of advice for FUNCTION (a symbol).
-
- (defadvice <function> (<class> <name> [<position>] [<arglist>] {<flags>}*)
- [ [<documentation-string>] [<interactive-form>] ]
- {<body-form>}* )
-
-<function> ::= name of the function to be advised
-<class> ::= before | around | after | activation | deactivation
-<name> ::= non-NIL symbol that names this piece of advice
-<position> ::= first | last | <number> (optional, defaults to `first',
- see also `ad-add-advice')
-<arglist> ::= an optional argument list to be used for the advised function
- instead of the argument list of the original. The first one found in
- before/around/after advices will be used.
-<flags> ::= protect | disable | activate | compile | preactivate
+ "Define a piece of advice for FUNCTION (a symbol).
+The syntax of `defadvice' is as follows:
+
+ \(defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
+ [DOCSTRING] [INTERACTIVE-FORM]
+ BODY... )
+
+FUNCTION ::= Name of the function to be advised.
+CLASS ::= `before' | `around' | `after' | `activation' | `deactivation'.
+NAME ::= Non-nil symbol that names this piece of advice.
+POSITION ::= `first' | `last' | NUMBER. Optional, defaults to `first',
+ see also `ad-add-advice'.
+ARGLIST ::= An optional argument list to be used for the advised function
+ instead of the argument list of the original. The first one found in
+ before/around/after-advices will be used.
+FLAG ::= `protect'|`disable'|`activate'|`compile'|`preactivate'|`freeze'.
All flags can be specified with unambiguous initial substrings.
-<documentation-string> ::= optional documentation for this piece of advice
-<interactive-form> ::= optional interactive form to be used for the advised
- function. The first one found in before/around/after advices will be used.
-<body-form> ::= any s-expression
+DOCSTRING ::= Optional documentation for this piece of advice.
+INTERACTIVE-FORM ::= Optional interactive form to be used for the advised
+ function. The first one found in before/around/after-advices will be used.
+BODY ::= Any s-expression.
Semantics of the various flags:
`protect': The piece of advice will be protected against non-local exits in
-any code that precedes it. If any around advice of a function is protected
-then automatically all around advices will be protected (the complete onion).
+any code that precedes it. If any around-advice of a function is protected
+then automatically all around-advices will be protected (the complete onion).
`activate': All advice of FUNCTION will be activated immediately if
-FUNCTION has been properly defined prior to the defadvice.
+FUNCTION has been properly defined prior to this application of `defadvice'.
`compile': In conjunction with `activate' specifies that the resulting
advised function should be compiled.
-`disable': The defined advice will be disabled, hence it will not be used
+`disable': The defined advice will be disabled, hence, it will not be used
during activation until somebody enables it.
-`preactivate': Preactivates the advised FUNCTION at macro expansion/compile
-time. This generates a compiled advised definition according to the current
-advice state that will be used during activation if appropriate. Only use
-this if the defadvice gets actually compiled (with a v18 byte-compiler put
-the defadvice into the body of a defun).
+`preactivate': Preactivates the advised FUNCTION at macro-expansion/compile
+time. This generates a compiled advised definition according to the current
+advice state that will be used during activation if appropriate. Only use
+this if the `defadvice' gets actually compiled.
+
+`freeze': Expands the `defadvice' into a redefining `defun/defmacro' according
+to this particular single advice. No other advice information will be saved.
+Frozen advices cannot be undone, they behave like a hard redefinition of
+the advised function. `freeze' implies `activate' and `preactivate'. The
+documentation of the advised function can be dumped onto the `DOC' file
+during preloading.
-Look at the file advice.el for comprehensive documentation."
+See Info node `(elisp)Advising Functions' for comprehensive documentation."
(if (not (ad-name-p function))
- (error "defadvice: Illegal function name: %s" function))
+ (error "defadvice: Invalid function name: %s" function))
(let* ((class (car args))
(name (if (not (ad-class-p class))
- (error "defadvice: Illegal advice class: %s" class)
- (nth 1 args)))
+ (error "defadvice: Invalid advice class: %s" class)
+ (nth 1 args)))
(position (if (not (ad-name-p name))
- (error "defadvice: Illegal advice name: %s" name)
- (setq args (nthcdr 2 args))
- (if (ad-position-p (car args))
- (prog1 (car args)
- (setq args (cdr args))))))
+ (error "defadvice: Invalid advice name: %s" name)
+ (setq args (nthcdr 2 args))
+ (if (ad-position-p (car args))
+ (prog1 (car args)
+ (setq args (cdr args))))))
(arglist (if (listp (car args))
(prog1 (car args)
(setq args (cdr args)))))
(mapcar
(function
(lambda (flag)
- (let ((completion
- (try-completion (symbol-name flag) ad-defadvice-flags)))
- (cond ((eq completion t) flag)
- ((assoc completion ad-defadvice-flags)
- (intern completion))
- (t (error "defadvice: Illegal or ambiguous flag: %s"
- flag))))))
+ (let ((completion
+ (try-completion (symbol-name flag) ad-defadvice-flags)))
+ (cond ((eq completion t) flag)
+ ((assoc completion ad-defadvice-flags)
+ (intern completion))
+ (t (error "defadvice: Invalid or ambiguous flag: %s"
+ flag))))))
args))
(advice (ad-make-advice
name (memq 'protect flags)
(not (memq 'disable flags))
- (` (advice lambda (, arglist) (,@ body)))))
+ `(advice lambda ,arglist ,@body)))
(preactivation (if (memq 'preactivate flags)
(ad-preactivate-advice
function advice class position))))
;; Now for the things to be done at evaluation time:
- (` (progn
- (ad-add-advice '(, function) '(, advice) '(, class) '(, position))
- (,@ (if preactivation
- (` ((ad-set-cache
- '(, function)
- ;; the function will get compiled:
- (, (cond ((ad-macro-p (car preactivation))
- (` (ad-macrofy
- (function
- (, (ad-lambdafy
- (car preactivation)))))))
- (t (` (function
- (, (car preactivation)))))))
- '(, (car (cdr preactivation))))))))
- (,@ (if (memq 'activate flags)
- (` ((ad-activate '(, function)
- (, (if (memq 'compile flags) t)))))))
- '(, function)))))
+ (if (memq 'freeze flags)
+ ;; jwz's idea: Freeze the advised definition into a dumpable
+ ;; defun/defmacro whose docs can be written to the DOC file:
+ (ad-make-freeze-definition function advice class position)
+ ;; the normal case:
+ `(progn
+ (ad-add-advice ',function ',advice ',class ',position)
+ ,@(if preactivation
+ `((ad-set-cache
+ ',function
+ ;; the function will get compiled:
+ ,(cond ((ad-macro-p (car preactivation))
+ `(ad-macrofy
+ (function
+ ,(ad-lambdafy
+ (car preactivation)))))
+ (t `(function
+ ,(car preactivation))))
+ ',(car (cdr preactivation)))))
+ ,@(if (memq 'activate flags)
+ `((ad-activate ',function
+ ,(if (memq 'compile flags) t))))
+ ',function))))
;; @@ Tools:
;; =========
(defmacro ad-with-originals (functions &rest body)
- "Binds FUNCTIONS to their original definitions and executes BODY.
+ "Binds FUNCTIONS to their original definitions and execute BODY.
For any members of FUNCTIONS that are not currently advised the rebinding will
-be a noop. Any modifications done to the definitions of FUNCTIONS will be
+be a noop. Any modifications done to the definitions of FUNCTIONS will be
undone on exit of this macro."
(let* ((index -1)
;; Make let-variables to store current definitions:
(current-bindings
(mapcar (function
(lambda (function)
- (setq index (1+ index))
- (list (intern (format "ad-oRiGdEf-%d" index))
- (` (symbol-function '(, function))))))
+ (setq index (1+ index))
+ (list (intern (format "ad-oRiGdEf-%d" index))
+ `(symbol-function ',function))))
functions)))
- (` (let (, current-bindings)
- (unwind-protect
- (progn
- (,@ (progn
- ;; Make forms to redefine functions to their
- ;; original definitions if they are advised:
- (setq index -1)
- (mapcar
- (function
- (lambda (function)
- (setq index (1+ index))
- (` (ad-real-fset
- '(, function)
- (or (ad-get-orig-definition '(, function))
- (, (car (nth index current-bindings))))))))
- functions)))
- (,@ body))
- (,@ (progn
- ;; Make forms to back-define functions to the definitions
- ;; they had outside this macro call:
- (setq index -1)
- (mapcar
- (function
- (lambda (function)
- (setq index (1+ index))
- (` (ad-real-fset
- '(, function)
- (, (car (nth index current-bindings)))))))
- functions))))))))
+ `(let ,current-bindings
+ (unwind-protect
+ (progn
+ ,@(progn
+ ;; Make forms to redefine functions to their
+ ;; original definitions if they are advised:
+ (setq index -1)
+ (mapcar
+ (function
+ (lambda (function)
+ (setq index (1+ index))
+ `(ad-safe-fset
+ ',function
+ (or (ad-get-orig-definition ',function)
+ ,(car (nth index current-bindings))))))
+ functions))
+ ,@body)
+ ,@(progn
+ ;; Make forms to back-define functions to the definitions
+ ;; they had outside this macro call:
+ (setq index -1)
+ (mapcar
+ (function
+ (lambda (function)
+ (setq index (1+ index))
+ `(ad-safe-fset
+ ',function
+ ,(car (nth index current-bindings)))))
+ functions))))))
(if (not (get 'ad-with-originals 'lisp-indent-hook))
(put 'ad-with-originals 'lisp-indent-hook 1))
-;; @@ Advising `defun', `defmacro', `fset' and `documentation'
-;; ===========================================================
-;; Use the advice mechanism to advise defun/defmacro/fset so we can forward
-;; advise functions that might be defined later during load/autoload.
-;; Enabling forward advice was the original motivation for doing this, it
-;; has now been generalized to running definition hooks so other packages
-;; can make use of this sort of functionality too.
-
-(defvar ad-defined-function nil)
-
-(defun ad-activate-defined-function (&optional function)
- "Activates the advice of an advised and defined FUNCTION.
-If the current definition of FUNCTION is byte-compiled then the advised
-definition will be compiled too. FUNCTION defaults to the value of
-`ad-defined-function'."
- (if (and (null function)
- ad-defined-function)
- (setq function ad-defined-function))
- (if (and (ad-is-advised function)
- (ad-real-definition function))
- (ad-activate function (ad-compiled-p (symbol-function function)))))
-
-;; Define some subr arglists for the benefit of v18. Do this here because
-;; they have to be available at compile/preactivation time. Use the same
-;; as defined in Lemacs' DOC file:
-(cond ((not ad-emacs19-p)
- (ad-define-subr-args 'documentation '(fun1))
- (ad-define-subr-args 'fset '(sym newdef))))
-
-;; A kludge to get `defadvice's compiled with a v18 compiler:
-(defun ad-execute-defadvices ()
-
-(defadvice defun (after ad-definition-hooks first disable preact)
- "Whenever a function gets re/defined with `defun' all hook functions
-in `ad-definition-hooks' will be run after the re/definition with
-`ad-defined-function' bound to the name of the function."
- (let ((ad-defined-function (ad-get-arg 0)))
- (run-hooks 'ad-definition-hooks)))
-
-(defadvice defmacro (after ad-definition-hooks first disable preact)
- "Whenever a macro gets re/defined with `defmacro' all hook functions
-in `ad-definition-hooks' will be run after the re/definition with
-`ad-defined-function' bound to the name of the function."
- (let ((ad-defined-function (ad-get-arg 0)))
- (run-hooks 'ad-definition-hooks)))
-
-(defadvice fset (after ad-definition-hooks first disable preact)
- "Whenever a function gets re/defined with `fset' all hook functions
-in `ad-definition-hooks' will be run after the re/definition with
-`ad-defined-function' bound to the name of the function. This advice was
-mainly created to handle forward-advice for byte-compiled files created
-by jwz's byte-compiler used in Lemacs.
-CAUTION: If you need the primitive `fset' behavior either deactivate
- its advice or use `ad-real-fset' instead!"
- (let ((ad-defined-function (ad-get-arg 0)))
- (run-hooks 'ad-definition-hooks)))
-
-;; Needed for GNU Emacs-19 (in v18s and Lemacs this is just a noop):
-(defadvice defalias (after ad-definition-hooks first disable preact)
- "Whenever a function gets re/defined with `defalias' all hook functions
-in `ad-definition-hooks' will be run after the re/definition with
-`ad-defined-function' bound to the name of the function. This advice was
-mainly created to handle forward-advice for byte-compiled files created
-by jwz's byte-compiler used in GNU Emacs-19."
- (let ((ad-defined-function (ad-get-arg 0)))
- ;; The new `byte-compile' uses `defalias' to set the definition which
- ;; leads to infinite recursion if it gets to use the advised version
- ;; (with `fset' this didn't matter because the compiled `byte-compile'
- ;; called it via its byte-code). Should there be a general provision to
- ;; avoid recursive application of definition hooks?
- (ad-with-originals (defalias)
- (run-hooks 'ad-definition-hooks))))
-
-;; Needed for GNU Emacs-19 (seems to be an identical copy of `defalias',
-;; it is used by simple.el and might be used later, hence, advise it):
-(defadvice define-function (after ad-definition-hooks first disable preact)
- "Whenever a function gets re/defined with `define-function' all hook
-functions in `ad-definition-hooks' will be run after the re/definition with
-`ad-defined-function' bound to the name of the function."
- (let ((ad-defined-function (ad-get-arg 0)))
- (ad-with-originals (define-function)
- (run-hooks 'ad-definition-hooks))))
+;; @@ Advising `documentation':
+;; ============================
+;; 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."
ad-return-value (match-beginning 1) (match-end 1)))))
(cond ((ad-is-advised function)
(setq ad-return-value (ad-make-advised-docstring function))
- ;; Handle GNU Emacs-19's optional `raw' argument:
+ ;; Handle optional `raw' argument:
(if (not (ad-get-arg 1))
(setq ad-return-value
(substitute-command-keys ad-return-value))))))))
-
-
-) ;; end of ad-execute-defadvices
-
-;; Only run this once we are compiled. Expanding the defadvices
-;; with only interpreted advice functions available takes forever:
-(if (ad-compiled-p (symbol-function 'ad-execute-defadvices))
- (ad-execute-defadvices))
-
-
-;; @@ Forward advice support for jwz's byte-compiler (M-x serious-HACK-mode-on)
-;; ============================================================================
-;; Jamie Zawinski's optimizing byte-compiler used in v19 (and by some daring
-;; folks in v18) produces compiled files that do not define functions via
-;; explicit calls to `defun/defmacro', it rather uses `fset' for functions with
-;; documentation strings, and hunks of byte-code for sets of functions without
-;; any documentation. In Jamie's byte-compiler a series of compiled functions
-;; without docstrings get hunked as
-;; (progn (fset 'f1 <code1>) (fset 'f2 <code2>) ...).
-;; The resulting progn will be compiled and the compiled form will be written
-;; to the compiled file as `(byte-code [progn-code] [constants] [depth])'. To
-;; handle forward advice we have to know when functions get defined so we can
-;; activate any advice there might be. For standard v18 byte-compiled files
-;; we can do this by simply advising `defun/defmacro' because these subrs are
-;; evaluated explicitly when such a file is loaded. For Jamie's v19 compiler
-;; our only choice is to additionally advise `fset' and change the subr
-;; `byte-code' such that it analyzes its byte-code string looking for fset's
-;; when we are currently loading a file. In v19 the general overhead caused
-;; by the advice of `byte-code' shouldn't be too bad, because byte-compiled
-;; functions do not call byte-code explicitly (as done in v18). In v18 this
-;; is a problem because with the changed `byte-code' function function calls
-;; become more expensive.
-;;
-;; Wish-List:
-;; - special defining functions for use in byte-compiled files, e.g.,
-;; `byte-compile-fset' and `byte-code-tl' which do the same as their
-;; standard brothers, but which can be advised for forward advice without
-;; the problems that advising `byte-code' generates.
-;; - More generally, a symbol definition hook that could be used for
-;; forward advice and related purposes.
-;;
-;; Until then: For the analysis of the byte-code string we simply scan it for
-;; an `fset' opcode (M in ascii) that is preceded by two constant references,
-;; the first of which points to the function name and the second to its code.
-;; A constant reference can either be a simple one-byte one, or a three-byte
-;; one if the function has more than 64 constants. The scanning can pretty
-;; efficiently be done with a regular expression. Here it goes:
-
-;; Have to hardcode these opcodes if I don't
-;; want to require the byte-compiler:
-(defvar byte-constant 192)
-(defvar byte-constant-limit 64)
-(defvar byte-constant2 129)
-(defvar byte-fset 77)
-
-;; Matches a byte-compiled fset operation with two constant arguments:
-(defvar ad-byte-code-fset-regexp
- (let* ((constant-reference
- (format "[%s-%s]"
- (char-to-string byte-constant)
- (char-to-string (+ byte-constant (1- byte-constant-limit)))))
- (constant2-reference
- ;; \0 makes it necessary to use concat instead of format in 18.57:
- (concat (char-to-string byte-constant2) "[\0-\377][\0-\377]"))
- (fset-opcode (char-to-string byte-fset)))
- (concat "\\(" constant-reference "\\|" constant2-reference "\\)"
- "\\(" constant-reference "\\|" constant2-reference "\\)"
- fset-opcode)))
-
-(defun ad-find-fset-in-byte-code (code constants start)
- ;;"Finds the first two-constant fset operation in CODE after START.
- ;;Returns a three element list consisting of the name of the defined
- ;;function, its code (both taken from the CONSTANTS vector), and an
- ;;advanced start index."
- (let ((start
- ;; The odd case that this regexp matches something that isn't an
- ;; actual fset operation is handled by additional tests and a
- ;; condition handler in ad-scan-byte-code-for-fsets:
- (string-match ad-byte-code-fset-regexp code start))
- name-index code-index)
- (cond (start
- (cond ((= (aref code start) byte-constant2)
- (setq name-index
- (+ (aref code (setq start (1+ start)))
- (* (aref code (setq start (1+ start))) 256)))
- (setq start (1+ start)))
- (t (setq name-index (- (aref code start) byte-constant))
- (setq start (1+ start))))
- (cond ((= (aref code start) byte-constant2)
- (setq code-index
- (+ (aref code (setq start (1+ start)))
- (* (aref code (setq start (1+ start))) 256)))
- (setq start (1+ start)))
- (t (setq code-index (- (aref code start) byte-constant))
- (setq start (1+ start))))
- (list (aref constants name-index)
- (aref constants code-index)
- ;; start points to fset opcode:
- start))
- (t nil))))
-
-(defun ad-scan-byte-code-for-fsets (ad-code ad-constants)
- ;; In case anything in here goes wrong we reset `byte-code' to its real
- ;; identity. In particular, the handler of the condition-case uses
- ;; `byte-code', so it better be the real one if we have an error:
- (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code))
- (condition-case ignore-errors
- (let ((fset-args '(0 0 0)))
- (while (setq fset-args (ad-find-fset-in-byte-code
- ad-code ad-constants
- (car (cdr (cdr fset-args)))))
- (if (and (symbolp (car fset-args))
- (fboundp (car fset-args))
- (eq (symbol-function (car fset-args))
- (car (cdr fset-args))))
- ;; We've found an fset that was executed during this call
- ;; to byte-code, and whose definition is still eq to the
- ;; current definition of the defined function:
- (let ((ad-defined-function (car fset-args)))
- (run-hooks 'ad-definition-hooks))))
- ;; Everything worked fine, readvise `byte-code':
- (ad-real-fset 'byte-code (symbol-function 'ad-advised-byte-code)))
- (error nil)))
-
-;; CAUTION: Don't try this at home!! Changing `byte-code' is a
-;; pretty suicidal activity.
-;; To allow v19 forward advice we cannot advise `byte-code' as a subr as
-;; we did for `defun' etc., because `ad-subr-args' of the advised
-;; `byte-code' would shield references to `ad-subr-args' in the body of
-;; v18 compiled advised subrs such as `defun', and, more importantly, the
-;; changed version of `byte-code' has to be as small and efficient as
-;; possible because it is used in every call to a compiled function.
-;; Hence, we previously saved its original definition and redefine it as
-;; the following function - yuck:
-
-;; The arguments will scope around the body of every byte-compiled
-;; function, hence they have to be obscure enough to not be equal to any
-;; global or argument variable referenced by any compiled function:
-(defun ad-advised-byte-code-definition (ad-cOdE ad-cOnStAnTs ad-dEpTh)
- "Modified version of `byte-code' subr used by the advice package.
-`byte-code' has been modified to allow automatic activation of forward
-advice for functions that are defined in byte-compiled files generated
-by jwz's byte-compiler (as standardly used in v19s).
-See `ad-real-byte-code' for original documentation."
- (prog1 (ad-real-byte-code ad-cOdE ad-cOnStAnTs ad-dEpTh)
- (if load-in-progress
- (ad-scan-byte-code-for-fsets ad-cOdE ad-cOnStAnTs))))
-
-(ad-real-byte-codify 'ad-advised-byte-code-definition)
-
-;; ad-advised-byte-code cannot be defined with `defun', because that would
-;; use `byte-code' for its body --> major disaster if forward advice is
-;; enabled and this file gets loaded:
-(ad-real-fset
- 'ad-advised-byte-code (symbol-function 'ad-advised-byte-code-definition))
-
-(defun ad-recover-byte-code ()
- "Recovers the real `byte-code' functionality."
- (interactive)
- (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code)))
-
-;; Make sure this is usable even if `byte-code' is screwed up:
-(ad-real-byte-codify 'ad-recover-byte-code)
-
-;; Store original stack sizes because we might have to change them:
-(defvar ad-orig-max-lisp-eval-depth max-lisp-eval-depth)
-(defvar ad-orig-max-specpdl-size max-specpdl-size)
-
-(defun ad-adjust-stack-sizes (&optional reset)
- "Increases stack sizes for the advised `byte-code' function.
-When called with a prefix argument the stack sizes will be reset
-to their original values. Calling this function should only be necessary
-if you get stack overflows because you run highly recursive v18 compiled
-code in a v19 Emacs with definition hooks enabled."
- (interactive "P")
- (cond (reset
- (setq max-lisp-eval-depth ad-orig-max-lisp-eval-depth)
- (setq max-specpdl-size ad-orig-max-specpdl-size))
- (t ;; The redefined `byte-code' needs more execution stack
- ;; (5 cells per function invocation) and variable stack
- ;; (3 vars per function invocation):
- (setq max-lisp-eval-depth (* ad-orig-max-lisp-eval-depth 3))
- (setq max-specpdl-size
- (+ ad-orig-max-specpdl-size (* (/ max-lisp-eval-depth 5) 3))))))
-
-(defun ad-enable-definition-hooks ()
- ;;"Enables definition hooks by redefining definition primitives.
- ;;Activates the advice of defun/defmacro/fset and possibly redefines
- ;;`byte-code' if a v19 byte-compiler is used. Redefining these primitives
- ;;might lead to problems. Use `ad-disable-definition-hooks' or
- ;;`ad-stop-advice' in such a case to establish a safe state."
- (ad-dolist (definer '(defun defmacro fset defalias define-function))
- (ad-enable-advice definer 'after 'ad-definition-hooks)
- (ad-activate definer 'compile))
- (cond (ad-use-jwz-byte-compiler
- (ad-real-byte-codify 'ad-advised-byte-code)
- (ad-real-byte-codify 'ad-scan-byte-code-for-fsets)
- ;; Now redefine byte-code...
- (ad-real-fset 'byte-code (symbol-function 'ad-advised-byte-code))
- ;; Only increase stack sizes in v18s, even though old-fashioned
- ;; v18 byte-code might be run in a v19, in which case one can call
- ;; `ad-adjust-stack-sizes' interactively if stacks become too small:
- (if (not ad-emacs19-p)
- (ad-adjust-stack-sizes)))))
-
-(defun ad-disable-definition-hooks ()
- ;;"Disables definition hooks by resetting definition primitives."
- (ad-recover-byte-code)
- (ad-dolist (definer '(defun defmacro fset defalias define-function))
- (ad-disable-advice definer 'after 'ad-definition-hooks)
- (ad-update definer))
- (if (not ad-emacs19-p)
- (ad-adjust-stack-sizes 'reset)))
-
-(ad-real-byte-codify 'ad-disable-definition-hooks)
;; @@ Starting, stopping and recovering from the advice package magic:
;; ===================================================================
-;;;###autoload
(defun ad-start-advice ()
- "Redefines some primitives to start the advice magic.
-If `ad-activate-on-definition' is t then advice information will
-automatically get activated whenever an advised function gets defined or
-redefined. This will enable goodies such as forward advice and
-automatically enable function definition hooks. If its value is nil but
-the value of `ad-enable-definition-hooks' is t then definition hooks
-will be enabled without having automatic advice activation, otherwise
-function definition hooks will be disabled too. If definition hooks are
-enabled then functions stored in `ad-definition-hooks' are run whenever
-a function gets defined or redefined."
+ "Start the automatic advice handling magic."
(interactive)
+ ;; Advising `ad-activate-internal' means death!!
+ (ad-set-advice-info 'ad-activate-internal nil)
+ (ad-safe-fset 'ad-activate-internal 'ad-activate)
(ad-enable-advice 'documentation 'after 'ad-advised-docstring)
- (ad-activate 'documentation 'compile)
- (if (or ad-activate-on-definition
- ad-enable-definition-hooks)
- (ad-enable-definition-hooks)
- (ad-disable-definition-hooks))
- (setq ad-definition-hooks
- (if ad-activate-on-definition
- (if (memq 'ad-activate-defined-function ad-definition-hooks)
- ad-definition-hooks
- (cons 'ad-activate-defined-function ad-definition-hooks))
- (delq 'ad-activate-defined-function ad-definition-hooks))))
+ (ad-activate 'documentation 'compile))
(defun ad-stop-advice ()
- "Undefines some primitives to stop the advice magic.
-This can also be used to recover from advice related emergencies."
+ "Stop the automatic advice handling magic.
+You should only need this in case of Advice-related emergencies."
(interactive)
- (ad-recover-byte-code)
+ ;; Advising `ad-activate-internal' means death!!
+ (ad-set-advice-info 'ad-activate-internal nil)
(ad-disable-advice 'documentation 'after 'ad-advised-docstring)
(ad-update 'documentation)
- (ad-disable-definition-hooks)
- (setq ad-definition-hooks
- (delq 'ad-activate-defined-function ad-definition-hooks)))
-
-(ad-real-byte-codify 'ad-stop-advice)
+ (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off))
(defun ad-recover-normality ()
- "Undoes all advice related redefinitions and unadvises everything.
+ "Undo all advice related redefinitions and unadvises everything.
Use only in REAL emergencies."
(interactive)
- (ad-recover-byte-code)
+ ;; Advising `ad-activate-internal' means death!!
+ (ad-set-advice-info 'ad-activate-internal nil)
+ (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off)
(ad-recover-all)
(setq ad-advised-functions nil))
-(ad-real-byte-codify 'ad-recover-normality)
-
-(if (and ad-start-advice-on-load
- ;; ...but only if we are compiled:
- (ad-compiled-p (symbol-function 'ad-execute-defadvices)))
- (ad-start-advice))
+(ad-start-advice)
(provide 'advice)
+;;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0
;;; advice.el ends here
HCoop / bpt / emacs.git / blobdiff