NetNews Usenet Archive 1992 #30/NN_1992_30.iso/spool/gnu/emacs/sources/863

Internet Message Format | 1992-12-15 | 67.4 KB

Path: sparky!uunet!zaphod.mps.ohio-state.edu!darwin.sura.net!rsg1.er.usgs.gov!ukma!cs.widener.edu!dsinc!ub!acsu.buffalo.edu!hans
From: [e-mail] (Hans Chalupsky)
Newsgroups: gnu.emacs.sources
Subject: advice.el - code
Message-ID: <[e-mail]>
Date: 15 Dec 92 05:12:04 GMT
Sender: [e-mail]
Distribution: gnu
Organization: State University of New York at Buffalo/Comp Sci
Lines: 1649
Nntp-Posting-Host: hadar.cs.buffalo.edu

Here's the code promised in the previous announcement message. Look for
the ;; eof at the end of the message to check whether you got the complete
file (about 70k).

Enjoy,

Hans

[e-mail]                       Thm 4.2.7: The number of polar bears
                                                     at an italian funeral is
                                                     always even.

;; ------------------------ cut here -----------------------------------------
;; -*-Emacs-Lisp-*-
;;
;; Copyright (C) 1992 Hans Chalupsky
;;
;; File:     advice.el
;; Revision: $Revision: 1.7 $
;; Author:   Hans Chalupsky ([e-mail])
;; Created:   Date: 92/12/08 17:37:33
;; Modified: $Date: 92/12/14 22:41:49 $
;;
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; A copy of the GNU General Public License can be obtained from this
;; program's author (send electronic mail to [e-mail]) or from
;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;; 02139, USA.
;;
;;
;; Description:
;; ============
;; This package implements a full-fledged Lisp-style advice mechanism
;; 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
;; 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.
;;
;; Highlights:
;; ===========
;; - Clean definition of multiple, named before/around/after advices
;;   for functions, macros, subrs and special forms
;; - Full control over the arguments an advised function will receive,
;;   the binding environment in which it will be executed, as well as the
;;   value it will return.
;; - Allows redefinition of interactive behavior of functions and subrs,
;;   as well as making previously non-interactive functions and subrs
;;   interactive.
;; - Every piece of advice can have a documentation string which will be
;;   combined with the original documentation of the advised function
;; - Documentation indirection ensures that command-key substitution of
;;   documentation strings occurs when the documentation function is called,
;;   and not when the advised function is constructed.
;; - Forward advice is possible, that is functions which have autoload
;;   definitions, or functions which might be defined later during a
;;   load/autoload can be advised without having to preload the file in
;;   which they are defined.
;; - Forward redefinition is possible because around advice can be used to
;;   completely redefine a function.
;; - The execution of every piece of advice can be protected against error
;;   and non-local exits in preceding code or advices.
;; - Advised functions can be byte-compiled.
;; - Separation of advice definition and activation/deactivation
;; - 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 file either via anonymous ftp from
;; ftp.cs.buffalo.edu (128.205.32.9) with pathname /pub/Emacs/advice.el,
;; or send email to [e-mail] and I'll mail it to you.
;;
;; Overview:
;; =========
;; This file was subject to serious documentation overkill, and hence had to
;; be organized into the following parts (search for the items in double
;; quotes to skip to that part):
;;
;;   1) Initial information     (short but insufficient)
;;   2) "General Documentation" (boring and/or confusing)
;;   3) "Foo games", a tutorial (hopefully less boring; for people who
;;                               like to learn by example)
;;   4) "Advice Implementation" (boring code)
;;   5) "Advising DEFUN"        (exiting application of advice to
;;                               bootstrap parts of the system)
;;
;; Restrictions:
;; =============
;; - When an advised subr is called directly from other subrs or C-code
;;   it will not exhibit the advised behavior. The same holds for advised
;;   macros which were expanded during byte-compilation before their advice
;;   was activated.
;; - This package was developed under GNU-Emacs version 18.57. For different
;;   versions your mileage may vary. In particular, running this under
;;   version 19 will probably need some work.
;;
;; Credits:
;; ========
;; This package is an extension and generalization of packages such as
;; insert-hooks.el written by Noah S. Friedman ([e-mail]),
;; and advise.el written by Raul J. Acevedo ([e-mail]). Some ideas
;; used in here come from these packages, others come from the various Lisp
;; advice mechanisms I've come across so far, and a few are simply mine.
;;
;; Installation:
;; =============
;; Put this file somewhere into your Emacs load-path, byte-compile it for
;; efficiency, and put the following autoload declaration into your .emacs
;;
;;    (autoload 'defadvice "advice" "Define a piece of advice" nil t)
;;
;; or explicitly load it with (require 'advice) or (load "advice").
;;
;; Comments, suggestions, bug reports
;; ==================================
;; are strongly appreciated, please email them to [e-mail].
;; Also feel free to mail me any questions you might have about advice.el.
;;
;; Motivation:
;; ===========
;; Before I go on explaining how advice works, here are three examples how
;; this package can be used. The first two are very useful, the third one
;; is just a joke:
;;
;;(defadvice switch-to-buffer (before existing-buffer activate)
;;  "  Switch to existing buffers only when called interactively, unless
;;when called with a prefix argument."
;;  (interactive
;;   (list (call-interactively
;;          (if (call-interactively '(lambda (arg) (interactive "P") arg))
;;              '(lambda (buffer) (interactive "BSwitch to buffer: ") buffer)
;;           '(lambda (buffer) (interactive "bSwitch to buffer: ") buffer))))))
;;
;;(defadvice find-file (before existing-file activate)
;;  "  Find existing files only"
;;  (interactive "fFind file: "))
;;
;;(defadvice car (around interactive activate)
;;  "  Make car an interactive function."
;;   (interactive "xCar of list: ")
;;   ad-do-it
;;   (if (interactive-p)
;;       (message "%s" ad-return-value)))
;;
;; Planned Extensions:
;; ===================
;; - A caching mechanism that reuses previously constructed advised definitions
;;   on activation if the advice info of a function hasn't changed
;; - Associate an enable flag with every single piece of advice such that only
;;   enabled pieces of advice will be used on activation
;; - Generalize the advice mechanism to a transformation mechanism that uses
;;   a source definition according to some specification, changes it according
;;   to the pieces of advice defined on it, and transforms it into a target
;;   definition according to some specification. With this not just named
;;   functions but also hook-functions (values of some hook-variables) and
;;   definitions of any kind could make use of the advice facility.
;;
;; General Documentation:
;; ======================
;; The main means of defining a piece of advice for some function is the macro
;; defadvice (type C-h d defadvice to learn more about defadvice). There is no
;; interactive way of specifying a piece of advice. However, the following
;; interactive functions can be used to manipulate the state of functions
;; advised with defadvice:
;;
;; - ad-activate combines all currently defined pieces of advice of a certain
;;               function with its original definition and redefines it with
;;               this advised definition
;; - ad-deactivate defines a function back to its unadvised original definition
;;               but keeps all advice information around so it can be
;;               activated again
;; - 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).
;;               Use this function in emergencies only.
;;
;; - ad-remove-advice removes a particular piece of advice of a function.
;;               You still have to do ad-activate to activate the new state
;;               of advice.
;;
;; - ad-activate-all   activates all advised functions
;; - ad-deactivate-all deactivates all advised functions
;; - ad-unadvise-all   unadvises all advised functions
;; - ad-recover-all    recovers all advised functions
;;
;; - ad-compile byte-compiles a function/macro if it is compilable.
;;
;; The non-interactive function ad-add-advice can be used to add a piece of
;; advice to some function without using defadvice. This is useful if advice
;; has to be added somewhere by a function (also look at ad-make-advice).
;;
;; Separation of advice definition and activation, forward advice:
;; ===============================================================
;; Advising happens in two stages:
;;
;;   1) definition of various pieces of advice
;;   2) activation of all advice currently defined
;;
;; The advantage of this is that various pieces of advice can be defined before
;; they get combined into an advised definition which avoids unnecessary
;; constructions of intermediate advised definitions. The more important
;; advantage is that it allows a simple implementation of forward advice.
;; Advice information for a certain function accumulates as the value of the
;; advice-info property of the function symbol. This accumulation is completely
;; independent of the fact that that function might not yet be defined. The
;; special forms defun and defmacro have been advised to check whether the
;; function/macro they defined had advice information associated with it. If
;; so, the original definition will be saved, and then the advice will be
;; activated. When a file is loaded the functions/macros it defines are defined
;; with calls to defun/defmacro. Hence, we can forward advise functions/macros
;; which will be defined later during a load/autoload of some file.
;;
;; As an extension of the current activation method one could associate an
;; enable/disable flag with every piece of advice such that during activation
;; only enabled pieces of advice would be considered.
;;
;; Defining a piece of advice with defadvice:
;; ==========================================
;; A call to defadvice has the following syntax which is very similar
;; to the syntax of defun/defmacro with the difference that defadvice
;; does not specify any argument variables:
;;
;; (defadvice <function> (<class> <name> [<position>] {<flags>}*)
;;   [ [<documentation-string>] [(interactive ...)] ]
;;   {<body-form>}* )
;;
;; <function> is the name of the function to be advised.
;;
;; <class> is the class of the advice which has to be one of `before',
;; `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 symbol (nil can be used
;; for unnamed advices). Names uniquely identify a piece of advice in a
;; certain advice class, hence named advices can be redefined by defining
;; an advice with the same class and name. They can also be removed with
;; ad-remove-advice. Unnamed advices can not be redefined or removed, the
;; only way to get rid of them is to completely unadvise the function.
;;
;; An optional <position> specifies where in the current list of advices of
;; the specified <class> this new advice will be placed. <position> has to be
;; either `first', `last' or a number that specifies a zero-based position
;; (`first' is equivalent to 0). If no position is specified `first' will be
;; used as a default. If this call to defadvice redefines an already existing
;; advice (see above) then the position argument will be ignored and the
;; position of the already existing advice will be used.
;;
;; <flags> is a list of flags that specify further information about the
;; advice. An `activate' flag 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. `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. This flag will be ignored
;; unless `activate' is also specified.
;;
;; An optional <documentation-string> can be supplied to document the advice.
;; On activation of the advice it will be combined with the documentation of
;; the original function.
;;
;; An optional (interactive ...) form can be supplied to change/add interactive
;; behavior of the original function. If more than one advice has an
;; (interactive ...) specification then the one from the advice with the
;; smallest position will be used. `before' advices go before `around'
;; advices and only interactive specifications in these two advice classes
;; will be considered.
;;
;; 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
;; other side effects.
;;
;; Assembling advised definitions:
;; ===============================
;; Suppose a function/macro/subr/special-form has N pieces of before advice,
;; M pieces of around advice and K pieces of after advice. Assuming none of
;; the advices is protected, its advised definition will look like this
;; (body-form indices correspond to the position of the respective advice in
;; that advice class):
;;
;;    ([macro] lambda <arglist>
;;       [ [<combined-docstring>] [(interactive ...)] ]
;;       (let (ad-return-value)
;;         {<before-0-body-form>}*
;;               ....
;;         {<before-N-1-body-form>}*
;;         {<around-0-body-form>}*
;;            {<around-1-body-form>}*
;;                  ....
;;               {<around-M-1-body-form>}*
;;                  (setq ad-return-value
;;                        <apply original-body to arglist>)
;;               {<other-around-M-1-body-form>}*
;;                  ....
;;            {<other-around-1-body-form>}*
;;         {<other-around-0-body-form>}*
;;         {<after-0-body-form>}*
;;               ....
;;         {<after-K-1-body-form>}*
;;         ad-return-value))
;;
;; Macros and special forms will be redefined as macros, hence the optional
;; [macro] in the beginning of the definition.
;;
;; <arglist> is the argument list of the original function, hence values of
;; <arglist> variables can be accessed/changed in the body of an advice by
;; simply referring to them by their original name.  For subrs/special forms
;; <arglist> will be (&rest ad-subr-args) because argument lists of subrs
;; are not accessible.  Changing the value of ad-subr-args will change the
;; arguments supplied to the original subr.
;;
;; <combined-docstring> is the optional documentation string constructed from
;; the original documentation and the advice documentation strings.
;;
;; (interactive ...) is an optional interactive form either taken from the
;; original function or from a before/around advice. For advised interactive
;; subrs that do not have an interactive form specified in any advice we
;; have to use (interactive) and then call the subr interactively if the
;; advised function was called interactively, because the interactive
;; specification of subrs is not accessible. This is the only case where
;; changing the values of arguments will not have an affect because they
;; will be reset by the interactive specification of the subr. If this is a
;; problem one can always specify an interactive form in a before/around
;; 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
;; the forms of the wrapped or surrounded forms should go with the special
;; 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
;;      <apply original-body 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
;; piece of advice had an error or a non-local exit. If any around advice is
;; protected then the whole around advice onion will be protected.
;;
;; Accessing argument bindings of arbitrary functions:
;; ===================================================
;; Some functions (such as trace) need a general method of accessing the
;; names and bindings of the arguments of an advised function. To do that
;; within an advice one can use the special keyword ad-arg-bindings which
;; is a text macro that will be substituted with a form that will evaluate
;; to a list of binding specifications, one for every argument variable.
;; These binding specifications can then be examined in the body of the advice.
;; For example, somewhere in an advice we could do this:
;;
;;   (let* ((bindings ad-arg-bindings)
;;          (firstarg (car bindings))
;;          (secondarg (car (cdr bindings))))
;;     ;; Print info about first argument
;;     (print (format "%s=%s (%s)"
;;                    (ad-arg-binding-field firstarg 'name)
;;                    (ad-arg-binding-field firstarg 'value)
;;                    (ad-arg-binding-field firstarg 'type)))
;;     ;; Set value of second argument to nil unless it was a number:
;;     (if (not (numberp (ad-arg-binding-field secondarg 'value)))
;;         (set (ad-arg-binding-field secondarg 'name) nil))
;;     ....)
;;
;; The `type' of an argument is either `required', `optional' or `rest'.
;; Wherever ad-arg-bindings appears a form will be inserted that evaluates
;; to the list of bindings, hence, in order to avoid multiple unnecessary
;; evaluations one should always bind it to some variable.
;;
;; Summary of symbols with special meanings when used within an advice:
;; ====================================================================
;;   ad-return-value   name of the return value variable (get/settable)
;;   ad-subr-args      name of &rest argument variable used for advised
;;                     subrs (get/settable)
;;   ad-arg-bindings   text macro that returns the actual names, values
;;                     and types of the arguments as a list of bindings. The
;;                     order of the bindings corresponds to the order of the
;;                     arguments. The individual fields of every binding (name,
;;                     value and type) can be accessed with the function
;;                     ad-arg-binding-field (see example above).
;;   ad-do-it          text macro that identifies the place where the original
;;                     or wrapped definition should go in an around advice
;;
;; Activation/deactivation advices, file load hooks:
;; =================================================
;; There are two special classes of advice called `activation' and
;; `deactivation'. The body forms of these advices are not included into the
;; advised definition of a function, they rather are assembled into a hook
;; form which will be evaluated whenever the advice info of the advised
;; function gets activated or deactivated. One application of this mechanism
;; is to define file load hooks for files that do not provide such hooks.
;; For example, suppose you want to print a message whenever file-x gets
;; loaded, and suppose the last function defined in file-x is file-x-last-fn.
;; Then we can define the following advice:
;;
;;   (defadvice file-x-last-fn (activation file-x-load-hook)
;;      "Executed whenever file-x is loaded"
;;      (if load-in-progress (message "Loaded file-x")))
;;
;; This will constitute a forward advice for function file-x-last-fn which
;; will get activated when file-x is loaded. Because there are no "real"
;; pieces of advice available for it, its definition will not be changed,
;; but the activation advice will be run during its activation which is
;; equivalent to having a file load hook for file-x.
;;
;;
;; Foo games: An advice tutorial
;; =============================
;;  ;; We start with a very innocent looking function foo that just
;;  ;; adds 1 to its argument x:
;;
;;  (defun foo (x)
;;    "Add 1 to x."
;;    (1+ x))
;;  foo
;;
;;  (foo 3)
;;  4
;;
;;  ;; Let's define the first piece of advice for function foo.  To do that we
;;  ;; use the macro defadvice which takes a function name, a list of advice
;;  ;; specifiers and a list of body forms as arguments.  The first element of
;;  ;; the advice specifiers is the class of the advice, the second is its
;;  ;; name, the third its position and the rest are some flags. The class of
;;  ;; our first advice is `before', its name is `add2', its position among
;;  ;; the currently defined before advices (none so far) is `first', and the
;;  ;; advice will be `activate'ed immediately.  In the body of an advice we
;;  ;; can refer to the argument variables of the original function by name.
;;  ;; Here we add 1 to x so the effect of calling foo will be to actually add
;;  ;; 2. All of the advice definitions below only have one body form for
;;  ;; simplicity, but there is no restriction to that extent. Every piece of
;;  ;; advice can have a documentation string which will be combined with the
;;  ;; documentation of the original function.
;;
;;  (defadvice foo (before add2 first activate)
;;    "  Add 2 to x"
;;    (setq x (1+ x)))
;;  foo
;;
;;  (foo 3)
;;  5
;;
;;  ;; Now we define the second `before' advice which will cancel the effect
;;  ;; of the previous advice. This time we specify the position as 0 which is
;;  ;; equivalent to `first'. A number can be used to specify the zero-based
;;  ;; position of an advice among the list of advices in the same class. This
;;  ;; time we already have one before advice hence the position specification
;;  ;; actually has an effect. So, after the following definition the position
;;  ;; of the previous advice will be 1 even though we specified it with
;;  ;; `first' above, the reason for this is that the position argument is
;;  ;; relative to the currently defined pieces of advice which by now has
;;  ;; changed.
;;
;;  (defadvice foo (before cancel-add2 0 activate)
;;    "  Again only add 1 to x"
;;    (setq x (1- x)))
;;  foo
;;
;;  (foo 3)
;;  4
;;
;;  ;; Now we define an advice with the same class and same name but with a
;;  ;; different position. Defining an advice in a class in which an advice
;;  ;; with that name already exists is interpreted as a redefinition of that
;;  ;; particular advice, in which case the position argument will be ignored
;;  ;; and the previous position of the redefined piece of advice is used:
;;
;;  (defadvice foo (before cancel-add2 last activate)
;;    "  Again only add 1 to x"
;;    (setq x (1- x)))
;;  foo
;;
;;  ;; The documentation strings of the various pieces of advice are assembled
;;  ;; in order which shows that advice `cancel-add2' is still the first
;;  ;; `before' advice even though we specified position `last' above:
;;
;;  (documentation 'foo)
;;  "Add 1 to x.
;;
;;  Function foo is advised:
;;
;;  cancel-add2 (before):
;;    Again only add 1 to x
;;  add2 (before):
;;    Add 2 to x"
;;
;;  ;; We can make a function interactive (or changing its interactive
;;  ;; behavior) by specifying an interactive form in one of the `before' or
;;  ;; `around' advices (there could be more body forms in this advice). The
;;  ;; particular definition always assigns 5 as an argument to x which gives
;;  ;; us 6 as a result when we call foo interactively:
;;
;;  (defadvice foo (before inter last activate)
;;    "  Use 5 as argument when called interactively"
;;    (interactive (list 5)))
;;  foo
;;
;;  (call-interactively 'foo)
;;  6
;;
;;  ;; If more than one advices have an interactive declaration, then the one
;;  ;; of the advice with the smallest position will be used (`before' advices
;;  ;; go before `around' advices), hence the declaration below does not have
;;  ;; any effect:
;;
;;  (defadvice foo (before inter2 last activate)
;;    (interactive (list 6)))
;;  foo
;;
;;  (call-interactively 'foo)
;;  6
;;
;;  ;; 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)
;;    "\\^origdoc
;;
;;  Function foo is advised:
;;
;;  cancel-add2 (before):
;;    Again only add 1 to x
;;  add2 (before):
;;    Add 2 to x
;;  inter (before):
;;    Use 5 as argument when called interactively"
;;    (interactive (list 5))
;;    (let (ad-return-value)
;;      (setq x (1- x))
;;      (setq x (1+ x))
;;      (setq ad-return-value (1+ x))
;;      ad-return-value))
;;
;;  ;; Now we'll try some `around' advices. An `around' advice is a wrapper
;;  ;; around the original definition. It can shadow or establish bindings for
;;  ;; the original definition, and it can look at and manipulate the value
;;  ;; returned by the original function. The position of the special keyword
;;  ;; `ad-do-it' specifies where the code of the original function will be
;;  ;; executed. The keyword can appear multiple times which will result in
;;  ;; multiple copies 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 `first' (or 0) is the default):
;;
;;  (defadvice foo (around times-2 activate)
;;    "  First double x"
;;    (let ((x (* x 2)))
;;      ad-do-it))
;;  foo
;;
;;  (foo 3)
;;  7
;;
;;  ;; Around advices are assembled like onion skins where the around advice
;;  ;; with position 0 is the outermost skin and the advice at the last
;;  ;; position is the innermost skin which is directly wrapped around the
;;  ;; original definition of the function. Hence after the next defadvice we
;;  ;; will first multiply x by 2 then add 1 and then call the original
;;  ;; definition (i.e., add 1 again):
;;
;;  (defadvice foo (around add-1 last activate)
;;    "  Add 1 to x"
;;    (let ((x (1+ x)))
;;      ad-do-it))
;;  foo
;;
;;  (foo 3)
;;  8
;;
;;  ;; Again, let's see what the definition of foo looks like so far:
;;  (symbol-function 'foo)
;;  (lambda (x)
;;    "\\^origdoc
;;
;;  Function foo is advised:
;;
;;  cancel-add2 (before):
;;    Again only add 1 to x
;;  add2 (before):
;;    Add 2 to x
;;  inter (before):
;;    Use 5 as argument when called interactively
;;  times-2 (around):
;;    First double x
;;  add-1 (around):
;;    Add 1 to 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 (1+ x))))
;;      ad-return-value))
;;
;;  ;; In every defadvice so far we have used the flag `activate' to activate
;;  ;; the advice immediately after its definition, and that's what we want in
;;  ;; most cases. However, if we define multiple pieces of advice for a
;;  ;; single function then activating every advice immediately is
;;  ;; inefficient. A better way to do this is to only activate the last
;;  ;; defined advice.  For example:
;;
;;  (defadvice foo (after times-x)
;;    "  Multiply the result with x"
;;    (setq ad-return-value (* ad-return-value x)))
;;  foo
;;
;;  ;; This still yields the same result as before:
;;  (foo 3)
;;  8
;;
;;  ;; Now we define another advice and activate it which will also activate
;;  ;; the previous advice `times-x'. Note the use of the special variable
;;  ;; ad-return-value in the body of the advice which is set to the result of
;;  ;; the original function. If we change its value then the value returned
;;  ;; by the advised function will be changed accordingly:
;;
;;  (defadvice foo (after times-x-again activate)
;;    "  Again multiply the result with x"
;;    (setq ad-return-value (* ad-return-value x)))
;;  foo
;;
;;  ;; Now the advices have an effect:
;;  (foo 3)
;;  72
;;
;;  ;; Once in a while we define an advice to perform some cleanup action,
;;  ;; for example:
;;
;;  (defadvice foo (after cleanup last activate)
;;    "  Do some cleanup"
;;    (print "Let's clean up now!"))
;;  foo
;;
;;  ;; However, in case of an error the cleanup won't be performed:
;;  (condition-case error
;;      (foo t)
;;    (error 'error-in-foo))
;;  error-in-foo
;;
;;  ;; To make sure a certain piece of advice gets executed even if some error
;;  ;; or non-local exit occurred in any preceding code, we can protect it by
;;  ;; using the `protect' keyword. (if any of the around advices is protected
;;  ;; then the whole around advice onion will be protected):
;;
;;  (defadvice foo (after cleanup protect activate)
;;    "  Do some protected cleanup"
;;    (print "Let's clean up now!"))
;;  foo
;;
;;  ;; Now the cleanup form will be executed even in case of an error:
;;  (condition-case error
;;      (foo t)
;;    (error 'error-in-foo))
;;  "Let's clean up now!"
;;  error-in-foo
;;
;;  ;; Again, let's see what foo looks like:
;;  (symbol-function 'foo)
;;  (lambda (x)
;;    "\\^origdoc
;;
;;  Function foo is advised:
;;
;;  cancel-add2 (before):
;;    Again only add 1 to x
;;  add2 (before):
;;    Add 2 to x
;;  inter (before):
;;    Use 5 as argument when called interactively
;;  times-2 (around):
;;    First double x
;;  add-1 (around):
;;    Add 1 to x
;;  times-x-again (after):
;;    Again multiply the result with x
;;  times-x (after):
;;    Multiply the result with x
;;  cleanup (after):
;;    Do some protected cleanup"
;;    (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 (1+ 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))
;;
;;  ;; Finally, we can specify the `compile' keyword in a defadvice to say
;;  ;; that we want the resulting advised function to be byte-compiled
;;  ;; (`compile' will be ignored unless we also specified `activate'):
;;
;;  (defadvice foo (after cleanup protect activate compile)
;;    "  Do some protected cleanup"
;;    (print "Let's clean up now!"))
;;  foo
;;
;;  ;; Now foo is byte-compiled:
;;  (symbol-function 'foo)
;;  (lambda (x)
;;    "\\^origdoc
;;
;;  Function foo is advised:
;;
;;  cancel-add2 (before):
;;    Again only add 1 to x
;;  add2 (before):
;;    Add 2 to x
;;  inter (before):
;;    Use 5 as argument when called interactively
;;  times-2 (around):
;;    First double x
;;  add-1 (around):
;;    Add 1 to x
;;  times-x-again (after):
;;    Again multiply the result with x
;;  times-x (after):
;;    Multiply the result with x
;;  cleanup (after):
;;    Do some protected cleanup"
;;    (interactive (byte-code "\300C\207" [5] 1))
;;    (byte-code "\302\210\302^X303\216    S\211^Q\210    T\211^Q\210\304    \305\"^Y    T^Y    T\211^P))\210\304^H    \"\211^P\210\304^H    \"\211^P)\210^H)\207" [ad-return-value x nil ((byte-code "\300\301!\207" [print "Let's clean up now!"] 2)) * 2] 5))
;;
;;  (foo 3)
;;  "Let's clean up now!"
;;  72
;;
;;
;;  ;; Forward Advice:
;;  ;; ===============
;;
;;  ;; Define a piece of advice for an undefined function:
;;
;;  (defadvice bar (before sub-1-more activate)
;;    "  Subtract one more from x"
;;    (setq x (1- x)))
;;  bar
;;
;;  ;; bar it is not yet defined:
;;  (fboundp 'bar)
;;  nil
;;
;;  ;; Now we define it and the forward advice will get activated:
;;
;;  (defun bar (x)
;;    "Subtract 1 from x"
;;    (1- x))
;;  bar
;;
;;  (bar 4)
;;  2
;;
;;  ;; Redefinition will also activate any available advice:
;;
;;  (defun bar (x)
;;    "Subtract 2 from x"
;;    (- x 2))
;;  bar
;;
;;  (bar 4)
;;  1
;;


;; Advice Implementation:
;; ======================

(require 'backquote)

;; I need a function to be defined during byte-compilation for
;; proper macro expansion, hence I preload the file if necessary
;; (bummer, no eval-when available in Emacs-Lisp):
(provide 'advice)
(require 'advice)

(defconst ad-version (substring "$Revision: 1.7 $" 11 -2))

(defvar ad-advised-functions nil
  "List of currently advised though not necessarily activated functions")


;; First some utilities:
;; =====================

(defun ad-map-tree (subtree-test function tree)
  "Maps over TREE and returns a tree with identical structure but every
subtree for which SUBTREE-TEST is T replaced by the result of applying
FUNCTION to it. TREE might be an atom or a list."
  (cond ((funcall subtree-test tree)
     (funcall function tree))
    ((listp tree)
     (mapcar (function
          (lambda (subtree)
            (ad-map-tree subtree-test function subtree)))
         tree))
    (t tree)))

(defun ad-substitute (old new tree)
  "Substitutes all occurrences of OLD in TREE with NEW and returns the
modified tree."
  (ad-map-tree (function (lambda (subtree) (equal subtree old)))
           (function (lambda (subtree) new))
           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}*)

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* ((var (car varform))
          (init (car (cdr varform)))
          (result (car (cdr (cdr varform))))
      ;; Use uninterned symbols that won't conflict with anything:
          (listvar (make-symbol "ad-do-var"))
      (tagsym (make-symbol "ad-do-exit"))
      (code (` (let (((, listvar) (, init))
             (, var))
             (while (, listvar)
               (setq (, var) (car (, listvar)))
               (,@ body)
               (setq (, listvar) (cdr (, listvar))))
             (, result))))
      contains-return)
     ;; Look for ad-do-return forms and substitute them with throw's:
     (setq code (ad-map-tree
         (function (lambda (subtree)
                 (and (consp subtree)
                  (eq (car subtree) 'ad-do-return)
                  (setq contains-return t))))
         (function (lambda (subtree)
                 (` (throw '(, tagsym) (, (car (cdr subtree)))))))
         code))
     ;; If we had an ad-do-return we need a catch:
     (cond (contains-return (` (catch '(, tagsym) (, code))))
       (t code))))


;; 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
;; alist of the following format:
;;
;;      ((active . t/nil)
;;       (before adv1 adv2 ...)
;;       (around adv1 adv2 ...)
;;       (after  adv1 adv2 ...)
;;       (activation  adv1 adv2 ...)
;;       (deactivation  adv1 adv2 ...)
;;       (origdef . <definition>))

(defun ad-get-advice-info (function)
  "Retrieves all the advice info for FUNCTION"
  (get function 'ad-advice-info))

(defun ad-set-advice-info (function advice-info)
  "Sets the advice info for FUNCTION"
  (put function 'ad-advice-info advice-info))

(defun 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."
  (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."
  (if (not (member function ad-advised-functions))
      (setq ad-advised-functions (cons function ad-advised-functions)))
  (ad-set-advice-info function (list (cons 'active nil))))

(defun ad-get-advice-info-field (function field)
  "Retrieves the value of the advice info FIELD of FUNCTION."
  (and (ad-is-advised function)
       (cdr (assoc field (ad-get-advice-info function)))))

(defun ad-set-advice-info-field (function field value)
  "Destructively modifies the VALUE of the advice info FIELD of FUNCTION."
  (and (ad-is-advised function)
       (cond ((assoc field (ad-get-advice-info function))
          ;; A field with that name is already present:
              (rplacd (assoc field (ad-get-advice-info function)) value))
         (t;; otherwise, create a new field with that name:
          (nconc (ad-get-advice-info function)
             (list (cons field value)))))))

(defvar ad-advice-classes '(before around after activation deactivation)
  "List of defined advice classes")

(defun ad-has-at-least-one-redefining-advice (function)
  "non-NIL if the advice info of FUNCTION defines at least one advice that
will lead to its redefinition on activation of the advice."
  (and (ad-is-advised function)
       (or (ad-get-advice-info-field function 'before)
       (ad-get-advice-info-field function 'around)
       (ad-get-advice-info-field function 'after))))

(defun ad-has-at-least-one-advice (function)
  "non-NIL 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-is-active (function)
  "non-NIL if FUNCTION is advised and activated"
  (and (ad-is-advised function)
       (ad-get-advice-info-field function 'active)))


;; Access fns for single pieces of advice and related predicates:
;; ==============================================================

(defun ad-make-advice (name protect forms)
  "Constructs a single piece of advice to be stored in some advice field of
the advice info of some function."
  (list name protect forms))

(defun ad-advice-name (advice)
  (nth 0 advice))
(defun ad-advice-protected (advice)
  (nth 1 advice))
(defun ad-advice-forms (advice)
  (nth 2 advice))

(defun ad-class-p (thing)
  (member thing ad-advice-classes))
(defun ad-name-p (thing)
  (symbolp thing))
(defun ad-position-p (thing)
  (or (natnump thing)
      (member thing '(first last))))


;; Adding and removing pieces of advice:
;; =====================================

(defun ad-remove-advice (function class name)
  "If FUNCTION has a piece of advice of CLASS with a non-NIL NAME, then this
advice will be removed from the list of advices in this class. If such an
advice could be found its zero-based position will be returned. NIL otherwise."
  (interactive
   "SRemove advice of function: \nSClass (before, around, after): \nSName: ")
  (if (ad-is-advised function)
      (let ((index 0) new-advices found-at-index)
    (ad-dolist (advice (ad-get-advice-info-field function class))
      (cond ((and name (eq name (ad-advice-name advice)))
         (setq found-at-index index))
        (t (setq new-advices (cons advice new-advices))))
      (setq index (1+ index)))
    (ad-set-advice-info-field function class (reverse new-advices))
    (if (and (interactive-p)
         (not found-at-index))
        (error "ad-remove-advice: No such advice found for %s: %s %s"
           function class name))
    found-at-index)
    (if (interactive-p)
    (error "ad-remove-advice: Function %s is not advised" function))
    nil))

(defun ad-add-advice (function advice class position)
  "Adds a piece of ADVICE of CLASS to the advice info of FUNCTION. If FUNCTION
has already one or more pieces of advice of the specified 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 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 and its original definition will be saved (this is not the case
for forward advice of functions that might get autoloaded later)"
  (cond ((not (ad-is-advised function))
         (ad-initialize-advice-info function)
     (if (ad-has-proper-definition function)
         (ad-set-advice-info-field
          function 'origdef (symbol-function function)))))
  (let* ((previous-position
      ;; Check whether we already had an advice with the same name:
      (ad-remove-advice function class (ad-advice-name advice)))
     (advices (ad-get-advice-info-field function class))
     ;; Determine a numerical position of the new advice:
     (position (cond (previous-position)
             ((eq position 'first) 0)
             ((eq position 'last) (length advices))
             ((numberp position)
              (max 0 (min position (length advices))))
             (t (length advices))))
     (index 0)
     pre-advices)
    (while (< index position)
      (setq pre-advices (append pre-advices (list (car advices))))
      (setq advices (cdr advices))
      (setq index (1+ index)))
    (ad-set-advice-info-field
     function class (append pre-advices (cons advice advices)))))


;; Accessing and manipulating function definitions:
;; ================================================
;; Some of these functions most likely have to be changed in order to work
;; under Emacs 19.

(defun ad-parse-definition (definition part)
  "Takes a function/macro/advice DEFINITION (a list of forms) and returns
the form(s) identified by PART. If PART is `arglist' then the argument list
of the function will be returned, if it is `docstring' then the documentation
string will be returned, if it is `interactive' then the interactive form will
be returned, and if it is `body' then the body forms without any arglists,
docstrings or interactive forms will be returned."
  (let* ((args-index (cond ((eq (car definition) 'macro) 2)
               ((eq (car definition) 'lambda) 1)
               ;; for advice definitions:
               (t -1)))
     (doc-skip (cond ((or (stringp (nth (1+ args-index) definition))
                  (natnump (nth (1+ args-index) definition)))
              1)
             (t 0)))
     (inter-form (nth (+ args-index doc-skip 1) definition))
     (inter-skip (cond ((eq (car-safe inter-form) 'interactive) 1)
               (t 0))))
    (cond ((and (eq part 'arglist)
        (> args-index 0))
       (nth args-index definition))
      ((and (eq part 'docstring)
        (> doc-skip 0))
       (nth (1+ args-index) definition))
      ((and (eq part 'interactive)
        (> inter-skip 0))
       inter-form)
      ((eq part 'body)
       (nthcdr (+ args-index doc-skip inter-skip 1) definition)))))

(defvar ad-special-forms '(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)
  "There is no way to determine whether some subr is a special form or not,
hence we need this list.")

(defun ad-special-form-p (subr-name)
  "non-NIL if SUBR-NAME is the name of a special form."
  (member subr-name ad-special-forms))

(defun ad-interactive-p (definition)
  "non-NIL if DEFINITION can be called interactively"
  (commandp definition))

(defun ad-subr-p (definition)
  "non-NIL if DEFINITION is a subr"
  (subrp definition))

(defun ad-macro-p (definition)
  "non-NIL if DEFINITION is a macro"
  (eq (car-safe definition) 'macro))

(defun ad-lambda-p (definition)
  "non-NIL if DEFINITION is a lambda expression"
  (eq (car-safe definition) 'lambda))

(defun ad-compiled-p (definition)
  "non-NIL if DEFINITION is byte compiled"
  (and (or (ad-lambda-p definition)
       (ad-macro-p definition))
       (eq (car-safe (car-safe (ad-parse-definition definition 'body)))
       'byte-code)))

(defun ad-has-proper-definition (function)
  "Returns T if FUNCTION is a symbol with a proper definition, i.e., it is
fbound and its definition is not an autoload declaration."
  (and (symbolp function)
       (fboundp function)
       (not (eq (car-safe (symbol-function function)) 'autoload))))

(defun ad-real-definition (function)
  "Chases function cell indirection of FUNCTION until if finds an actual
definition which it will return"
  (if (ad-has-proper-definition function)
      (let ((definition (symbol-function function)))
    (if (symbolp definition)
        (ad-real-definition definition)
      definition))))

(defun ad-real-orig-definition (function)
  "Chases function cell indirection of the original definition of FUNCTION
until if finds an actual definition which it will return"
  (if (and (ad-is-advised function)
       (ad-get-advice-info-field function 'origdef))
      (let ((origdef (ad-get-advice-info-field function 'origdef)))
    (if (symbolp origdef)
        (ad-real-definition origdef)
      origdef))))

(defun ad-interactive-form (definition)
  "Returns the interactive form of DEFINITION if it is available"
  (if (consp (commandp definition))
      (commandp definition)))

(defun ad-lambda-expression (definition)
  "Returns the lambda expression of DEFINITION if it is a macro or a lambda"
  (cond ((ad-macro-p definition)
     (cdr definition))
    ((ad-lambda-p definition) definition)))

(defun ad-is-compilable (function)
  "Check whether 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)))))

(defun ad-compile-function (function)
  "Byte-compiles FUNCTION if it is not yet compiled."
  (interactive "aByte-compile function: ")
  (require 'byte-compile "bytecomp")
  (if (ad-is-compilable function)
      (let* ((definition (symbol-function function))
         (is-macro (ad-macro-p definition))
         (lambda (ad-lambda-expression definition))
         (compiled-lambda
          (byte-compile-lambda lambda)))
    (fset function
          (cond (is-macro (cons 'macro compiled-lambda))
            (t compiled-lambda))))))

(defun ad-optimize-definition (definition)
  "Takes a function DEFINITION and replaces all one-element progn forms
in it with the according body form."
  (ad-map-tree
   (function
    (lambda (form)
      (and (eq (car-safe form) 'progn)
       (= (length (cdr form)) 1))))
   (function
    (lambda (progn-form)
      (car (ad-optimize-definition (cdr progn-form)))))
   definition))

(defun ad-retrieve-args-form (arglist)
  "Generates a form from ARGLIST which when evaluated within a function with
that argument list 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* (required optional rest)
    (setq rest (cdr (member '&rest arglist)))
    (if rest (setq arglist (reverse (cdr (member '&rest (reverse arglist))))))
    (setq optional (cdr (member '&optional arglist)))
    (if optional
    (setq required (reverse (cdr (member '&optional (reverse arglist)))))
      (setq required arglist))
    (` (list
    (,@ (mapcar (function
             (lambda (req)
               (` (list '(, req) (, req) 'required))))
            required))
    (,@ (mapcar (function
             (lambda (opt)
               (` (list '(, opt) (, opt) 'optional))))
            optional))
    (,@ (if rest (list (` (list '(, (car rest)) (, (car rest)) 'rest)))))
    ))))

(defun ad-arg-binding-field (binding field)
  (cond ((eq field 'name) (car binding))
    ((eq field 'value) (car (cdr binding)))
    ((eq field 'type) (car (cdr (cdr binding))))))


;; Body access fns for pieces of advice:
;; =====================================

(defun ad-advice-docstring (advice)
  (ad-parse-definition (ad-advice-forms advice) 'docstring))
(defun ad-advice-interactive (advice)
  (ad-parse-definition (ad-advice-forms advice) 'interactive))
(defun ad-advice-body-forms (advice)
  (ad-parse-definition (ad-advice-forms advice) 'body))


;; Constructing advised definitions:
;; =================================

(defun ad-assemble-advised-definition
  (type args docstring interactive orig &optional befores arounds afters)

  "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 that has to be used,
ORIG is a form that evaluates 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
               (progn (,@ before-forms))
             (,@ (ad-advice-body-forms advice)))))))
        (t (setq before-forms
             (append before-forms
                 (ad-advice-body-forms advice))))))

    (setq around-form (` (setq ad-return-value (, orig))))
    (setq arounds (reverse arounds))
    (ad-dolist (advice 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
         'ad-do-it around-form
         (` (progn (,@ (ad-advice-body-forms advice)))))))

    (setq after-forms
      (if (and around-form-protected before-forms)
          (` ((unwind-protect
              (progn (,@ 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
               (progn (,@ after-forms))
             (,@ (ad-advice-body-forms advice)))))))
        (t (setq after-forms
             (append after-forms
                 (ad-advice-body-forms advice))))))

    (setq definition
      (` ((,@ (if (member type '(macro special-form)) '(macro)))
          lambda
          (, args)
          (,@ (if docstring (list docstring)))
          (,@ (if interactive (list interactive)))
          (let (ad-return-value)
        ;; Construct part of this "by hand" because of some
        ;; strange backquote behavior (or bug):
        (,@ (append after-forms
                (if (eq type 'special-form)
                ;; Do this because special forms become macros:
                (list '(list 'quote ad-return-value))
                  (list 'ad-return-value))))
        ))))

    ;; Insert argument bindings access form if we need to:
    (setq definition
      (ad-substitute
       'ad-arg-bindings (ad-retrieve-args-form args) definition))

    ;; Optimize one-element progns away (I guess a special constructor
    ;; function that checked for this special case would have worked too):
    (ad-optimize-definition definition)))

(defvar ad-doc-indirection-pointer "\\^origdoc"
  "String used in a docstring to indicate the position where the docstring of
the original function should get included.")

(defvar ad-doc-indirection-pointer-regexp
  (regexp-quote ad-doc-indirection-pointer)
  "Regexp that matches an indirection pointer in a docstring")

(defun ad-make-single-advice-docstring (advice class)
  (let ((advice-docstring (ad-advice-docstring advice)))
    (if advice-docstring
        (format "%s (%s):\n%s"
        (if (ad-advice-name advice)
            (ad-advice-name advice)
          "unnamed")
        class
        advice-docstring))))

(defun ad-make-advised-docstring (function)
  "Constructs a documentation string for the advised FUNCTION by
concatenating the original documentation with the advice documentation
strings. Every advice documentation string will start on a new line."
  (let* ((origdef (ad-real-orig-definition function))
     (origdoc (documentation origdef))
     (advice-docstring
      ;; Combine advice docstrings with original docstring, for now
      ;; just concatenate them with newlines inbetween:
      (mapconcat
       (function
        (lambda (class)
          (mapconcat (function
              (lambda (advice)
                (let ((doc (ad-make-single-advice-docstring
                    advice class)))
                  (and doc (format "\n%s" doc)))))
             (ad-get-advice-info-field function class)
             "")))
       ad-advice-classes "")))
    (if (and origdoc (ad-is-active 'documentation))
    (setq origdoc ad-doc-indirection-pointer))
    (if (not (equal advice-docstring ""))
    (setq advice-docstring
          (format "%s %s is advised:\n%s"
              (cond ((ad-special-form-p function) "Special form")
                ((ad-subr-p origdef) "Subr")
                ((ad-macro-p origdef) "Macro")
                (t "Function"))
              function
              advice-docstring)))
    (cond ((equal advice-docstring "") origdoc)
      (origdoc (format "%s\n\n%s" origdoc advice-docstring))
      (t advice-docstring))))

(defun ad-advised-interactive-form (function)
  "Maps over before and around advices of FUNCTION and returns the first
interactive form it finds, NIL otherwise."
  (ad-dolist (advice (append (ad-get-advice-info-field function 'before)
                 (ad-get-advice-info-field function 'around)))
     (if (ad-advice-interactive advice)
     ;; We found the first one, use it:
     (ad-do-return (ad-advice-interactive advice)))))

;; There are various decisions to be made about what the advised definition
;; of a function/macro/subr/special form should look like:
;; - Should it have the same argument list as the original (when possible),
;;   or should it use a universal (&rest args) form? I chose the former
;;   because it allows pieces of advice to refer to arguments by name, instead
;;   of having to fiddle them out of a list and changing the whole list
;;   (for subrs we still need the &rest approach though)
;; - What should the call to the original code look like? With a &rest argument
;;   form one could use (apply orig args) for functions and subrs, but not for
;;   macros and special forms. With function indirection one could construct
;;   a form (orig-fn-symbol arg1 ... argn) as long as there are no &rest
;;   variables. I chose to copy the code of the original function/macro into
;;   the advised function, which is a bit of a waste but avoids all the
;;   argument list problems and works for macros as well. Subrs still have
;;   to be applied though. If somebody has a better idea how to do this
;;   let me know.

(defun ad-make-advised-definition (function)
  "Generates an advised definition of FUNCTION from its advice info."
  (if (and (ad-is-advised function)
       (ad-has-at-least-one-redefining-advice function))
      (let* ((origdef (ad-real-orig-definition function))
         (orig-interactive-p (ad-interactive-p origdef))
         (orig-subr-p (ad-subr-p origdef))
         (orig-special-form-p (ad-special-form-p function))
         (orig-macro-p (ad-macro-p origdef))
         ;; Construct the individual pieces that we need for assembly:
         (arglist (cond ((or orig-subr-p orig-special-form-p)
                         ;; The argument lists of subrs/special forms are
                 ;; not accessible, hence we use &rest ad-subr-args
                 '(&rest ad-subr-args))
                ;; otherwise, use same args as the original fn
                (t (ad-parse-definition origdef 'arglist))))
         (advised-interactive-form (ad-advised-interactive-form function))
         (interactive-form
          (cond (orig-macro-p nil)
            (advised-interactive-form)
            ((ad-interactive-form origdef))
            ;; Otherwise, just make it interactive if we have to:
            (orig-interactive-p '(interactive))))
         (orig-form
          (cond (orig-special-form-p
             ;; Special forms are tricky because they are not apply-
             ;; able, hence we temporarily bind ad-original-subr to
             ;; their original definition and construct an EVAL form
             ;; that provides the proper arguments. This is save even
             ;; if the evaluation of the arguments causes another
             ;; advised special form to rebind ad-original-subr,
             ;; because EVAL saves the definition of the symbol in
             ;; functional position right away and later applies it
             ;; to the evaluated arguments (actually, special forms
             ;; should not lead to immediate argument evaluation
             ;; anyway):
             (` (progn (fset 'ad-original-subr '(, origdef))
                   (eval (cons 'ad-original-subr ad-subr-args)))))
            (orig-subr-p
             (cond ((or (not orig-interactive-p)
                advised-interactive-form)
                ;; If the advised subr is not interactive, or if
                ;; somebody advised interactive handling then we
                ;; can simply apply the subr without interaction...
                (` (apply (, origdef) ad-subr-args)))
               (t;; ...otherwise we have to check whether we
                ;; were called interactively in order to do
                ;; proper prompting:
                (` (if (interactive-p)
                   (call-interactively (, origdef))
                 (apply (, origdef) ad-subr-args))))))
            ;; And now for normal functions (winner, this will work
            ;; for macros as well):
            (t (` (progn (,@ (ad-parse-definition origdef 'body))))))))

    ;; Finally, build the sucker:
    (ad-assemble-advised-definition
     (cond (orig-macro-p 'macro)
           (orig-special-form-p 'special-form)
           (t 'lambda))
     arglist
     (ad-make-advised-docstring function)
     interactive-form
     orig-form
     (ad-get-advice-info-field function 'before)
     (ad-get-advice-info-field function 'around)
     (ad-get-advice-info-field function 'after)))))

(defun ad-make-hook-form (function hook-name)
  "Uses the body forms of all advices of FUNCTION that are of class HOOK-NAME
to generate a single form that can be evaluated in a hook-style fashion."
  (let ((hook-forms
     (mapcar 'ad-advice-body-forms
         (ad-get-advice-info-field function hook-name))))
    (if hook-forms
    (cons 'progn (apply 'append hook-forms)))))


;; The top-level advice interface:
;; ===============================

(defun ad-activate (function &optional compile)
  "If FUNCTION is an advised function with 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 the advised definition. With an
argument (compile is non-NIL) the resulting function 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."
  (interactive "aActivate advice of: \nP")
  (if (not (ad-is-advised function))
      (error "ad-activate: No advice information available for %s" function)
    (if (not (ad-get-advice-info-field function 'origdef))
    (error "ad-activate: Function %s has not yet been defined" function)
      (if (not (ad-has-at-least-one-advice function))
      (ad-unadvise function)
    ;; Otherwise activate the advice:
    (cond ((ad-has-at-least-one-redefining-advice function)
           (fset function (ad-make-advised-definition function))
           (if compile (ad-compile-function function))))
    (ad-set-advice-info-field function 'active t)
    (eval (ad-make-hook-form function 'activation))
    function))))

(defun ad-deactivate (function)
  "If FUNCTION is an advised function with a proper original definition,
then the current definition of FUNCTION will be replaced with its original
definition. All the advice information will still be available. It can be
activated again with a call to ad-activate."
  (interactive "aDeactivate advice of: ")
  (if (not (ad-is-advised function))
      (error "ad-deactivate: %s does not have any advice information" function)
    (if (null (ad-get-advice-info-field function 'origdef))
    (error "ad-deactivate: No original definition available for %s"
           function)
      (fset function (ad-get-advice-info-field function 'origdef))
      (ad-set-advice-info-field function 'active nil)
      (eval (ad-make-hook-form function 'deactivation))
      function)))

(defun ad-unadvise (function)
  "Deactivates the advice of FUNCTION if its advice is currently active, and
then removes all its advice information. If FUNCTION was not advised this
will be a noop."
  (interactive "aDeactivate advice and remove all advice info of: ")
  (cond ((ad-is-advised function)
     (if (ad-is-active function)
         (ad-deactivate function))
     (ad-set-advice-info function nil)
     (setq ad-advised-functions (delq function ad-advised-functions)))))

(defun ad-recover (function)
  "Recovers the original definition of FUNCTION if available, and then
removes all its advice information without doing any deactivation.
Use in emergencies."
  (interactive "aRecover and remove all advice info of: ")
  (cond ((ad-is-advised function)
     (if (ad-get-advice-info-field function 'origdef)
         (fset function (ad-get-advice-info-field function 'origdef)))
     (ad-set-advice-info function nil)
     (setq ad-advised-functions (delq function ad-advised-functions)))))

(defun ad-activate-all ()
  "Activates all currently advised functions"
  (interactive)
  (ad-dolist (function ad-advised-functions)
     (ad-activate function)))

(defun ad-deactivate-all ()
  "Deactivates all currently advised functions"
  (interactive)
  (ad-dolist (function ad-advised-functions)
     (ad-deactivate function)))

(defun ad-unadvise-all ()
  "Unadvises all currently advised functions"
  (interactive)
  (ad-dolist (function (copy-alist ad-advised-functions))
     (ad-unadvise function)))

(defun ad-recover-all ()
  "Recovers all currently advised functions. Use in emergencies"
  (interactive)
  (ad-dolist (function (copy-alist ad-advised-functions))
     (ad-recover function)))

(defvar ad-defadvice-flags '(protect activate compile)
  "Set of legal defadvice flags")

(defmacro defadvice (function args &rest body)
  "Defines a piece of advice for FUNCTION (a symbol). ARGS is a list of
symbols which specify the class, name and position of the advice and
some flags.  The first element of ARGS specifies the class and must be
one of `before', `around', `after', `activation' or `deactivation'.
The second element must be a symbol that specifies the name of the
advice.  Unnamed advices are specified with NIL as their name. If the
third element is either `first', `last' or an integer it will be used
as the position for the advice.  Otherwise the position defaults to
`first'.  The rest of ARGS is a set of flags. If `protect' is member
of these flags then 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).  If `activate' is member of the flags
then all advice of FUNCTION will be activated immediately (only if
FUNCTION has been properly defined prior to the defadvice).  If
`compile' is a member of the flags together with `activate' then the
resulting advised function will be compiled.
   Finally, BODY is the list of forms that define the advice. The
format is similar to that used within defun. The BODY may have a
documentation string which will be combined with the documentation
strings of other pieces of advice as well as with the documentation of
the original definition. BODY may also have an (interactive ...)
declaration which will be used instead of the one of the original
function if this is the first advice that has such a declaration. For
example, if a function has two pieces of before advice both of which
have an interactive declaration, then the declaration of the before
advice at position 0 will be used. Interactive declarations in after
advices will be ignored. An advice that only contains an interactive
declaration can be used to change the interactive behavior of a
function without executing any additional advice code. Interactive
declarations in advices can also be used to make previously
non-interactive functions interactive."
  (if (not (and function (symbolp function)))
      (error "defadvice: Can only advise named functions: %s" function))
  (let* ((class (nth 0 args))
     (name (nth 1 args))
     (position (if (ad-position-p (nth 2 args))
               (nth 2 args)))
     (flags (cond (position (nthcdr 3 args))
             (t (nthcdr 2 args)))))
    (if (not (ad-class-p class))
    (error "defadvice: Illegal advice class: %s" class))
    (if (not (ad-name-p name))
    (error "defadvice: Illegal advice name: %s" name))
    (ad-dolist (flag flags)
       (if (not (member flag ad-defadvice-flags))
       (error "defadvice: Illegal flag: %s" flag)))
    (if (null position) (setq position 'first))
    (ad-add-advice
     function (ad-make-advice name (member 'protect flags) body)
     class position)
    (if (and (member 'activate flags)
         (ad-has-proper-definition function))
    (ad-activate function (member 'compile flags)))
    (list 'quote function)))


;; Advising DEFUN, DEFMACRO and DOCUMENTATION
;; ==========================================
;; Use the advise mechanism to advise defun/defmacro so we can forward advise
;; functions that might be defined later during load/autoload:

(defun ad-activate-redefined-function (function)
  "Assumes the current definition of FUNCTION to be its original definition,
and if FUNCTION has any advice info saves that as its new origdef and activates
all of its advice. If the original definition was byte-compiled the new advised
function will get compiled too."
  (cond ((ad-is-advised function)
     ;; save the original definition
     (ad-set-advice-info-field
      function 'origdef (symbol-function function))
     ;; activate the advice and compile it if the original was compiled:
     (ad-activate
      function
      (ad-compiled-p (symbol-function function))))))

(defadvice defun (after check-advice first activate compile)
  "Whenever an advised function gets redefined with defun all its
advices will be activated immediately after redefinition. If the
original function was compiled, e.g., when a byte-compiled file was
loaded, then the advised function will be compiled too."
  (ad-activate-redefined-function (car ad-subr-args)))

(defadvice defmacro (after check-advice first activate compile)
  "Whenever an advised macro gets redefined with defmacro all its
advices will be activated immediately after redefinition. If the
original macro was compiled, e.g., when a byte-compiled file was
loaded, then the advised macro will be compiled too.\n"
  (ad-activate-redefined-function (car ad-subr-args)))

(defadvice documentation (after expand-indirection activate compile)
  "Expands documentation indirection pointers to insert original docstrings
in order to properly substitute key bindings at the time this function
is called.\n"
  (if (and (symbolp (car ad-subr-args))
       (stringp ad-return-value)
       (ad-is-active (car ad-subr-args))
       (string-match ad-doc-indirection-pointer-regexp ad-return-value))
      (setq ad-return-value
        (format "%s%s%s"
            (substring ad-return-value 0 (match-beginning 0))
            ;; Make sure that in the very odd case that the original
            ;; docstring of the advised functions contains the
            ;; indirection pointer we don't go into infinite recursion
            ;; by binding the regexp to something that won't ever match
                    (let ((ad-doc-indirection-pointer-regexp " \\`"))
              (documentation
               (ad-get-advice-info-field (car ad-subr-args) 'origdef)))
            (substring ad-return-value (match-end 0))))))

;; eof