comparison lisp/emacs-lisp/advice.el @ 8445:81f7b5d9b990

New handling of automatic advice activation that exploits modified built-in versions of `fset' and `defalias' which take care of this functionality directly: (ad-start-advice-on-load, ad-activate-on-definition) (ad-definition-hooks, ad-enable-definition-hooks, ad-defined-function) (ad-advised-definers, ad-advised-byte-compilers, byte-constant) (byte-constant-limit, byte-constant2, byte-fset) (ad-byte-code-fset-regexp): Variables deleted. (ad-activate-defined-function, ad-find-fset-in-byte-code) (ad-scan-byte-code-for-fsets, ad-advised-byte-code) (ad-recover-byte-code, ad-enable-definition-hooks) (ad-disable-definition-hooks): Functions deleted. (defun, defmacro, fset, defalias, define-function) (byte-compile-from-buffer, byte-compile-top-level): Removed `defadvice' for these functions. (ad-save-real-definitions): Removed saving of `byte-code'. (ad-activate-off): New dummy function. (ad-activate-on): New name for `ad-activate'. All calls changed. (ad-with-auto-activation-disabled): New macro prevents automatic advice activation. (ad-safe-fset): New function, used instead of `ad-real-fset'. (ad-compile-function): Disable automatic advice activation while compiling, because `byte-compile' uses `fset'. (ad-activate-on): Renamed from `ad-activate'. Avoid recursive calls. (ad-activate-on-top-level): New variable. (ad-start-advice, ad-stop-advice, ad-recover-normality): Modified to achieve de/activation of automatic advice activation by setting the definition of `ad-activate' to `ad-activate-on' or `ad-activate-off'. (ad-start-advice): Is now called unconditionally when Advice is loaded. Made compilation behavior of advised definitions customizable, since loading the byte-compiler takes some time and is not always worth the cost, e.g., if one only wants to make a few simple modifications: (ad-default-compilation-action): New variable which specifies whether to compile an advised definition in case the COMPILE argument to `ad-activate-on' or one of its friends was supplied as nil. (ad-preactivate-advice): Supply negative COMPILE argument to prevent compilation. (ad-should-compile): New function. (ad-activate-advised-definition): Use `ad-should-compile' to determine whether an advised definition should get compiled. (ad-activate-on, ad-update, ad-activate-regexp, ad-update-regexp) (ad-activate-all): Doc fixes. (ad-update): Leave handling of COMPILE up to `ad-activate-on'. Extracted construction of freeze-advices from `defadvice': (ad-make-freeze-definition): New function. (defadvice): Use `ad-make-freeze-definition' to construct frozen defs.

8444:841f2c8ae5bb

;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.

;; Author: Hans Chalupsky <[e-mail]>
;; Created: 12 Dec 1992
;; Version: advice.el,v 2.11 1994/02/24 22:51:43 hans Exp
;; Keywords: extensions, lisp, tools

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;; LCD Archive Entry:
;; advice|Hans Chalupsky|[e-mail]|
;; Overloading mechanism for Emacs Lisp functions|
;; 1994/02/24 22:51:43|2.11|~/packages/advice.el.Z|


;;; Commentary:

;; NOTE: This documentation is slightly out of date. In particular, all the

;; - Allows the specification of a different argument list for the advised
;;   version of a function.
;; - 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
;;   as yet undefined or autoload functions 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.
;; - 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 
;;   regular expressions that match advice names
;; - Allows definition of load-hooks for arbitrary Emacs Lisp files without
;;   modification of these files

;; @ 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 

;; The latter three are actual headings which you can search for
;; directly in case `outline-mode' doesn't work for you.

;; @ Restrictions:
;; ===============
;; - This version of Advice only works for Emacs-19 or Lucid Emacs.
;; - 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 
;;     byte-compilation (e.g., car)
;;   + advised macros which were expanded during byte-compilation before
;;     their advice was activated.

;; @ Known bug:
;; ============
;; - Using automatic activation of (forward) advice will break the
;;   function `interactive-p' when it is used in the body of a `catch'
;;   (this problem will go away once automatic advice activation gets
;;   supported by built-in functions).

;; @ Credits:
;; ==========
;; This package is an extension and generalization of packages such as
;; insert-hooks.el written by Noah S. Friedman, and advise.el written by
;; Raul J. Acevedo. Some ideas used in here come from these packages,

;; @ Safety Rules and Emergency Exits:
;; ===================================
;; Before we begin: CAUTION!!
;; 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 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'.
;; 
;; If you experience any strange behavior/errors etc. that you attribute to
;; Advice or to some ill-advised function do one of the following:

;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what

;; I use it extensively and haven't run into any serious trouble in a long
;; time. Just wanted you to be warned.

;; @ 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.

;; 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.

;; @ Motivation:
;; =============
;; Before I go on explaining how advice works, here are four simple examples
;; how this package can be used. The first three are very useful, the last one

;; redefined with the advised definition.  This also means that undefined
;; functions cannot get activated even though they might be already advised.

;; 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
;; 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.

;; `ad-deactivate' can be used to back-define an advised function to its

;; A certain piece of advice is considered a match if its name contains a
;; 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:
;; =============================================
;; 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
;; to preload every file that defines a certain function before it can be
;; advised, which would partly defeat the purpose of the advice mechanism.

;; information for a possibly undefined function.

;; 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.

;; @@@ 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
;; 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 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 wouldn't have to use all
;;   these dirty hacks to achieve this functionality.

;; @@ Caching of advised definitions:
;; ==================================
;; After an advised definition got constructed it gets cached as part of the
;; advised function's advice-info so it can be reused, for example, after an

(provide 'advice-preload)
;; During a normal load this is a noop:
(require 'advice-preload "advice.el")


;; @@ Variable definitions:
;; ========================

(defconst ad-version "2.11")

(defmacro ad-lemacs-p ()
  ;;Expands into Non-nil constant if we run Lucid's version of Emacs-19.
  ;;Unselected conditional code will be optimized away during compilation.
  (string-match "Lucid" emacs-version))

;;;###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.
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.")


;; @@ Some utilities:
;; ==================

(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-definition byte-code)
  (put 'ad-real-byte-code 'byte-compile nil))

(ad-save-real-definitions)


;; @@ Advice info access fns:

      (if (ad-advice-enabled advice)
	  (setq enabled-advices (cons advice enabled-advices))))
    (reverse enabled-advices)))


;; @@ 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

  (` (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))))

(defmacro ad-clear-orig-definition (function)
  (` (fmakunbound (ad-get-advice-info-field (, function) 'origname))))

;; 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))

(defmacro ad-compiled-p (definition)
  ;;"non-nil if DEFINITION is a compiled byte-code object."
  (` (or (byte-code-function-p (, definition))
	 (and (ad-macro-p (, definition))

(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)
      (byte-compile function)))


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

    (unwind-protect
	(progn
	  (ad-add-advice function advice class position)
	  (ad-enable-advice function class (ad-advice-name advice))
	  (ad-clear-cache function)
	  (ad-activate function nil)
	  (if (and (ad-is-active function)
	           (ad-get-cache-definition function))
	      (list (ad-get-cache-definition function)
		    (ad-get-cache-id function))))
      (ad-set-advice-info function old-advice-info)
      ;; Don't `fset' function to nil if it was previously unbound:
      (if function-defined-p
	  (ad-real-fset function old-definition)
	(fmakunbound function)))))

(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."
  (let ((verified-cached-definition
	 (if (ad-verify-cache-id function)
	     (ad-get-cache-definition function))))
    (ad-real-fset function
		  (or verified-cached-definition
		      (ad-make-advised-definition function)))
    (if 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:
	    (ad-set-cache
	     function (symbol-function function) (ad-get-cache-id 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")
		  (if (eq ad-redefinition-action 'discard)
		      (ad-real-fset function original-definition)
		    (ad-set-orig-definition function current-definition)
		    (if (eq ad-redefinition-action 'warn)
			(message "ad-handle-definition: `%s' got redefined"
				 function))))
	      ;; either advised def or correct original is in place:

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

(defun ad-activate (function &optional compile)
  "Activates 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 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)))))))

(defun ad-deactivate (function)
  "Deactivates 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

    (cond ((ad-is-active function)
	   (ad-handle-definition function)
	   (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-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."
  (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))))))

(defun ad-unadvise (function)
  "Deactivates FUNCTION and then removes all its advice information. 
If FUNCTION was not advised this will be a noop."
  (interactive

  (interactive
   (list (intern
	  (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-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."
  (interactive
   (list (ad-read-regexp "Activate via advice regexp: ")
	 current-prefix-arg))
  (ad-do-advised-functions (function)
    (if (ad-find-some-advice function 'any regexp)
	(ad-activate function compile))))

(defun ad-deactivate-regexp (regexp)
  "Deactivates functions with an advice name containing REGEXP match."
  (interactive
   (list (ad-read-regexp "Deactivate via advice regexp: ")))

    (if (ad-find-some-advice function 'any regexp)
	(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."
  (interactive
   (list (ad-read-regexp "Update via advice regexp: ")
	 current-prefix-arg))
  (ad-do-advised-functions (function)
    (if (ad-find-some-advice function 'any regexp)
	(ad-update function compile))))

(defun ad-activate-all (&optional compile)
  "Activates all currently advised functions.
With prefix argument compiles resulting advised definitions."
  (interactive "P")
  (ad-do-advised-functions (function)
    (ad-activate function)))

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

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 the current advice state.  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.

		  name (memq 'protect flags)
		  (not (memq 'disable flags))
		  (` (advice lambda (, arglist) (,@ body)))))
	 (preactivation (if (memq 'preactivate flags)
			    (ad-preactivate-advice
			     function advice class position)))
	 unique-origname
	 (redefinition
	  (if (memq 'freeze flags)
	      (ad-with-originals (ad-make-advised-definition-docstring
				  ad-make-origname)
		;; Make sure we construct the actual docstring:
		(fset 'ad-make-advised-definition-docstring
		      'ad-make-freeze-docstring)
		;; With a unique origname we can have multiple freeze advices
		;; for the same function, each overloading the previous one:
		(setq unique-origname
		      (intern (format "%s-%s-%s"
				      (ad-make-origname function) class name)))
		(fset 'ad-make-origname '(lambda (x) unique-origname))
		(if (not (ad-has-proper-definition function))
		    (error
		     "defadvice: `freeze' needs proper definition of `%s'"
		     function))
		(ad-preactivate-advice function advice class position)))))
    ;; Now for the things to be done at evaluation time:
    (if redefinition
	;; jwz's idea: Freeze the advised definition into a dumpable
	;; defun/defmacro whose docs can be written to the DOC file:
	(let* ((macro-p (ad-macro-p (car redefinition)))
	       (body (cdr (if macro-p
			      (ad-lambdafy (car redefinition))
			    (car redefinition)))))
	  (` (progn
	       (if (not (fboundp '(, unique-origname)))
		   (fset '(, unique-origname) (symbol-function '(, function))))
	       ((, (if macro-p 'defmacro 'defun))
		(, function)
		(,@ body)))))
      ;; the normal case:	 
      (` (progn
	   (ad-add-advice '(, function) '(, advice) '(, class) '(, position))
	   (,@ (if preactivation
		   (` ((ad-set-cache

					   (car preactivation)))))))
				 (t (` (function
					(, (car preactivation)))))))
			'(, (car (cdr preactivation))))))))
	   (,@ (if (memq 'activate flags)
		   (` ((ad-activate '(, function)
				    (, (if (memq 'compile flags) t)))))))
	   '(, function))))))


;; @@ Tools:
;; =========

		     (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))

		 (setq index -1)
		 (mapcar
		  (function
		   (lambda (function)
		     (setq index (1+ index))
		     (` (ad-real-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)))))

(defvar ad-advised-definers
  '(defun defmacro fset defalias define-function))

(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)))

;; In 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."
  (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 Emacs (seems to be an identical copy of `defalias', but
;; it is used in `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))))

(defadvice documentation (after ad-advised-docstring first disable preact)
  "Builds an advised docstring if FUNCTION is advised."
  ;; Because we get the function name from the advised docstring
  ;; this will work for function names as well as for definitions:

	       ;; Handle optional `raw' argument: 
	       (if (not (ad-get-arg 1))
		   (setq ad-return-value
			 (substitute-command-keys ad-return-value))))))))

;; The following two advised functions are a (hopefully temporary) kludge
;; to fix a problem with the compilation of embedded (or non-top-level)
;; `defun/defmacro's when automatic activation of advice is enabled.  For
;; the time of the compilation they backdefine `defun/defmacro' to their
;; original definition to make sure they are not treated as plain macros.
;; Both advices are forward advices, hence, they will only be activated if
;; automatic advice activation is enabled, but since that is the actual
;; situation where we have a problem, we can be sure that the advices will 
;; be active when we need them.

;; We only need this in Lemacs, because in Emacs it is
;; now taken care of directly by the byte-compiler:
(cond ((ad-lemacs-p)

(defvar ad-advised-byte-compilers
  '(byte-compile-from-buffer byte-compile-top-level))

(defadvice byte-compile-from-buffer (around ad-deactivate-defun-defmacro
					    first disable preact)
  "Deactivates `defun/defmacro' for proper compilation when they are embedded."
  (let (;; make sure no `require' starts them again by accident:
	(ad-advised-definers '(fset defalias define-function)))
    (ad-with-originals (defun defmacro)
      ad-do-it)))

(defadvice byte-compile-top-level (around ad-deactivate-defun-defmacro
					  first disable preact)
  "Deactivates `defun/defmacro' for proper compilation when they are embedded."
  (let (;; make sure no `require' starts them again by accident:
	(ad-advised-definers '(fset defalias define-function)))
    (ad-with-originals (defun defmacro)
      ad-do-it)))

)) ;; end of cond

;; Make sure advice-infos are not allocated in pure space 
;; (this might not be necessary anymore):
(ad-dolist (advised-function (cons 'documentation
				   (append ad-advised-definers
					   (if (ad-lemacs-p)
					       ad-advised-byte-compilers))))
  (ad-set-advice-info advised-function (ad-copy-advice-info advised-function)))


;; @@ 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 nil
      (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 (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.
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))))

(defun ad-recover-byte-code ()
  "Recovers the real `byte-code' functionality."
  (interactive)
  (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code)))

(defun ad-enable-definition-hooks ()
  ;;"Enables definition hooks by redefining definition primitives.
  ;;Activates the advice of defun/defmacro/fset and redefines `byte-code'.
  ;;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 ad-advised-definers)
    (ad-enable-advice definer 'after 'ad-definition-hooks)
    (ad-activate definer 'compile))
  (if (ad-lemacs-p)
      (ad-dolist (byte-compiler ad-advised-byte-compilers)
	(ad-enable-advice byte-compiler 'around 'ad-deactivate-defun-defmacro)
	(ad-activate byte-compiler 'compile)))
  ;; Now redefine byte-code...
  (ad-real-fset 'byte-code (symbol-function 'ad-advised-byte-code)))

(defun ad-disable-definition-hooks ()
  ;;"Disables definition hooks by resetting definition primitives."
  (ad-recover-byte-code)
  (ad-dolist (definer ad-advised-definers)
    (ad-disable-advice definer 'after 'ad-definition-hooks)
    (ad-update definer))
  (if (ad-lemacs-p)
      (ad-dolist (byte-compiler ad-advised-byte-compilers)
	(ad-disable-advice byte-compiler 'around 'ad-deactivate-defun-defmacro)
	(ad-update byte-compiler 'compile))))


;; @@ 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."
  (interactive)
  (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))))

(defun ad-stop-advice ()
  "Undefines some primitives to stop the advice magic.
This can also be used to recover from advice related emergencies."
  (interactive)
  (ad-recover-byte-code)
  (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)))

(defun ad-recover-normality ()
  "Undoes all advice related redefinitions and unadvises everything. 
Use only in REAL emergencies."
  (interactive)
  (ad-recover-byte-code)
  (ad-recover-all)
  (setq ad-advised-functions nil))

(if (and ad-start-advice-on-load
         ;; ...but only if we are compiled:
	 (ad-compiled-p (symbol-function 'ad-start-advice)))
    (ad-start-advice))

(provide 'advice)

;;; advice.el ends here

8445:81f7b5d9b990

;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.

;; Author: Hans Chalupsky <[e-mail]>
;; Created: 12 Dec 1992
;; Version: advice.el,v 2.13 1994/08/03 23:27:05 hans Exp
;; Keywords: extensions, lisp, tools

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;; LCD Archive Entry:
;; advice|Hans Chalupsky|[e-mail]|
;; Overloading mechanism for Emacs Lisp functions|
;; 1994/08/03 23:27:05|2.13|~/packages/advice.el.Z|


;;; Commentary:

;; NOTE: This documentation is slightly out of date. In particular, all the

;; - Allows the specification of a different argument list for the advised
;;   version of a function.
;; - Advised functions can be byte-compiled either at file-compile time
;;   (see preactivation) or activation time.
;; - Separation of advice definition and activation
;; - 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. 
;; - 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 
;;   regular expressions that match advice names

;; @ 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 

;; The latter three are actual headings which you can search for
;; 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 
;;     byte-compilation (e.g., car)
;;   + advised macros which were expanded during byte-compilation before
;;     their advice was activated.

;; @ Credits:
;; ==========
;; This package is an extension and generalization of packages such as
;; insert-hooks.el written by Noah S. Friedman, and advise.el written by
;; Raul J. Acevedo. Some ideas used in here come from these packages,

;; @ Safety Rules and Emergency Exits:
;; ===================================
;; Before we begin: CAUTION!!
;; 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'
;; (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 or to some ill-advised function do one of the following:

;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what

;; I use it extensively and haven't run into any serious trouble in a long
;; time. Just wanted you to be warned.

;; @ Customization:
;; ================

;; 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
;; how this package can be used. The first three are very useful, the last one

;; redefined with the advised definition.  This also means that undefined
;; functions cannot get activated even though they might be already advised.

;; 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 `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.

;; `ad-deactivate' can be used to back-define an advised function to its

;; A certain piece of advice is considered a match if its name contains a
;; match for the regular expression. To enable ange-ftp again we would use
;; `ad-enable-regexp' and then activate or update again.

;; @@ 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
;; to preload every file that defines a certain function before it can be
;; advised, which would partly defeat the purpose of the advice mechanism.

;; information for a possibly undefined function.

;; Advice implements forward advice mainly via the following: 1) Separation
;; of advice definition and activation that makes it possible to accumulate
;; advice information without having the original function already defined,
;; 2) special versions of the built-in functions `fset/defalias' which check
;; for advice information whenever they define a function. If advice
;; information was found then the advice will immediately get activated when
;; the function gets defined.

;; 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.

;; @@@ 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:
;; ==================================
;; After an advised definition got constructed it gets cached as part of the
;; advised function's advice-info so it can be reused, for example, after an

(provide 'advice-preload)
;; During a normal load this is a noop:
(require 'advice-preload "advice.el")


(defmacro ad-lemacs-p ()
  ;;Expands into Non-nil constant if we run Lucid's version of Emacs-19.
  ;;Unselected conditional code will be optimized away during compilation.
  (string-match "Lucid" emacs-version))


;; @@ Variable definitions:
;; ========================

(defconst ad-version "2.13")

;;;###autoload
(defvar 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-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.")


;; @@ Some utilities:
;; ==================

(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:

      (if (ad-advice-enabled advice)
	  (setq enabled-advices (cons 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(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' 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' 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-on' by using `ad-with-auto-activation-disabled' where
;; appropriate, especially in a safe version of `fset'.

;; For now define `ad-activate' to the dummy definition:
(defun ad-activate (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-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-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' 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

  (` (let ((origname (ad-get-advice-info-field (, function) 'origname)))
       (if (fboundp origname)
	   (symbol-function origname)))))

(defmacro ad-set-orig-definition (function 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))))

;; 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-safe-fset 'byte-code-function-p 'compiled-function-p))

(defmacro ad-compiled-p (definition)
  ;;"non-nil if DEFINITION is a compiled byte-code object."
  (` (or (byte-code-function-p (, definition))
	 (and (ad-macro-p (, definition))

(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)
      ;; Need to turn off auto-activation
      ;; because `byte-compile' uses `fset':
      (ad-with-auto-activation-disabled
       (byte-compile function))))


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

    (unwind-protect
	(progn
	  (ad-add-advice function advice class position)
	  (ad-enable-advice function class (ad-advice-name advice))
	  (ad-clear-cache function)
	  (ad-activate-on function -1)
	  (if (and (ad-is-active function)
	           (ad-get-cache-definition function))
	      (list (ad-get-cache-definition function)
		    (ad-get-cache-id function))))
      (ad-set-advice-info function old-advice-info)
      ;; Don't `fset' function to nil if it was previously unbound:
      (if function-defined-p
	  (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)
  ;;"Returns 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.
  ;;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-safe-fset function
		  (or verified-cached-definition
		      (ad-make-advised-definition 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:
	    (ad-set-cache
	     function (symbol-function function) (ad-get-cache-id 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")
		  (if (eq ad-redefinition-action 'discard)
		      (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"
				 function))))
	      ;; either advised def or correct original is in place:

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

(defun ad-activate-on (function &optional compile)
  "Activates 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.
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 ad-activate-on-top-level
      ;; avoid recursive calls to `ad-activate-on':
      (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)))))))))

(defun ad-deactivate (function)
  "Deactivates 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

    (cond ((ad-is-active function)
	   (ad-handle-definition function)
	   (if (not (ad-get-orig-definition function))
	       (error "ad-deactivate: `%s' has no original 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.
See `ad-activate-on' 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-on function compile)))

(defun ad-unadvise (function)
  "Deactivates FUNCTION and then removes all its advice information. 
If FUNCTION was not advised this will be a noop."
  (interactive

  (interactive
   (list (intern
	  (completing-read "Recover advised function: " obarray nil t))))
  (cond ((ad-is-advised function)
	 (cond ((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.
See `ad-activate-on' for documentation on the optional COMPILE argument."
  (interactive
   (list (ad-read-regexp "Activate via advice regexp: ")
	 current-prefix-arg))
  (ad-do-advised-functions (function)
    (if (ad-find-some-advice function 'any regexp)
	(ad-activate-on function compile))))

(defun ad-deactivate-regexp (regexp)
  "Deactivates functions with an advice name containing REGEXP match."
  (interactive
   (list (ad-read-regexp "Deactivate via advice regexp: ")))

    (if (ad-find-some-advice function 'any regexp)
	(ad-deactivate function))))

(defun ad-update-regexp (regexp &optional compile)
  "Updates functions with an advice name containing a REGEXP match.
See `ad-activate-on' for documentation on the optional COMPILE argument."
  (interactive
   (list (ad-read-regexp "Update via advice regexp: ")
	 current-prefix-arg))
  (ad-do-advised-functions (function)
    (if (ad-find-some-advice function 'any regexp)
	(ad-update function compile))))

(defun ad-activate-all (&optional compile)
  "Activates all currently advised functions.
See `ad-activate-on' for documentation on the optional COMPILE argument."
  (interactive "P")
  (ad-do-advised-functions (function)
    (ad-activate-on function compile)))

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

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.

		  name (memq 'protect flags)
		  (not (memq 'disable flags))
		  (` (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:
    (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

					   (car preactivation)))))))
				 (t (` (function
					(, (car preactivation)))))))
			'(, (car (cdr preactivation))))))))
	   (,@ (if (memq 'activate flags)
		   (` ((ad-activate-on '(, function)
				       (, (if (memq 'compile flags) t)))))))
	   '(, function))))))


;; @@ Tools:
;; =========

		     (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))

		 (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 `documentation':
;; ============================
;; Use the advice mechanism to advise `documentation' to make it
;; generate proper documentation strings for advised definitions:

(defadvice documentation (after ad-advised-docstring first disable preact)
  "Builds an advised docstring if FUNCTION is advised."
  ;; Because we get the function name from the advised docstring
  ;; this will work for function names as well as for definitions:

	       ;; Handle optional `raw' argument: 
	       (if (not (ad-get-arg 1))
		   (setq ad-return-value
			 (substitute-command-keys ad-return-value))))))))


;; @@ Starting, stopping and recovering from the advice package magic:
;; ===================================================================

(defun ad-start-advice ()
  "Starts the automatic advice handling magic."
  (interactive)
  ;; Advising `ad-activate' means death!!
  (ad-set-advice-info 'ad-activate nil)
  (ad-safe-fset 'ad-activate 'ad-activate-on)
  (ad-enable-advice 'documentation 'after 'ad-advised-docstring)
  (ad-activate-on 'documentation 'compile))

(defun ad-stop-advice ()
  "Stops the automatic advice handling magic.
You should only need this in case of Advice-related emergencies."
  (interactive)
  ;; Advising `ad-activate' means death!!
  (ad-set-advice-info 'ad-activate nil)
  (ad-disable-advice 'documentation 'after 'ad-advised-docstring)
  (ad-update 'documentation)
  (ad-safe-fset 'ad-activate 'ad-activate-off))

(defun ad-recover-normality ()
  "Undoes all advice related redefinitions and unadvises everything. 
Use only in REAL emergencies."
  (interactive)
  ;; Advising `ad-activate' means death!!
  (ad-set-advice-info 'ad-activate nil)
  (ad-safe-fset 'ad-activate 'ad-activate-off)
  (ad-recover-all)
  (setq ad-advised-functions nil))

;; Until the Advice-related changes to `data.c' are part of Lemacs we
;; have to load the old implementation of advice activation hooks:
(if (ad-lemacs-p)
    (require 'ad-hooks))

(ad-start-advice)

(provide 'advice)

;;; advice.el ends here