aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorRichard M. Stallman1994-02-23 03:57:07 +0000
committerRichard M. Stallman1994-02-23 03:57:07 +0000
commit6e2f6f4518fb490338ed6e392c699508fc111461 (patch)
tree43fe37e25addf5549def72ae69d5afd52e42803d /lisp
parentc93b9aaef9b7e3e1228632e986f85d9ee41193f1 (diff)
downloademacs-6e2f6f4518fb490338ed6e392c699508fc111461.tar.gz
emacs-6e2f6f4518fb490338ed6e392c699508fc111461.zip
Removed all support for Emacs-18:
Removed autoload for `backquote'. Removed arglist specifications for `documentation' and `fset'. (ad-emacs19-p, ad-use-jwz-compiler): Removed these variables. (ad-lemacs-p, ad-v19-compiled-p, ad-subr-arglist, ad-make-advised-docstring): Removed reference to `ad-emacs19-p'. (ad-compiled-p): Renamed from `ad-v19-compiled-p'. Removed old definition of `ad-compiled-p'. (ad-compiled-code): Renamed from `ad-v19-compiled-code'. (ad-arglists, ad-docstring, ad-interactive-form): Use new names. (ad-body-forms): Always return nil for compiled definitions. (ad-compile-function): Simplified, because the v19 incarnation of `byte-compile' can compile macros. (ad-real-byte-codify): Removed. (ad-execute-defadvices): Removed. The `defadvice's it contained are now at the top level. (ad-advised-byte-code-definition): Renamed to `ad-advised-byte-code' and removed the definition of `ad-advised-byte-code' via `fset'. (ad-advised-byte-code-definition, ad-recover-byte-code, ad-stop-advice, ad-recover-normality): Removed `ad-real-byte-codify'-cation of their definitions. (ad-adjust-stack-sizes): Removed. (ad-enable-definition-hooks, ad-disable-definition-hooks): Removed v19 conditionalization. Fixed the problematic interaction between the byte-compiler and Advice when `ad-activate-on-definition' was t which resulted in erroneous compilation of nested `defun/defmacro's: (byte-compile-from-buffer, byte-compile-top-level): Advised to temporarily deactivate the advice of `defun/defmacro'. (ad-advised-definers, ad-advised-byte-compilers): New variables. (ad-enable-definition-hooks, ad-disable-definition-hooks): En/disable the advised byte-compiler entry points. (defadvice): Implement a `freeze' option which expands the `defadvice' into a redefining and dumpable `defun/defmacro' whose documentation can be written to the `DOC' file. Frozen advices cannot be undone, hence, they do not need any Advice runtime support. (ad-defadvice-flags): Add `freeze' flag. (ad-make-advised-docstring, ad-make-single-advice-docstring): New STYLE option for `plain' and `freeze' styles. Slightly changed the default formatting of advised docstrings. (ad-make-plain-docstring, ad-make-freeze-docstring): New functions. (ad-recover-all, ad-scan-byte-code-for-fsets): Removed unused condition variable `ignore-errors'. (ad-save-real-definition): New macro to save real definitions of functions used by Advice. Use `ad-save-real-definition' to save definitions of `fset', `byte-code' and now also `documentation'. (ad-subr-arglist, ad-docstring, ad-make-advised-docstring): Use `ad-real-documentation' to avoid interference with the advised version of `documentation'. (ad-execute-defadvices): Copy advice infos. (ad-start-advice-on-load): Default changed to t.
Diffstat (limited to 'lisp')
-rw-r--r--lisp/emacs-lisp/advice.el965
1 files changed, 486 insertions, 479 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index 83c81a98088..7d400842850 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -1,10 +1,10 @@
1;;; advice.el --- advice mechanism for Emacs Lisp functions 1;;; advice.el --- an overloading mechanism for Emacs Lisp functions
2 2
3;; Copyright (C) 1993 Free Software Foundation, Inc. 3;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
4 4
5;; Author: Hans Chalupsky <hans@cs.buffalo.edu> 5;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
6;; Created: 12 Dec 1992 6;; Created: 12 Dec 1992
7;; Version: advice.el,v 2.1 1993/05/26 00:07:58 hans Exp 7;; Version: advice.el,v 2.10 1994/02/21 10:34:03 hans Exp
8;; Keywords: extensions, lisp, tools 8;; Keywords: extensions, lisp, tools
9 9
10;; This file is part of GNU Emacs. 10;; This file is part of GNU Emacs.
@@ -25,12 +25,18 @@
25 25
26;; LCD Archive Entry: 26;; LCD Archive Entry:
27;; advice|Hans Chalupsky|hans@cs.buffalo.edu| 27;; advice|Hans Chalupsky|hans@cs.buffalo.edu|
28;; Advice mechanism for Emacs Lisp functions| 28;; Overloading mechanism for Emacs Lisp functions|
29;; 1993/05/26 00:07:58|2.1|~/packages/advice.el.Z| 29;; 1994/02/21 10:34:03|2.10|~/packages/advice.el.Z|
30 30
31 31
32;;; Commentary: 32;;; Commentary:
33 33
34;; NOTE: This documentation is slightly out of date. In particular, all the
35;; references to Emacs-18 are obsolete now, because it is not any longer
36;; supported by this version of Advice. An up-to-date version will soon be
37;; available as an info file (thanks to the kind help of Jack Vinson and
38;; David M. Smith).
39
34;; @ Introduction: 40;; @ Introduction:
35;; =============== 41;; ===============
36;; This package implements a full-fledged Lisp-style advice mechanism 42;; This package implements a full-fledged Lisp-style advice mechanism
@@ -80,39 +86,35 @@
80;; - Allows definition of load-hooks for arbitrary Emacs Lisp files without 86;; - Allows definition of load-hooks for arbitrary Emacs Lisp files without
81;; modification of these files 87;; modification of these files
82 88
83;; @ How to get the latest advice.el: 89;; @ How to get Advice for Emacs-18:
84;; ================================== 90;; =================================
85;; You can get the latest version of this package either via anonymous ftp 91;; `advice18.el', a version of Advice that also works in Emacs-18 is available
86;; from ftp.cs.buffalo.edu (128.205.32.9) with pathname /pub/Emacs/advice.el, 92;; either via anonymous ftp from `ftp.cs.buffalo.edu (128.205.32.9)' with
87;; or send email to hans@cs.buffalo.edu and I'll mail it to you. 93;; pathname `/pub/Emacs/advice18.el', or from one of the Emacs Lisp archive
94;; sites, or send email to <hans@cs.buffalo.edu> and I'll mail it to you.
88 95
89;; @ Overview, or how to read this file: 96;; @ Overview, or how to read this file:
90;; ===================================== 97;; =====================================
91;; Advice has enough features now to justify an info file, however, I 98;; NOTE: This documentation is slightly out of date. In particular, all the
92;; didn't have the time yet to do all the necessary formatting. So, 99;; references to Emacs-18 are obsolete now, because it is not any longer
93;; until I do have the time or some kind soul does it for me I crammed 100;; supported by this version of Advice. An up-to-date version will soon be
94;; everything into the source file. Because about 50% of this file is 101;; available as an info file (thanks to the kind help of Jack Vinson and
95;; documentation it should be in outline-mode by default, but it is not. 102;; David M. Smith). Until then you can use `outline-mode' to help you read
96;; If you choose to use outline-mode set `outline-regexp' to `";; @+"' 103;; this documentation (set `outline-regexp' to `";; @+"').
97;; and use `M-x hide-body' to see just the headings. Use the various
98;; other outline-mode functions to move around in the text. If you use
99;; Lucid Emacs, you'll just have to wait until `selective-display'
100;; works properly in order to be able to use outline-mode, sorry.
101;;
102;; And yes, I know: Documentation is for wimps.
103;; 104;;
104;; The four major sections of this file are: 105;; The four major sections of this file are:
105;; 106;;
106;; @ This initial information ...installation, customization etc. 107;; @ This initial information ...installation, customization etc.
107;; @ Advice documentation: ...general documentation 108;; @ Advice documentation: ...general documentation
108;; @ Foo games: An advice tutorial ...teaches about advice by example 109;; @ Foo games: An advice tutorial ...teaches about Advice by example
109;; @ Advice implementation: ...actual code, yeah!! 110;; @ Advice implementation: ...actual code, yeah!!
110;; 111;;
111;; The latter three are actual headings which you can search for 112;; The latter three are actual headings which you can search for
112;; directly in case outline-mode doesn't work for you. 113;; directly in case `outline-mode' doesn't work for you.
113 114
114;; @ Restrictions: 115;; @ Restrictions:
115;; =============== 116;; ===============
117;; - This version of Advice only works for Emacs-19 or Lucid Emacs.
116;; - Advised functions/macros/subrs will only exhibit their advised behavior 118;; - Advised functions/macros/subrs will only exhibit their advised behavior
117;; when they are invoked via their function cell. This means that advice will 119;; when they are invoked via their function cell. This means that advice will
118;; not work for the following: 120;; not work for the following:
@@ -121,9 +123,13 @@
121;; byte-compilation (e.g., car) 123;; byte-compilation (e.g., car)
122;; + advised macros which were expanded during byte-compilation before 124;; + advised macros which were expanded during byte-compilation before
123;; their advice was activated. 125;; their advice was activated.
124;; - This package was developed under GNU Emacs 18.59 and Lucid Emacs 19.6. 126
125;; It was adapted and tested for GNU Emacs 19.8 and seems to work ok for 127;; @ Known bug:
126;; Epoch 4.2. For different Emacs environments your mileage may vary. 128;; ============
129;; - Using automatic activation of (forward) advice will break the
130;; function `interactive-p' when it is used in the body of a `catch'
131;; (this problem will go away once automatic advice activation gets
132;; supported by built-in functions).
127 133
128;; @ Credits: 134;; @ Credits:
129;; ========== 135;; ==========
@@ -137,33 +143,33 @@
137;; ===================================== 143;; =====================================
138;; If you find any bugs, have suggestions for new advice features, find the 144;; If you find any bugs, have suggestions for new advice features, find the
139;; documentation wrong, confusing, incomplete, or otherwise unsatisfactory, 145;; documentation wrong, confusing, incomplete, or otherwise unsatisfactory,
140;; have any questions about advice.el, or have otherwise enlightening 146;; have any questions about Advice, or have otherwise enlightening
141;; comments feel free to send me email at <hans@cs.buffalo.edu>. 147;; comments feel free to send me email at <hans@cs.buffalo.edu>.
142 148
143;; @ Safety Rules and Emergency Exits: 149;; @ Safety Rules and Emergency Exits:
144;; =================================== 150;; ===================================
145;; Before we begin: CAUTION!! 151;; Before we begin: CAUTION!!
146;; advice.el provides you with a lot of rope to hang yourself on very 152;; Advice provides you with a lot of rope to hang yourself on very
147;; easily accessible trees, so, here are a few important things you 153;; easily accessible trees, so, here are a few important things you
148;; should know: Once advice has been started with `ad-start-advice' it 154;; should know: Once Advice has been started with `ad-start-advice' it
149;; generates advised definitions of the `documentation' function, and, 155;; generates advised definitions of the `documentation' function, and,
150;; if definition hooks are enabled (e.g., for forward advice), also of 156;; if definition hooks are enabled (e.g., for forward advice), also of
151;; `defun', `defmacro' and `fset' (if you use Jamie Zawinski's (jwz) 157;; `defun', `defmacro' and `fset' (if you use Jamie Zawinski's (jwz)
152;; optimizing byte-compiler as standardly used in GNU Emacs-19 and 158;; optimizing byte-compiler as standardly used in Emacs-19 and
153;; Lucid Emacs-19 (Lemacs), then enabling definition hooks will also 159;; Lucid Emacs-19 (Lemacs), then enabling definition hooks will also
154;; redefine the `byte-code' subr). All these changes can be undone at 160;; redefine the `byte-code' subr). All these changes can be undone at
155;; any time with `M-x ad-stop-advice'. 161;; any time with `M-x ad-stop-advice'.
156;; 162;;
157;; If you experience any strange behavior/errors etc. that you attribute to 163;; If you experience any strange behavior/errors etc. that you attribute to
158;; advice.el or to some ill-advised function do one of the following: 164;; Advice or to some ill-advised function do one of the following:
159 165
160;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what 166;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what
161;; function gives you problems) 167;; function gives you problems)
162;; - M-x ad-deactivate-all (if you don't have a clue what's going wrong) 168;; - M-x ad-deactivate-all (if you don't have a clue what's going wrong)
163;; - M-x ad-stop-advice (if you think the problem is related to the 169;; - M-x ad-stop-advice (if you think the problem is related to the
164;; advised functions used by advice.el itself) 170;; advised functions used by Advice itself)
165;; - M-x ad-recover-normality (for real emergencies) 171;; - M-x ad-recover-normality (for real emergencies)
166;; - If none of the above solves your advice related problem go to another 172;; - If none of the above solves your Advice-related problem go to another
167;; terminal, kill your Emacs process and send me some hate mail. 173;; terminal, kill your Emacs process and send me some hate mail.
168 174
169;; The first three measures have restarts, i.e., once you've figured out 175;; The first three measures have restarts, i.e., once you've figured out
@@ -172,40 +178,16 @@
172;; everything so you won't be able to reactivate any advised functions, you'll 178;; everything so you won't be able to reactivate any advised functions, you'll
173;; have to stick with their standard incarnations for the rest of the session. 179;; have to stick with their standard incarnations for the rest of the session.
174 180
175;; IMPORTANT: With advice.el loaded always do `M-x ad-deactivate-all' before 181;; IMPORTANT: With Advice loaded always do `M-x ad-deactivate-all' before
176;; you byte-compile a file, because advised special forms and macros can lead 182;; you byte-compile a file, because advised special forms and macros can lead
177;; to unwanted compilation results. When you are done compiling use 183;; to unwanted compilation results. When you are done compiling use
178;; `M-x ad-activate-all' to go back to the advised state of all your 184;; `M-x ad-activate-all' to go back to the advised state of all your
179;; advised functions. 185;; advised functions.
180 186
181;; RELAX: advice.el is pretty safe even if you are oblivious to the above. 187;; RELAX: Advice is pretty safe even if you are oblivious to the above.
182;; I use it extensively and haven't run into any serious trouble in a long 188;; I use it extensively and haven't run into any serious trouble in a long
183;; time. Just wanted you to be warned. 189;; time. Just wanted you to be warned.
184 190
185;; @ Installation:
186;; ===============
187;; Put this file somewhere into your Emacs `load-path' and byte-compile it.
188;; Both steps are mandatory! You cannot (and would not want to) run advice
189;; uncompiled, and because there is bootstrapping going on the byte-compiler
190;; needs to preload advice in order to compile it, hence, it has to find it
191;; in your `load-path' (you can preload advice.el "by hand" before you compile
192;; it if you don't want to put it into your `load-path'). Once you have
193;; compiled advice put the following autoload declarations into your .emacs
194;; to load it on demand
195;;
196;; (autoload 'defadvice "advice" "Define a piece of advice" nil t)
197;; (autoload 'ad-add-advice "advice" "Add a piece of advice")
198;; (autoload 'ad-start-advice "advice" "Start advice magic" t)
199;;
200;; or explicitly load it with (require 'advice) or (load "advice").
201
202;; @@ Preloading:
203;; ==============
204;; If you preload the complete advice.el or its autoloads into a dumped Emacs
205;; image and you use jwz's byte-compiler make sure advice gets loaded after the
206;; byte-compiler runtime support is loaded so that `ad-use-jwz-byte-compiler'
207;; receives the proper initial value.
208
209;; @ Customization: 191;; @ Customization:
210;; ================ 192;; ================
211;; Part of the advice magic does not start until you call `ad-start-advice' 193;; Part of the advice magic does not start until you call `ad-start-advice'
@@ -227,16 +209,6 @@
227;; defined/loaded. The value of this variable will not have any effect until 209;; defined/loaded. The value of this variable will not have any effect until
228;; `ad-start-advice' gets executed. 210;; `ad-start-advice' gets executed.
229 211
230;; If you use a v18 Emacs but use jwz's byte-compiler and want to use
231;; forward advice make sure that `ad-use-jwz-byte-compiler' has a non-NIL
232;; value after advice.el got loaded. If it doesn't set it explicitly in
233;; your .emacs with
234;;
235;; (setq ad-use-jwz-byte-compiler t)
236;;
237;; Also make sure that you read the paragraph on forward advice below to
238;; find out about the trade-offs involved for this combination of features.
239
240;; Look at the documentation of `ad-redefinition-action' for possible values 212;; Look at the documentation of `ad-redefinition-action' for possible values
241;; of this variable. Its default value is `warn' which will print a warning 213;; of this variable. Its default value is `warn' which will print a warning
242;; message when an already defined advised function gets redefined with a 214;; message when an already defined advised function gets redefined with a
@@ -281,13 +253,14 @@
281 253
282;; @@ Terminology: 254;; @@ Terminology:
283;; =============== 255;; ===============
284;; - GNU Emacs-19: GNU's version of Emacs with major version 19 256;; - Emacs, Emacs-19: FSF's version of Emacs with major version 19
285;; - Lemacs: Lucid's version of Emacs with major version 19 257;; - Lemacs: Lucid's version of Emacs with major version 19
286;; - v18: Any Emacs with major version 18 or built as an extension to that 258;; - v18: Any Emacs with major version 18 or built as an extension to that
287;; (such as Epoch) 259;; (such as Epoch)
288;; - v19: Any Emacs with major version 19 260;; - v19: Any Emacs with major version 19
289;; - jwz: Jamie Zawinski - keeper of Lemacs and creator of the optimizing 261;; - jwz: Jamie Zawinski - keeper of Lemacs and creator of the optimizing
290;; byte-compiler used in v19s. 262;; byte-compiler used in v19s.
263;; - Advice: The name of this package.
291;; - advices: Short for "pieces of advice". 264;; - advices: Short for "pieces of advice".
292 265
293;; @@ Defining a piece of advice with `defadvice': 266;; @@ Defining a piece of advice with `defadvice':
@@ -307,7 +280,7 @@
307;; `around', `after', `activation' or `deactivation' (the last two allow 280;; `around', `after', `activation' or `deactivation' (the last two allow
308;; definition of special act/deactivation hooks). 281;; definition of special act/deactivation hooks).
309 282
310;; <name> is the name of the advice which has to be a non-NIL symbol. 283;; <name> is the name of the advice which has to be a non-nil symbol.
311;; Names uniquely identify a piece of advice in a certain advice class, 284;; Names uniquely identify a piece of advice in a certain advice class,
312;; hence, advices can be redefined by defining an advice with the same class 285;; hence, advices can be redefined by defining an advice with the same class
313;; and name. Advice names are global symbols, hence, the same name space 286;; and name. Advice names are global symbols, hence, the same name space
@@ -560,7 +533,7 @@
560;; know the argument list of the original function. For functions and macros 533;; know the argument list of the original function. For functions and macros
561;; the argument list can be determined from the actual definition, however, 534;; the argument list can be determined from the actual definition, however,
562;; for subrs there is no such direct access available. In Lemacs and for some 535;; for subrs there is no such direct access available. In Lemacs and for some
563;; subrs in GNU Emacs-19 the argument list of a subr can be determined from 536;; subrs in Emacs-19 the argument list of a subr can be determined from
564;; its documentation string, in a v18 Emacs even that is not possible. If 537;; its documentation string, in a v18 Emacs even that is not possible. If
565;; advice cannot at all determine the argument list of a subr it uses 538;; advice cannot at all determine the argument list of a subr it uses
566;; `(&rest ad-subr-args)' which will always work but is inefficient because 539;; `(&rest ad-subr-args)' which will always work but is inefficient because
@@ -775,7 +748,7 @@
775;; The v18 byte-compiler only uses `defun/defmacro' to define compiled 748;; The v18 byte-compiler only uses `defun/defmacro' to define compiled
776;; functions, hence, providing advised versions of these functions was 749;; functions, hence, providing advised versions of these functions was
777;; sufficient to achieve forward advice. With the advent of Jamie Zawinski's 750;; sufficient to achieve forward advice. With the advent of Jamie Zawinski's
778;; optimizing byte-compiler which is now standardly used in GNU Emacs-19 and 751;; optimizing byte-compiler which is now standardly used in Emacs-19 and
779;; Lemacs things became more complicated. jwz's compiler defines functions 752;; Lemacs things became more complicated. jwz's compiler defines functions
780;; in hunks of byte-code without explicit usage of `defun/defmacro'. To 753;; in hunks of byte-code without explicit usage of `defun/defmacro'. To
781;; still provide forward advice even in this scenario, advice defines an 754;; still provide forward advice even in this scenario, advice defines an
@@ -854,7 +827,7 @@
854;; of `byte-code' to execute hunks of function defining byte-code at the 827;; of `byte-code' to execute hunks of function defining byte-code at the
855;; top level of compiled files. 828;; top level of compiled files.
856;; - Definition hooks should be implemented directly as part of the C-code 829;; - Definition hooks should be implemented directly as part of the C-code
857;; that implements `fset', because then advice.el wouldn't have to use all 830;; that implements `fset', because then Advice wouldn't have to use all
858;; these dirty hacks to achieve this functionality. 831;; these dirty hacks to achieve this functionality.
859 832
860;; @@ Caching of advised definitions: 833;; @@ Caching of advised definitions:
@@ -949,7 +922,7 @@
949;; MORAL-II: Redefining somebody else's advice is BAAAAD (to speak with 922;; MORAL-II: Redefining somebody else's advice is BAAAAD (to speak with
950;; George Walker Bush), and why would you redefine your own advice anyway? 923;; George Walker Bush), and why would you redefine your own advice anyway?
951;; Advice is a mechanism to facilitate function redefinition, not advice 924;; Advice is a mechanism to facilitate function redefinition, not advice
952;; redefinition (wait until I write meta-advice.el :-). If you really have 925;; redefinition (wait until I write Meta-Advice :-). If you really have
953;; to undo somebody else's advice try to write a "neutralizing" advice. 926;; to undo somebody else's advice try to write a "neutralizing" advice.
954 927
955;; @@ Advising macros and special forms and other dangerous things: 928;; @@ Advising macros and special forms and other dangerous things:
@@ -1093,7 +1066,7 @@
1093 1066
1094;; @ Foo games: An advice tutorial 1067;; @ Foo games: An advice tutorial
1095;; =============================== 1068;; ===============================
1096;; The following tutorial was created in GNU Emacs 18.59. Left-justified 1069;; The following tutorial was created in Emacs 18.59. Left-justified
1097;; s-expressions are input forms followed by one or more result forms. 1070;; s-expressions are input forms followed by one or more result forms.
1098;; First we have to start the advice magic: 1071;; First we have to start the advice magic:
1099;; 1072;;
@@ -1817,12 +1790,12 @@
1817;; @@ Specifying argument lists of subrs: 1790;; @@ Specifying argument lists of subrs:
1818;; ====================================== 1791;; ======================================
1819;; The argument lists of subrs cannot be determined directly from Lisp. 1792;; The argument lists of subrs cannot be determined directly from Lisp.
1820;; This means that advice.el has to use `(&rest ad-subr-args)' as the 1793;; This means that Advice has to use `(&rest ad-subr-args)' as the
1821;; argument list of the advised subr which is not very efficient. In Lemacs 1794;; argument list of the advised subr which is not very efficient. In Lemacs
1822;; subr argument lists can be determined from their documentation string, in 1795;; subr argument lists can be determined from their documentation string, in
1823;; GNU Emacs-19 this is the case for some but not all subrs. To accommodate 1796;; Emacs-19 this is the case for some but not all subrs. To accommodate
1824;; for the cases where the argument lists cannot be determined (e.g., in a 1797;; for the cases where the argument lists cannot be determined (e.g., in a
1825;; v18 Emacs) advice.el comes with a specification mechanism that allows the 1798;; v18 Emacs) Advice comes with a specification mechanism that allows the
1826;; advice programmer to tell advice what the argument list of a certain subr 1799;; advice programmer to tell advice what the argument list of a certain subr
1827;; really is. 1800;; really is.
1828;; 1801;;
@@ -1968,9 +1941,73 @@
1968;;; Change Log: 1941;;; Change Log:
1969 1942
1970;; advice.el,v 1943;; advice.el,v
1944;; Revision 2.10 1994/02/21 10:34:03 hans
1945;; * Removed all support for Emacs-18 and associated conditional code.
1946;; * Made some minor changes to the documentation which is now
1947;; slightly out-of-date.
1948;;
1949;; Revision 2.9 1994/02/21 08:03:39 hans
1950;; * Lots of cosmetic changes to make documentation strings
1951;; conform to the standard conventions.
1952;; * Some minor changes to the general documentation.
1953;; * This version is the last one that still supports a v18 Emacs.
1954;; It will be made available as `advice18.el'.
1955;;
1956;; Revision 2.8 1994/02/20 01:46:02 hans
1957;; * (ad-enable-definition-hooks): Disabled definition hooks for
1958;; the combination of a v18 Emacs with a v19 byte-compiler,
1959;; because it breaks the rather important `interactive-p'.
1960;;
1961;; Revision 2.7 1994/02/20 01:09:18 hans
1962;; * Fixed the problematic interaction between the byte-compiler and
1963;; Advice when `ad-activate-on-definition' was t which
1964;; resulted in erroneous compilation of nested `defun/defmacro's:
1965;; * (byte-compile-from-buffer, byte-compile-top-level): Now
1966;; advised to temporarily deactivate the advice of `defun/defmacro'.
1967;; * (ad-advised-definers, ad-advised-byte-compilers): New variables.
1968;; * (ad-execute-defadvices): Contains the new advices for the
1969;; byte-compiler entry points. Uses new variables to copy advice infos.
1970;; * (ad-enable-definition-hooks, ad-disable-definition-hooks):
1971;; Additionally en/disable the advised byte-compiler entry
1972;; points. Uses new variables to do so.
1973;;
1974;; Revision 2.6 1994/02/18 11:02:00 hans
1975;; * (defadvice): Implement jwz's idea of a `freeze' option which
1976;; expands the `defadvice' into a dumpable `defun/defmacro'
1977;; whose documentation can be written to the `DOC' file.
1978;; * (ad-make-advised-docstring, ad-make-single-advice-docstring):
1979;; New STYLE option for `plain' and `freeze' styles. Slightly
1980;; changed the default formatting of advised docstrings.
1981;; * (ad-make-plain-docstring, ad-make-freeze-docstring): New functions.
1982;;
1983;; Revision 2.5 1994/02/18 06:52:25 hans
1984;; * Merged with version of Lemacs 19.9: Infinite recursion bug in jwz's
1985;; adaption of `ad-docstring' fixed with use of `ad-real-documentation'.
1986;; * (ad-recover-all, ad-scan-byte-code-for-fsets): Removed
1987;; unused condition variable `ignore-errors'.
1988;;
1989;; Revision 2.4 1994/02/18 06:01:56 hans
1990;; * (ad-save-real-definition): New macro to save real
1991;; definitions of functions used by Advice with all the
1992;; necessary byte-compile properties.
1993;; * Now also save real definition of `documentation'.
1994;; * (ad-subr-arglist, ad-docstring, ad-make-advised-docstring):
1995;; Use `ad-real-documentation' to avoid interference with
1996;; advised version.
1997;;
1998;; Revision 2.3 1994/01/25 05:25:00 hans
1999;; * (ad-execute-defadvices): Copy advice infos to make sure they
2000;; are not allocated in pure space during preloading (otherwise
2001;; we cannot modify them later on).
2002;;
2003;; Revision 2.2 1993/12/23 02:32:34 hans
2004;; * Merged with the version of the Emacs 19.22 distribution:
2005;; (ad-start-advice-on-load): Default is now t.
2006;; New value for `Keywords' header specification.
2007;;
1971;; Revision 2.1 1993/05/26 00:07:58 hans 2008;; Revision 2.1 1993/05/26 00:07:58 hans
1972;; * advise `defalias' and `define-function' to properly handle forward 2009;; * advise `defalias' and `define-function' to properly handle forward
1973;; advice in GNU Emacs-19.7 and later 2010;; advice in Emacs-19.7 and later
1974;; * fix minor bug in `ad-preactivate-advice' 2011;; * fix minor bug in `ad-preactivate-advice'
1975;; * merge with FSF installation of version 2.0 2012;; * merge with FSF installation of version 2.0
1976;; 2013;;
@@ -2002,47 +2039,35 @@
2002;; ============================== 2039;; ==============================
2003 2040
2004;; `defadvice' expansion needs quite a few advice functions and variables, 2041;; `defadvice' expansion needs quite a few advice functions and variables,
2005;; hence, I need to preload the file before it can be compiled. To avoid 2042;; hence, I need to preload the file before it can be compiled. To avoid
2006;; interference of bogus compiled files I always preload the source file: 2043;; interference of bogus compiled files I always preload the source file:
2007(provide 'advice-preload) 2044(provide 'advice-preload)
2008;; During a normal load this is a noop: 2045;; During a normal load this is a noop:
2009(require 'advice-preload "advice.el") 2046(require 'advice-preload "advice.el")
2010 2047
2011;; For the odd case that ``' does not have an autoload definition in some
2012;; Emacs we autoload it here. It is only needed for compilation, hence,
2013;; I don't want to unconditionally `require' it (re-autoloading ``' after
2014;; this file got preloaded will properly redefine this autoload):
2015(if (not (fboundp '`)) (autoload '` "backquote"))
2016
2017 2048
2018;; @@ Variable definitions: 2049;; @@ Variable definitions:
2019;; ======================== 2050;; ========================
2020 2051
2021(defconst ad-version "2.1") 2052(defconst ad-version "2.10")
2022
2023(defconst ad-emacs19-p
2024 (not (or (and (boundp 'epoch::version) epoch::version)
2025 (string-lessp emacs-version "19")))
2026 "Non-NIL if we run Emacs version 19 or higher.
2027This will be true for GNU Emacs-19 as well as Lemacs.")
2028 2053
2029(defconst ad-lemacs-p 2054(defconst ad-lemacs-p
2030 (and ad-emacs19-p (string-match "Lucid" emacs-version)) 2055 (string-match "Lucid" emacs-version)
2031 "Non-NIL if we run Lucid's version of Emacs-19.") 2056 "Non-nil if we run Lucid's version of Emacs-19.")
2032 2057
2033;;;###autoload 2058;;;###autoload
2034(defvar ad-start-advice-on-load t 2059(defvar ad-start-advice-on-load t
2035 "*Non-NIL will start advice magic when this file gets loaded. 2060 "*Non-nil will start Advice magic when this file gets loaded.
2036Also see function `ad-start-advice'.") 2061Also see function `ad-start-advice'.")
2037 2062
2038;;;###autoload 2063;;;###autoload
2039(defvar ad-activate-on-definition nil 2064(defvar ad-activate-on-definition nil
2040 "*Non-NIL means automatic advice activation at function definition. 2065 "*Non-nil means automatic advice activation at function definition.
2041Set this variable to t if you want to enable forward advice (which is 2066Set this variable to t if you want to enable forward advice (which is
2042automatic advice activation of a previously undefined function at the 2067automatic advice activation of a previously undefined function at the
2043point the function gets defined/loaded/autoloaded). The value of this 2068point the function gets defined/loaded/autoloaded). The value of this
2044variable takes effect only during the execution of `ad-start-advice'. 2069variable takes effect only during the execution of `ad-start-advice'.
2045If non-NIL it will enable definition hooks regardless of the value 2070If non-nil it will enable definition hooks regardless of the value
2046of `ad-enable-definition-hooks'.") 2071of `ad-enable-definition-hooks'.")
2047 2072
2048;;;###autoload 2073;;;###autoload
@@ -2052,9 +2077,9 @@ Redefinition occurs if a previously activated function that already has an
2052original definition associated with it gets redefined and then de/activated. 2077original definition associated with it gets redefined and then de/activated.
2053In such a case we can either accept the current definition as the new 2078In such a case we can either accept the current definition as the new
2054original definition, discard the current definition and replace it with the 2079original definition, discard the current definition and replace it with the
2055old original, or keep it and raise an error. The values `accept', `discard', 2080old original, or keep it and raise an error. The values `accept', `discard',
2056`error' or `warn' govern what will be done. `warn' is just like `accept' but 2081`error' or `warn' govern what will be done. `warn' is just like `accept' but
2057it additionally prints a warning message. All other values will be 2082it additionally prints a warning message. All other values will be
2058interpreted as `error'.") 2083interpreted as `error'.")
2059 2084
2060;;;###autoload 2085;;;###autoload
@@ -2065,48 +2090,9 @@ the currently defined function when the hook function is run.")
2065 2090
2066;;;###autoload 2091;;;###autoload
2067(defvar ad-enable-definition-hooks nil 2092(defvar ad-enable-definition-hooks nil
2068 "*Non-NIL will enable hooks to be run on function definition. 2093 "*Non-nil will enable hooks to be run on function definition.
2069Setting this variable is a noop unless the value of 2094Setting this variable is a noop unless the value of
2070`ad-activate-on-definition' (which see) is NIL.") 2095`ad-activate-on-definition' (which see) is nil.")
2071
2072;; The following autoload depends on proper preloading of the runtime
2073;; support of jwz's byte-compiler for accurate initialization:
2074
2075;;;###autoload
2076(defvar ad-use-jwz-byte-compiler
2077 ;; True if jwz's bytecomp-runtime is loaded:
2078 (fboundp 'eval-when-compile)
2079 "*Non-NIL means Jamie Zawinski's v19 byte-compiler will be used.
2080If you use a v18 Emacs and don't use jwz's optimizing byte-compiler (the
2081normal case) then this variable should be NIL, because otherwise
2082enabling definition hooks (e.g., for forward advice) will redefine the
2083`byte-code' subr which will lead to some performance degradation for
2084byte-compiled code.")
2085
2086
2087;; @@ `fset/byte-code' hack for jwz's byte-compiler:
2088;; =================================================
2089;; Because byte-compiled files that were generated by jwz's byte-compiler
2090;; (as standardly used in v19s) define compiled functions and macros via
2091;; `fset' and `byte-code' instead of `defun/defmacro' we have to advise
2092;; `fset' similar to `defun/defmacro' and redefine `byte-code' to allow
2093;; proper forward advice; hence, we have to make sure that there are
2094;; proper primitive versions around that can be used by the advice package
2095;; itself.
2096;;
2097;; Wish: A `byte-code-tl' function to be used at the top level of byte-
2098;; compiled files which could be advised for the purpose of forward
2099;; advice without creating all that trouble caused by redefining
2100;; `byte-code'.
2101
2102(if (not (fboundp 'ad-real-fset))
2103 (progn (fset 'ad-real-fset (symbol-function 'fset))
2104 ;; Copy byte-compiler properties:
2105 (put 'ad-real-fset 'byte-compile (get 'fset 'byte-compile))
2106 (put 'ad-real-fset 'byte-opcode (get 'fset 'byte-opcode))))
2107
2108(if (not (fboundp 'ad-real-byte-code))
2109 (fset 'ad-real-byte-code (symbol-function 'byte-code)))
2110 2096
2111 2097
2112;; @@ Some utilities: 2098;; @@ Some utilities:
@@ -2118,8 +2104,8 @@ byte-compiled code.")
2118 ;;"Substitutes qualifying subTREEs with result of FUNCTION(subTREE). 2104 ;;"Substitutes qualifying subTREEs with result of FUNCTION(subTREE).
2119 ;;Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4) 2105 ;;Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4)
2120 ;;then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are 2106 ;;then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are
2121 ;;allowed too. Once a qualifying subtree has been found its subtrees will 2107 ;;allowed too. Once a qualifying subtree has been found its subtrees will
2122 ;;not be considered anymore. (ad-substitute-tree 'atom 'identity tree) 2108 ;;not be considered anymore. (ad-substitute-tree 'atom 'identity tree)
2123 ;;generates a copy of TREE." 2109 ;;generates a copy of TREE."
2124 (cond ((consp tReE) 2110 (cond ((consp tReE)
2125 (cons (if (funcall sUbTrEe-TeSt (car tReE)) 2111 (cons (if (funcall sUbTrEe-TeSt (car tReE))
@@ -2143,13 +2129,13 @@ byte-compiled code.")
2143(defmacro ad-dolist (varform &rest body) 2129(defmacro ad-dolist (varform &rest body)
2144 "A Common-Lisp-style dolist iterator with the following syntax: 2130 "A Common-Lisp-style dolist iterator with the following syntax:
2145 2131
2146 (ad-dolist (<var> <init-form> [<result-form>]) 2132 (ad-dolist (VAR INIT-FORM [RESULT-FORM])
2147 {body-form}*) 2133 BODY-FORM...)
2148 2134
2149which will iterate over the list yielded by <init-form> binding <var> to the 2135which will iterate over the list yielded by INIT-FORM binding VAR to the
2150current head at every iteration. If <result-form> is supplied its value will 2136current head at every iteration. If RESULT-FORM is supplied its value will
2151be returned at the end of the iteration, NIL otherwise. The iteration can be 2137be returned at the end of the iteration, nil otherwise. The iteration can be
2152exited prematurely with (ad-do-return [<value>])." 2138exited prematurely with `(ad-do-return [VALUE])'."
2153 (let ((expansion 2139 (let ((expansion
2154 (` (let ((ad-dO-vAr (, (car (cdr varform)))) 2140 (` (let ((ad-dO-vAr (, (car (cdr varform))))
2155 (, (car varform))) 2141 (, (car varform)))
@@ -2180,11 +2166,43 @@ exited prematurely with (ad-do-return [<value>])."
2180 (put 'ad-dolist 'lisp-indent-hook 1)) 2166 (put 'ad-dolist 'lisp-indent-hook 1))
2181 2167
2182 2168
2169;; @@ Save real definitions of subrs used by Advice:
2170;; =================================================
2171;; Advice depends on the real, unmodified functionality of various subrs,
2172;; we save them here so advised versions will not interfere (eventually,
2173;; we will save all subrs used in code generated by Advice):
2174
2175(defmacro ad-save-real-definition (function)
2176 (let ((saved-function (intern (format "ad-real-%s" function))))
2177 ;; Make sure the compiler is loaded during macro expansion:
2178 (require 'byte-compile "bytecomp")
2179 (` (if (not (fboundp '(, saved-function)))
2180 (progn (fset '(, saved-function) (symbol-function '(, function)))
2181 ;; Copy byte-compiler properties:
2182 (,@ (if (get function 'byte-compile)
2183 (` ((put '(, saved-function) 'byte-compile
2184 '(, (get function 'byte-compile)))))))
2185 (,@ (if (get function 'byte-opcode)
2186 (` ((put '(, saved-function) 'byte-opcode
2187 '(, (get function 'byte-opcode))))))))))))
2188
2189(defun ad-save-real-definitions ()
2190 ;; Macro expansion will hardcode the values of the various byte-compiler
2191 ;; properties into the compiled version of this function such that the
2192 ;; proper values will be available at runtime without loading the compiler:
2193 (ad-save-real-definition fset)
2194 (ad-save-real-definition documentation)
2195 (ad-save-real-definition byte-code)
2196 (put 'ad-real-byte-code 'byte-compile nil))
2197
2198(ad-save-real-definitions)
2199
2200
2183;; @@ Advice info access fns: 2201;; @@ Advice info access fns:
2184;; ========================== 2202;; ==========================
2185 2203
2186;; Advice information for a particular function is stored on the 2204;; Advice information for a particular function is stored on the
2187;; advice-info property of the function symbol. It is stored as an 2205;; advice-info property of the function symbol. It is stored as an
2188;; alist of the following format: 2206;; alist of the following format:
2189;; 2207;;
2190;; ((active . t/nil) 2208;; ((active . t/nil)
@@ -2215,9 +2233,9 @@ exited prematurely with (ad-do-return [<value>])."
2215 2233
2216(defmacro ad-do-advised-functions (varform &rest body) 2234(defmacro ad-do-advised-functions (varform &rest body)
2217 ;;"`ad-dolist'-style iterator that maps over `ad-advised-functions'. 2235 ;;"`ad-dolist'-style iterator that maps over `ad-advised-functions'.
2218 ;; (ad-do-advised-functions (<var> [<result-form>]) 2236 ;; (ad-do-advised-functions (VAR [RESULT-FORM])
2219 ;; {body-form}*) 2237 ;; BODY-FORM...)
2220 ;;Also see `ad-dolist'. On each iteration <var> will be bound to the 2238 ;;Also see `ad-dolist'. On each iteration VAR will be bound to the
2221 ;;name of an advised function (a symbol)." 2239 ;;name of an advised function (a symbol)."
2222 (` (ad-dolist ((, (car varform)) 2240 (` (ad-dolist ((, (car varform))
2223 ad-advised-functions 2241 ad-advised-functions
@@ -2238,7 +2256,7 @@ exited prematurely with (ad-do-return [<value>])."
2238 (` (ad-copy-tree (get (, function) 'ad-advice-info)))) 2256 (` (ad-copy-tree (get (, function) 'ad-advice-info))))
2239 2257
2240(defmacro ad-is-advised (function) 2258(defmacro ad-is-advised (function)
2241 ;;"Returns non-NIL if FUNCTION has any advice info associated with it. 2259 ;;"Returns non-nil if FUNCTION has any advice info associated with it.
2242 ;;This does not mean that the advice is also active." 2260 ;;This does not mean that the advice is also active."
2243 (list 'ad-get-advice-info function)) 2261 (list 'ad-get-advice-info function))
2244 2262
@@ -2264,7 +2282,7 @@ exited prematurely with (ad-do-return [<value>])."
2264 2282
2265;; Don't make this a macro so we can use it as a predicate: 2283;; Don't make this a macro so we can use it as a predicate:
2266(defun ad-is-active (function) 2284(defun ad-is-active (function)
2267 ;;"non-NIL if FUNCTION is advised and activated." 2285 ;;"non-nil if FUNCTION is advised and activated."
2268 (ad-get-advice-info-field function 'active)) 2286 (ad-get-advice-info-field function 'active))
2269 2287
2270 2288
@@ -2273,9 +2291,9 @@ exited prematurely with (ad-do-return [<value>])."
2273 2291
2274(defun ad-make-advice (name protect enable definition) 2292(defun ad-make-advice (name protect enable definition)
2275 "Constructs single piece of advice to be stored in some advice-info. 2293 "Constructs single piece of advice to be stored in some advice-info.
2276NAME should be a non-NIL symbol, PROTECT and ENABLE should each be 2294NAME should be a non-nil symbol, PROTECT and ENABLE should each be
2277either t or nil, and DEFINITION should be a list of the form 2295either t or nil, and DEFINITION should be a list of the form
2278 (advice lambda ({<arg>}*) [docstring] [(interactive ...)] {body-form}*)" 2296`(advice lambda ARGLIST [DOCSTRING] [INTERACTIVE-FORM] BODY...)'."
2279 (list name protect enable definition)) 2297 (list name protect enable definition))
2280 2298
2281;; ad-find-advice uses the alist structure directly -> 2299;; ad-find-advice uses the alist structure directly ->
@@ -2340,9 +2358,9 @@ either t or nil, and DEFINITION should be a list of the form
2340;; ============================================ 2358;; ============================================
2341;; The advice-info of an advised function contains its `origname' which is 2359;; The advice-info of an advised function contains its `origname' which is
2342;; a symbol that is fbound to the original definition available at the first 2360;; a symbol that is fbound to the original definition available at the first
2343;; proper activation of the function after a legal re/definition. If the 2361;; proper activation of the function after a legal re/definition. If the
2344;; original was defined via fcell indirection then `origname' will be defined 2362;; original was defined via fcell indirection then `origname' will be defined
2345;; just so. Hence, to get hold of the actual original definition of a function 2363;; just so. Hence, to get hold of the actual original definition of a function
2346;; we need to use `ad-real-orig-definition'. 2364;; we need to use `ad-real-orig-definition'.
2347 2365
2348(defun ad-make-origname (function) 2366(defun ad-make-origname (function)
@@ -2367,10 +2385,10 @@ either t or nil, and DEFINITION should be a list of the form
2367 2385
2368(defun ad-read-advised-function (&optional prompt predicate default) 2386(defun ad-read-advised-function (&optional prompt predicate default)
2369 ;;"Reads name of advised function with completion from the minibuffer. 2387 ;;"Reads name of advised function with completion from the minibuffer.
2370 ;;An optional PROMPT will be used to prompt for the function. PREDICATE 2388 ;;An optional PROMPT will be used to prompt for the function. PREDICATE
2371 ;;plays the same role as for `try-completion' (which see). DEFAULT will 2389 ;;plays the same role as for `try-completion' (which see). DEFAULT will
2372 ;;be returned on empty input (defaults to the first advised function for 2390 ;;be returned on empty input (defaults to the first advised function for
2373 ;;which PREDICATE returns non-NIL)." 2391 ;;which PREDICATE returns non-nil)."
2374 (if (null ad-advised-functions) 2392 (if (null ad-advised-functions)
2375 (error "ad-read-advised-function: There are no advised functions")) 2393 (error "ad-read-advised-function: There are no advised functions"))
2376 (setq default 2394 (setq default
@@ -2406,7 +2424,7 @@ either t or nil, and DEFINITION should be a list of the form
2406 2424
2407(defun ad-read-advice-class (function &optional prompt default) 2425(defun ad-read-advice-class (function &optional prompt default)
2408 ;;"Reads a legal advice class with completion from the minibuffer. 2426 ;;"Reads a legal advice class with completion from the minibuffer.
2409 ;;An optional PROMPT will be used to prompt for the class. DEFAULT will 2427 ;;An optional PROMPT will be used to prompt for the class. DEFAULT will
2410 ;;be returned on empty input (defaults to the first non-empty advice 2428 ;;be returned on empty input (defaults to the first non-empty advice
2411 ;;class of FUNCTION)." 2429 ;;class of FUNCTION)."
2412 (setq default 2430 (setq default
@@ -2442,7 +2460,7 @@ either t or nil, and DEFINITION should be a list of the form
2442 2460
2443(defun ad-read-advice-specification (&optional prompt) 2461(defun ad-read-advice-specification (&optional prompt)
2444 ;;"Reads a complete function/class/name specification from minibuffer. 2462 ;;"Reads a complete function/class/name specification from minibuffer.
2445 ;;The list of read symbols will be returned. The optional PROMPT will 2463 ;;The list of read symbols will be returned. The optional PROMPT will
2446 ;;be used to prompt for the function." 2464 ;;be used to prompt for the function."
2447 (let* ((function (ad-read-advised-function prompt)) 2465 (let* ((function (ad-read-advised-function prompt))
2448 (class (ad-read-advice-class function)) 2466 (class (ad-read-advice-class function))
@@ -2499,8 +2517,8 @@ If CLASS is `any' all legal advice classes will be checked."
2499 ;;"Sets enable FLAG of FUNCTION's advices in CLASS matching NAME. 2517 ;;"Sets enable FLAG of FUNCTION's advices in CLASS matching NAME.
2500 ;;If NAME is a string rather than a symbol then it's interpreted as a regular 2518 ;;If NAME is a string rather than a symbol then it's interpreted as a regular
2501 ;;expression and all advices whose name contain a match for it will be 2519 ;;expression and all advices whose name contain a match for it will be
2502 ;;affected. If CLASS is `any' advices in all legal advice classes will be 2520 ;;affected. If CLASS is `any' advices in all legal advice classes will be
2503 ;;considered. The number of changed advices will be returned (or NIL if 2521 ;;considered. The number of changed advices will be returned (or nil if
2504 ;;FUNCTION was not advised)." 2522 ;;FUNCTION was not advised)."
2505 (if (ad-is-advised function) 2523 (if (ad-is-advised function)
2506 (let ((matched-advices 0)) 2524 (let ((matched-advices 0))
@@ -2536,7 +2554,7 @@ If CLASS is `any' all legal advice classes will be checked."
2536 2554
2537(defun ad-enable-regexp-internal (regexp class flag) 2555(defun ad-enable-regexp-internal (regexp class flag)
2538 ;;"Sets enable FLAGs of all CLASS advices whose name contains a REGEXP match. 2556 ;;"Sets enable FLAGs of all CLASS advices whose name contains a REGEXP match.
2539 ;;If CLASS is `any' all legal advice classes are considered. The number of 2557 ;;If CLASS is `any' all legal advice classes are considered. The number of
2540 ;;affected advices will be returned." 2558 ;;affected advices will be returned."
2541 (let ((matched-advices 0)) 2559 (let ((matched-advices 0))
2542 (ad-do-advised-functions (advised-function) 2560 (ad-do-advised-functions (advised-function)
@@ -2586,14 +2604,14 @@ in that CLASS."
2586(defun ad-add-advice (function advice class position) 2604(defun ad-add-advice (function advice class position)
2587 "Adds a piece of ADVICE to FUNCTION's list of advices in CLASS. 2605 "Adds a piece of ADVICE to FUNCTION's list of advices in CLASS.
2588If FUNCTION already has one or more pieces of advice of the specified 2606If FUNCTION already has one or more pieces of advice of the specified
2589CLASS then POSITION determines where the new piece will go. The value 2607CLASS then POSITION determines where the new piece will go. The value
2590of POSITION can either be `first', `last' or a number where 0 corresponds 2608of POSITION can either be `first', `last' or a number where 0 corresponds
2591to `first'. Numbers outside the range will be mapped to the closest 2609to `first'. Numbers outside the range will be mapped to the closest
2592extreme position. If there was already a piece of ADVICE with the same 2610extreme position. If there was already a piece of ADVICE with the same
2593name, then the position argument will be ignored and the old advice 2611name, then the position argument will be ignored and the old advice
2594will be overwritten with the new one. 2612will be overwritten with the new one.
2595 If the FUNCTION was not advised already, then its advice info will be 2613 If the FUNCTION was not advised already, then its advice info will be
2596initialized. Redefining a piece of advice whose name is part of the cache-id 2614initialized. Redefining a piece of advice whose name is part of the cache-id
2597will clear the cache." 2615will clear the cache."
2598 (cond ((not (ad-is-advised function)) 2616 (cond ((not (ad-is-advised function))
2599 (ad-initialize-advice-info function) 2617 (ad-initialize-advice-info function)
@@ -2632,7 +2650,7 @@ will clear the cache."
2632 (` (cdr (, definition)))) 2650 (` (cdr (, definition))))
2633 2651
2634;; There is no way to determine whether some subr is a special form or not, 2652;; There is no way to determine whether some subr is a special form or not,
2635;; hence we need this list (which is the same for v18s and v19s): 2653;; hence we need this list (which is probably out of date):
2636(defvar ad-special-forms 2654(defvar ad-special-forms
2637 (mapcar 'symbol-function 2655 (mapcar 'symbol-function
2638 '(and catch cond condition-case defconst defmacro 2656 '(and catch cond condition-case defconst defmacro
@@ -2643,45 +2661,44 @@ will clear the cache."
2643 with-output-to-temp-buffer))) 2661 with-output-to-temp-buffer)))
2644 2662
2645(defmacro ad-special-form-p (definition) 2663(defmacro ad-special-form-p (definition)
2646 ;;"non-NIL if DEFINITION is a special form." 2664 ;;"non-nil if DEFINITION is a special form."
2647 (list 'memq definition 'ad-special-forms)) 2665 (list 'memq definition 'ad-special-forms))
2648 2666
2649(defmacro ad-interactive-p (definition) 2667(defmacro ad-interactive-p (definition)
2650 ;;"non-NIL if DEFINITION can be called interactively." 2668 ;;"non-nil if DEFINITION can be called interactively."
2651 (list 'commandp definition)) 2669 (list 'commandp definition))
2652 2670
2653(defmacro ad-subr-p (definition) 2671(defmacro ad-subr-p (definition)
2654 ;;"non-NIL if DEFINITION is a subr." 2672 ;;"non-nil if DEFINITION is a subr."
2655 (list 'subrp definition)) 2673 (list 'subrp definition))
2656 2674
2657(defmacro ad-macro-p (definition) 2675(defmacro ad-macro-p (definition)
2658 ;;"non-NIL if DEFINITION is a macro." 2676 ;;"non-nil if DEFINITION is a macro."
2659 (` (eq (car-safe (, definition)) 'macro))) 2677 (` (eq (car-safe (, definition)) 'macro)))
2660 2678
2661(defmacro ad-lambda-p (definition) 2679(defmacro ad-lambda-p (definition)
2662 ;;"non-NIL if DEFINITION is a lambda expression." 2680 ;;"non-nil if DEFINITION is a lambda expression."
2663 (` (eq (car-safe (, definition)) 'lambda))) 2681 (` (eq (car-safe (, definition)) 'lambda)))
2664 2682
2665;; see ad-make-advice for the format of advice definitions: 2683;; see ad-make-advice for the format of advice definitions:
2666(defmacro ad-advice-p (definition) 2684(defmacro ad-advice-p (definition)
2667 ;;"non-NIL if DEFINITION is a piece of advice." 2685 ;;"non-nil if DEFINITION is a piece of advice."
2668 (` (eq (car-safe (, definition)) 'advice))) 2686 (` (eq (car-safe (, definition)) 'advice)))
2669 2687
2670;; GNU Emacs-19/Lemacs cross-compatibility 2688;; Emacs/Lemacs cross-compatibility
2671;; (compiled-function-p is an obsolete function in GNU Emacs-19): 2689;; (compiled-function-p is an obsolete function in Emacs):
2672(if (and (not (fboundp 'byte-code-function-p)) 2690(if (and (not (fboundp 'byte-code-function-p))
2673 (fboundp 'compiled-function-p)) 2691 (fboundp 'compiled-function-p))
2674 (ad-real-fset 'byte-code-function-p 'compiled-function-p)) 2692 (ad-real-fset 'byte-code-function-p 'compiled-function-p))
2675 2693
2676(defmacro ad-v19-compiled-p (definition) 2694(defmacro ad-compiled-p (definition)
2677 ;;"non-NIL if DEFINITION is a compiled object of a v19 Emacs." 2695 ;;"non-nil if DEFINITION is a compiled byte-code object."
2678 (` (and ad-emacs19-p 2696 (` (or (byte-code-function-p (, definition))
2679 (or (byte-code-function-p (, definition)) 2697 (and (ad-macro-p (, definition))
2680 (and (ad-macro-p (, definition)) 2698 (byte-code-function-p (ad-lambdafy (, definition)))))))
2681 (byte-code-function-p (ad-lambdafy (, definition))))))))
2682 2699
2683(defmacro ad-v19-compiled-code (compiled-definition) 2700(defmacro ad-compiled-code (compiled-definition)
2684 ;;"Returns the byte-code object of a v19 COMPILED-DEFINITION." 2701 ;;"Returns the byte-code object of a COMPILED-DEFINITION."
2685 (` (if (ad-macro-p (, compiled-definition)) 2702 (` (if (ad-macro-p (, compiled-definition))
2686 (ad-lambdafy (, compiled-definition)) 2703 (ad-lambdafy (, compiled-definition))
2687 (, compiled-definition)))) 2704 (, compiled-definition))))
@@ -2700,8 +2717,8 @@ will clear the cache."
2700 ;;"Returns the argument list of DEFINITION. 2717 ;;"Returns the argument list of DEFINITION.
2701 ;;If DEFINITION could be from a subr then its NAME should be 2718 ;;If DEFINITION could be from a subr then its NAME should be
2702 ;;supplied to make subr arglist lookup more efficient." 2719 ;;supplied to make subr arglist lookup more efficient."
2703 (cond ((ad-v19-compiled-p definition) 2720 (cond ((ad-compiled-p definition)
2704 (aref (ad-v19-compiled-code definition) 0)) 2721 (aref (ad-compiled-code definition) 0))
2705 ((consp definition) 2722 ((consp definition)
2706 (car (cdr (ad-lambda-expression definition)))) 2723 (car (cdr (ad-lambda-expression definition))))
2707 ((ad-subr-p definition) 2724 ((ad-subr-p definition)
@@ -2726,28 +2743,39 @@ will clear the cache."
2726 2743
2727(defun ad-subr-arglist (subr-name) 2744(defun ad-subr-arglist (subr-name)
2728 ;;"Retrieve arglist of the subr with SUBR-NAME. 2745 ;;"Retrieve arglist of the subr with SUBR-NAME.
2729 ;;Either use the one stored under the `ad-subr-arglist' property, or, if we 2746 ;;Either use the one stored under the `ad-subr-arglist' property,
2730 ;;have a v19 Emacs try to retrieve it from the docstring and cache it under 2747 ;;or try to retrieve it from the docstring and cache it under
2731 ;;that property, or otherwise use `(&rest ad-subr-args)'." 2748 ;;that property, or otherwise use `(&rest ad-subr-args)'."
2732 (if (ad-subr-args-defined-p subr-name) 2749 (cond ((ad-subr-args-defined-p subr-name)
2733 (ad-get-subr-args subr-name) 2750 (ad-get-subr-args subr-name))
2734 (let ((doc (if ad-emacs19-p 2751 ;; says jwz: Should use this for Lemacs 19.8 and above:
2735 (documentation subr-name)))) 2752 ;;((fboundp 'subr-min-args)
2736 (cond ((and doc 2753 ;; ...)
2737 (string-match "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'" doc)) 2754 ;; says hans: I guess what Jamie means is that I should use the values
2738 (ad-define-subr-args 2755 ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist
2739 subr-name 2756 ;; without having to look it up via parsing the docstring, e.g.,
2740 (car (read-from-string doc (match-beginning 1) (match-end 1)))) 2757 ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an
2741 (ad-get-subr-args subr-name)) 2758 ;; argument list. However, that won't work because there is no
2742 (t '(&rest ad-subr-args)))))) 2759 ;; way to distinguish a subr with args `(a &optional b &rest c)' from
2760 ;; one with args `(a &rest c)' using that mechanism. Also, the argument
2761 ;; names from the docstring are more meaningful. Hence, I'll stick with
2762 ;; the old way of doing things.
2763 (t (let ((doc (ad-real-documentation subr-name t)))
2764 (cond ((and doc
2765 (string-match
2766 "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'" doc))
2767 (ad-define-subr-args
2768 subr-name
2769 (car (read-from-string
2770 doc (match-beginning 1) (match-end 1))))
2771 (ad-get-subr-args subr-name))
2772 (t '(&rest ad-subr-args)))))))
2743 2773
2744(defun ad-docstring (definition) 2774(defun ad-docstring (definition)
2745 ;;"Returns the unexpanded docstring of DEFINITION." 2775 ;;"Returns the unexpanded docstring of DEFINITION."
2746 (let ((docstring 2776 (let ((docstring
2747 (if (ad-v19-compiled-p definition) 2777 (if (ad-compiled-p definition)
2748 (condition-case nodoc 2778 (ad-real-documentation definition t)
2749 (aref (ad-v19-compiled-code definition) 4)
2750 (error nil))
2751 (car (cdr (cdr (ad-lambda-expression definition))))))) 2779 (car (cdr (cdr (ad-lambda-expression definition)))))))
2752 (if (or (stringp docstring) 2780 (if (or (stringp docstring)
2753 (natnump docstring)) 2781 (natnump docstring))
@@ -2755,34 +2783,22 @@ will clear the cache."
2755 2783
2756(defun ad-interactive-form (definition) 2784(defun ad-interactive-form (definition)
2757 ;;"Returns the interactive form of DEFINITION." 2785 ;;"Returns the interactive form of DEFINITION."
2758 (cond ((ad-v19-compiled-p definition) 2786 (cond ((ad-compiled-p definition)
2759 (and (commandp definition) 2787 (and (commandp definition)
2760 (list 'interactive (aref (ad-v19-compiled-code definition) 5)))) 2788 (list 'interactive (aref (ad-compiled-code definition) 5))))
2761 ((or (ad-advice-p definition) 2789 ((or (ad-advice-p definition)
2762 (ad-lambda-p definition)) 2790 (ad-lambda-p definition))
2763 (commandp (ad-lambda-expression definition))))) 2791 (commandp (ad-lambda-expression definition)))))
2764 2792
2765(defun ad-body-forms (definition) 2793(defun ad-body-forms (definition)
2766 ;;"Returns the list of body forms of DEFINITION." 2794 ;;"Returns the list of body forms of DEFINITION."
2767 (cond ((ad-v19-compiled-p definition) 2795 (cond ((ad-compiled-p definition)
2768 (setq definition (ad-v19-compiled-code definition)) 2796 nil)
2769 ;; build a standard (byte-code ...) form from the v19 code
2770 ;; (I don't think I ever use this):
2771 (list (list 'byte-code
2772 (aref definition 1)
2773 (aref definition 2)
2774 (aref definition 3))))
2775 ((consp definition) 2797 ((consp definition)
2776 (nthcdr (+ (if (ad-docstring definition) 1 0) 2798 (nthcdr (+ (if (ad-docstring definition) 1 0)
2777 (if (ad-interactive-form definition) 1 0)) 2799 (if (ad-interactive-form definition) 1 0))
2778 (cdr (cdr (ad-lambda-expression definition))))))) 2800 (cdr (cdr (ad-lambda-expression definition)))))))
2779 2801
2780(defun ad-compiled-p (definition)
2781 ;;"non-NIL if DEFINITION is byte-compiled."
2782 (or (ad-v19-compiled-p definition)
2783 (memq (car-safe (car (ad-body-forms definition)))
2784 '(byte-code ad-real-byte-code))))
2785
2786;; Matches the docstring of an advised definition. 2802;; Matches the docstring of an advised definition.
2787;; The first group of the regexp matches the function name: 2803;; The first group of the regexp matches the function name:
2788(defvar ad-advised-definition-docstring-regexp "^\\$ad-doc: \\(.+\\)\\$$") 2804(defvar ad-advised-definition-docstring-regexp "^\\$ad-doc: \\(.+\\)\\$$")
@@ -2790,13 +2806,13 @@ will clear the cache."
2790(defun ad-make-advised-definition-docstring (function) 2806(defun ad-make-advised-definition-docstring (function)
2791 ;; Makes an identifying docstring for the advised definition of FUNCTION. 2807 ;; Makes an identifying docstring for the advised definition of FUNCTION.
2792 ;; Put function name into the documentation string so we can infer 2808 ;; Put function name into the documentation string so we can infer
2793 ;; the name of the advised function from the docstring. This is needed 2809 ;; the name of the advised function from the docstring. This is needed
2794 ;; to generate a proper advised docstring even if we are just given a 2810 ;; to generate a proper advised docstring even if we are just given a
2795 ;; definition (also see the defadvice for `documentation'): 2811 ;; definition (also see the defadvice for `documentation'):
2796 (format "$ad-doc: %s$" (prin1-to-string function))) 2812 (format "$ad-doc: %s$" (prin1-to-string function)))
2797 2813
2798(defun ad-advised-definition-p (definition) 2814(defun ad-advised-definition-p (definition)
2799 ;;"non-NIL if DEFINITION was generated from advice information." 2815 ;;"non-nil if DEFINITION was generated from advice information."
2800 (if (or (ad-lambda-p definition) 2816 (if (or (ad-lambda-p definition)
2801 (ad-macro-p definition) 2817 (ad-macro-p definition)
2802 (ad-compiled-p definition)) 2818 (ad-compiled-p definition))
@@ -2848,34 +2864,11 @@ will clear the cache."
2848 (ad-macro-p (symbol-function function))) 2864 (ad-macro-p (symbol-function function)))
2849 (not (ad-compiled-p (symbol-function function))))) 2865 (not (ad-compiled-p (symbol-function function)))))
2850 2866
2851;; Need this because the v18 `byte-compile' can't compile macros:
2852(defun ad-compile-function (function) 2867(defun ad-compile-function (function)
2853 "Byte-compiles FUNCTION (or macro) if it is not yet compiled." 2868 "Byte-compiles FUNCTION (or macro) if it is not yet compiled."
2854 (interactive "aByte-compile function: ") 2869 (interactive "aByte-compile function: ")
2855 (if (ad-is-compilable function) 2870 (if (ad-is-compilable function)
2856 (or (progn 2871 (byte-compile function)))
2857 (require 'byte-compile "bytecomp")
2858 (byte-compile function))
2859 ;; If we get here we must have a macro and a
2860 ;; standard non-optimizing v18 byte-compiler:
2861 (and (ad-macro-p (symbol-function function))
2862 (ad-real-fset
2863 function (ad-macrofy
2864 (byte-compile-lambda
2865 (ad-lambda-expression
2866 (symbol-function function)))))))))
2867
2868(defun ad-real-byte-codify (function)
2869 ;;"Compile FUNCTION and use `ad-real-byte-code' in the compiled body.
2870 ;;This is needed when forward advice with jwz-byte-compiled files is used in
2871 ;;order to avoid infinite recursion and keep efficiency as high as possible."
2872 (ad-compile-function function)
2873 (let ((definition (symbol-function function)))
2874 (cond ((ad-v19-compiled-p definition))
2875 ((ad-compiled-p definition)
2876 ;; Use ad-real-byte-code in the body of function:
2877 (setcar (car (ad-body-forms definition))
2878 'ad-real-byte-code)))))
2879 2872
2880 2873
2881;; @@ Constructing advised definitions: 2874;; @@ Constructing advised definitions:
@@ -2890,10 +2883,10 @@ will clear the cache."
2890;; I chose to use function indirection for all four types of original 2883;; I chose to use function indirection for all four types of original
2891;; definitions (functions, macros, subrs and special forms), i.e., create 2884;; definitions (functions, macros, subrs and special forms), i.e., create
2892;; a unique symbol `ad-Orig-<name>' which is fbound to the original 2885;; a unique symbol `ad-Orig-<name>' which is fbound to the original
2893;; definition and call it according to type and arguments. Functions and 2886;; definition and call it according to type and arguments. Functions and
2894;; subrs that don't have any &rest arguments can be called directly in a 2887;; subrs that don't have any &rest arguments can be called directly in a
2895;; `(ad-Orig-<name> ....)' form. If they have a &rest argument we have to 2888;; `(ad-Orig-<name> ....)' form. If they have a &rest argument we have to
2896;; use `apply'. Macros will be called with 2889;; use `apply'. Macros will be called with
2897;; `(macroexpand '(ad-Orig-<name> ....))', and special forms also need a 2890;; `(macroexpand '(ad-Orig-<name> ....))', and special forms also need a
2898;; form like that with `eval' instead of `macroexpand'. 2891;; form like that with `eval' instead of `macroexpand'.
2899;; 2892;;
@@ -2919,7 +2912,7 @@ will clear the cache."
2919 ;;"Parses ARGLIST into its required, optional and rest parameters. 2912 ;;"Parses ARGLIST into its required, optional and rest parameters.
2920 ;;A three-element list is returned, where the 1st element is the list of 2913 ;;A three-element list is returned, where the 1st element is the list of
2921 ;;required arguments, the 2nd is the list of optional arguments, and the 3rd 2914 ;;required arguments, the 2nd is the list of optional arguments, and the 3rd
2922 ;;is the name of an optional rest parameter (or NIL)." 2915 ;;is the name of an optional rest parameter (or nil)."
2923 (let* (required optional rest) 2916 (let* (required optional rest)
2924 (setq rest (car (cdr (memq '&rest arglist)))) 2917 (setq rest (car (cdr (memq '&rest arglist))))
2925 (if rest (setq arglist (reverse (cdr (memq '&rest (reverse arglist)))))) 2918 (if rest (setq arglist (reverse (cdr (memq '&rest (reverse arglist))))))
@@ -3093,14 +3086,14 @@ will clear the cache."
3093;; The mapping should work for any two argument lists. 3086;; The mapping should work for any two argument lists.
3094 3087
3095(defun ad-map-arglists (source-arglist target-arglist) 3088(defun ad-map-arglists (source-arglist target-arglist)
3096 "Makes funcall/apply form to map SOURCE-ARGLIST to TARGET-ARGLIST. 3089 "Makes `funcall/apply' form to map SOURCE-ARGLIST to TARGET-ARGLIST.
3097The arguments supplied to TARGET-ARGLIST will be taken from SOURCE-ARGLIST just 3090The arguments supplied to TARGET-ARGLIST will be taken from SOURCE-ARGLIST just
3098as if they had been supplied to a function with TARGET-ARGLIST directly. 3091as if they had been supplied to a function with TARGET-ARGLIST directly.
3099Excess source arguments will be neglected, missing source arguments will be 3092Excess source arguments will be neglected, missing source arguments will be
3100supplied as NIL. Returns a funcall or apply form with the second element being 3093supplied as nil. Returns a `funcall' or `apply' form with the second element
3101`function' which has to be replaced by an actual function argument. 3094being `function' which has to be replaced by an actual function argument.
3102Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return 3095Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return
3103 (funcall function a (car args) (car (cdr args)) (nth 2 args))" 3096 `(funcall function a (car args) (car (cdr args)) (nth 2 args))'."
3104 (let* ((parsed-source-arglist (ad-parse-arglist source-arglist)) 3097 (let* ((parsed-source-arglist (ad-parse-arglist source-arglist))
3105 (source-reqopt-args (append (nth 0 parsed-source-arglist) 3098 (source-reqopt-args (append (nth 0 parsed-source-arglist)
3106 (nth 1 parsed-source-arglist))) 3099 (nth 1 parsed-source-arglist)))
@@ -3141,7 +3134,7 @@ Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return
3141;; @@@ Making an advised documentation string: 3134;; @@@ Making an advised documentation string:
3142;; =========================================== 3135;; ===========================================
3143;; New policy: The documentation string for an advised function will be built 3136;; New policy: The documentation string for an advised function will be built
3144;; at the time the advised `documentation' function is called. This has the 3137;; at the time the advised `documentation' function is called. This has the
3145;; following advantages: 3138;; following advantages:
3146;; 1) command-key substitutions will automatically be correct 3139;; 1) command-key substitutions will automatically be correct
3147;; 2) No wasted string space due to big advised docstrings in caches or 3140;; 2) No wasted string space due to big advised docstrings in caches or
@@ -3149,48 +3142,52 @@ Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return
3149;; The overall overhead for this should be negligible because people normally 3142;; The overall overhead for this should be negligible because people normally
3150;; don't lookup documentation for the same function over and over again. 3143;; don't lookup documentation for the same function over and over again.
3151 3144
3152(defun ad-make-single-advice-docstring (advice class) 3145(defun ad-make-single-advice-docstring (advice class &optional style)
3153 (let ((advice-docstring (ad-docstring (ad-advice-definition advice)))) 3146 (let ((advice-docstring (ad-docstring (ad-advice-definition advice))))
3154 ;; Always show advice name/class even if there is no docstring: 3147 (cond ((eq style 'plain)
3155 (format "%s (%s):%s%s" 3148 advice-docstring)
3156 (ad-advice-name advice) class 3149 ((eq style 'freeze)
3157 (if advice-docstring "\n" "") 3150 (format "Permanent %s-advice `%s':%s%s"
3158 (or advice-docstring "")))) 3151 class (ad-advice-name advice)
3159 3152 (if advice-docstring "\n" "")
3160(defun ad-make-advised-docstring (function) 3153 (or advice-docstring "")))
3154 (t (format "%s-advice `%s':%s%s"
3155 (capitalize (symbol-name class)) (ad-advice-name advice)
3156 (if advice-docstring "\n" "")
3157 (or advice-docstring ""))))))
3158
3159(defun ad-make-advised-docstring (function &optional style)
3161 ;;"Constructs a documentation string for the advised FUNCTION. 3160 ;;"Constructs a documentation string for the advised FUNCTION.
3162 ;;It concatenates the original documentation with the documentation 3161 ;;It concatenates the original documentation with the documentation
3163 ;;strings of the individual pieces of advice. Name and class of every 3162 ;;strings of the individual pieces of advice which will be formatted
3164 ;;advice will be displayed too. The order of the advice documentation 3163 ;;according to STYLE. STYLE can be `plain' or `freeze', everything else
3164 ;;will be interpreted as `default'. The order of the advice documentation
3165 ;;strings corresponds to before/around/after and the individual ordering 3165 ;;strings corresponds to before/around/after and the individual ordering
3166 ;;in any of these classes." 3166 ;;in any of these classes."
3167 (let* ((origdef (ad-real-orig-definition function)) 3167 (let* ((origdef (ad-real-orig-definition function))
3168 (origtype (symbol-name (ad-definition-type origdef)))
3168 (origdoc 3169 (origdoc
3169 ;; Use this wacky apply construction to avoid an Lemacs compiler 3170 ;; Retrieve raw doc, key substitution will be taken care of later:
3170 ;; warning (its `documentation' has only 1 arg as opposed to GNU 3171 (ad-real-documentation origdef t))
3171 ;; Emacs-19's version which has an optional `raw' arg): 3172 paragraphs advice-docstring)
3172 (apply 'documentation 3173 (if origdoc (setq paragraphs (list origdoc)))
3173 origdef 3174 (if (not (eq style 'plain))
3174 (if (and ad-emacs19-p (not ad-lemacs-p)) 3175 (setq paragraphs (cons (concat "This " origtype " is advised.")
3175 ;; If we have GNU Emacs-19 retrieve raw doc, because 3176 paragraphs)))
3176 ;; key substitution will be taken care of later anyway: 3177 (ad-dolist (class ad-advice-classes)
3177 '(t))))) 3178 (ad-dolist (advice (ad-get-enabled-advices function class))
3178 (concat (or origdoc "") 3179 (setq advice-docstring
3179 (if origdoc "\n\n" "\n") 3180 (ad-make-single-advice-docstring advice class style))
3180 ;; Always inform about advice even if there is no origdoc: 3181 (if advice-docstring
3181 "This " (symbol-name (ad-definition-type origdef)) 3182 (setq paragraphs (cons advice-docstring paragraphs)))))
3182 " is advised with the following advice(s):" 3183 (if paragraphs
3183 ;; Combine advice docstrings: 3184 ;; separate paragraphs with blank lines:
3184 (mapconcat 3185 (mapconcat 'identity (nreverse paragraphs) "\n\n"))))
3185 (function 3186
3186 (lambda (class) 3187(defun ad-make-plain-docstring (function)
3187 (mapconcat 3188 (ad-make-advised-docstring function 'plain))
3188 (function 3189(defun ad-make-freeze-docstring (function)
3189 (lambda (advice) 3190 (ad-make-advised-docstring function 'freeze))
3190 (concat
3191 "\n\n" (ad-make-single-advice-docstring advice class))))
3192 (ad-get-enabled-advices function class) "")))
3193 ad-advice-classes ""))))
3194 3191
3195;; @@@ Accessing overriding arglists and interactive forms: 3192;; @@@ Accessing overriding arglists and interactive forms:
3196;; ======================================================== 3193;; ========================================================
@@ -3300,12 +3297,12 @@ Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return
3300 3297
3301 ;;"Assembles an original and its advices into an advised function. 3298 ;;"Assembles an original and its advices into an advised function.
3302 ;;It constructs a function or macro definition according to TYPE which has to 3299 ;;It constructs a function or macro definition according to TYPE which has to
3303 ;;be either `macro', `function' or `special-form'. ARGS is the argument list 3300 ;;be either `macro', `function' or `special-form'. ARGS is the argument list
3304 ;;that has to be used, DOCSTRING if non-NIL defines the documentation of the 3301 ;;that has to be used, DOCSTRING if non-nil defines the documentation of the
3305 ;;definition, INTERACTIVE if non-NIL is the interactive form to be used, 3302 ;;definition, INTERACTIVE if non-nil is the interactive form to be used,
3306 ;;ORIG is a form that calls the body of the original unadvised function, 3303 ;;ORIG is a form that calls the body of the original unadvised function,
3307 ;;and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG 3304 ;;and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG
3308 ;;should be modified. The assembled function will be returned." 3305 ;;should be modified. The assembled function will be returned."
3309 3306
3310 (let (before-forms around-form around-form-protected after-forms definition) 3307 (let (before-forms around-form around-form-protected after-forms definition)
3311 (ad-dolist (advice befores) 3308 (ad-dolist (advice befores)
@@ -3383,7 +3380,7 @@ Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return
3383;; definition if the current advice and function definition state is the 3380;; definition if the current advice and function definition state is the
3384;; same as it was at the time when the cached definition was generated. 3381;; same as it was at the time when the cached definition was generated.
3385;; For that purpose we associate every cache with an id so we can verify 3382;; For that purpose we associate every cache with an id so we can verify
3386;; if it is still valid at a certain point in time. This id mechanism 3383;; if it is still valid at a certain point in time. This id mechanism
3387;; makes it possible to preactivate advised functions, write the compiled 3384;; makes it possible to preactivate advised functions, write the compiled
3388;; advised definitions to a file and reuse them during the actual 3385;; advised definitions to a file and reuse them during the actual
3389;; activation without having to risk that the resulting definition will be 3386;; activation without having to risk that the resulting definition will be
@@ -3410,7 +3407,7 @@ Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return
3410;; F) a piece of advice used in the cache got redefined before the 3407;; F) a piece of advice used in the cache got redefined before the
3411;; defadvice with the cached definition got loaded: This is a PROBLEM! 3408;; defadvice with the cached definition got loaded: This is a PROBLEM!
3412;; 3409;;
3413;; Cases A and B are the normal ones. A is taken care of by `ad-add-advice' 3410;; Cases A and B are the normal ones. A is taken care of by `ad-add-advice'
3414;; which clears the cache in such a case, B is easily checked during 3411;; which clears the cache in such a case, B is easily checked during
3415;; verification at activation time. 3412;; verification at activation time.
3416;; 3413;;
@@ -3418,8 +3415,8 @@ Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return
3418;; if one considers the case that the original function could be different 3415;; if one considers the case that the original function could be different
3419;; from the one available at caching time (e.g., for forward advice of 3416;; from the one available at caching time (e.g., for forward advice of
3420;; functions that get redefined by some packages - such as `eval-region' gets 3417;; functions that get redefined by some packages - such as `eval-region' gets
3421;; redefined by edebug). All these cases can be easily checked during 3418;; redefined by edebug). All these cases can be easily checked during
3422;; verification. Element 4 of the id lets one check case C, element 5 takes 3419;; verification. Element 4 of the id lets one check case C, element 5 takes
3423;; care of case D (using t in the equality case saves some space, because the 3420;; care of case D (using t in the equality case saves some space, because the
3424;; arglist can be recovered at validation time from the cached definition), 3421;; arglist can be recovered at validation time from the cached definition),
3425;; and element 6 takes care of case E which is only a problem if the original 3422;; and element 6 takes care of case E which is only a problem if the original
@@ -3432,7 +3429,7 @@ Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return
3432;; 3429;;
3433;; The cache-id of a typical advised function with one piece of advice and 3430;; The cache-id of a typical advised function with one piece of advice and
3434;; no arglist redefinition takes 7 conses which is a small price to pay for 3431;; no arglist redefinition takes 7 conses which is a small price to pay for
3435;; the added efficiency. The validation itself is also pretty cheap, certainly 3432;; the added efficiency. The validation itself is also pretty cheap, certainly
3436;; a lot cheaper than reconstructing an advised definition. 3433;; a lot cheaper than reconstructing an advised definition.
3437 3434
3438(defmacro ad-get-cache-definition (function) 3435(defmacro ad-get-cache-definition (function)
@@ -3490,9 +3487,9 @@ advised definition from scratch."
3490 3487
3491;; There should be a way to monitor if and why a cache verification failed 3488;; There should be a way to monitor if and why a cache verification failed
3492;; in order to determine whether a certain preactivation could be used or 3489;; in order to determine whether a certain preactivation could be used or
3493;; not. Right now the only way to find out is to trace 3490;; not. Right now the only way to find out is to trace
3494;; `ad-cache-id-verification-code'. The code it returns indicates where the 3491;; `ad-cache-id-verification-code'. The code it returns indicates where the
3495;; verification failed. Tracing `ad-verify-cache-class-id' might provide 3492;; verification failed. Tracing `ad-verify-cache-class-id' might provide
3496;; some additional useful information. 3493;; some additional useful information.
3497 3494
3498(defun ad-cache-id-verification-code (function) 3495(defun ad-cache-id-verification-code (function)
@@ -3531,7 +3528,7 @@ advised definition from scratch."
3531;; ================= 3528;; =================
3532;; Preactivation can be used to generate compiled advised definitions 3529;; Preactivation can be used to generate compiled advised definitions
3533;; at compile time without having to give up the dynamic runtime flexibility 3530;; at compile time without having to give up the dynamic runtime flexibility
3534;; of the advice mechanism. Preactivation is a special feature of `defadvice', 3531;; of the advice mechanism. Preactivation is a special feature of `defadvice',
3535;; it involves the following steps: 3532;; it involves the following steps:
3536;; - remembering the function's current state (definition and advice-info) 3533;; - remembering the function's current state (definition and advice-info)
3537;; - advising it with the defined piece of advice 3534;; - advising it with the defined piece of advice
@@ -3543,11 +3540,10 @@ advised definition from scratch."
3543;; before the preactivation 3540;; before the preactivation
3544;; - Returning the saved definition and its id to be used in the expansion of 3541;; - Returning the saved definition and its id to be used in the expansion of
3545;; `defadvice' to assign it as an initial cache, hence it will be compiled 3542;; `defadvice' to assign it as an initial cache, hence it will be compiled
3546;; at time the `defadvice' gets compiled (for v18 byte-compilers the 3543;; at time the `defadvice' gets compiled.
3547;; `defadvice' needs to be in the body of a `defun' for that to occur).
3548;; Naturally, for preactivation to be effective it has to be applied/compiled 3544;; Naturally, for preactivation to be effective it has to be applied/compiled
3549;; at the right time, i.e., when the current state of advices and function 3545;; at the right time, i.e., when the current state of advices and function
3550;; definition exactly reflects the state at activation time. Should that not 3546;; definition exactly reflects the state at activation time. Should that not
3551;; be the case, the precompiled definition will just be discarded and a new 3547;; be the case, the precompiled definition will just be discarded and a new
3552;; advised definition will be generated. 3548;; advised definition will be generated.
3553 3549
@@ -3577,7 +3573,7 @@ advised definition from scratch."
3577 3573
3578(defun ad-activate-advised-definition (function compile) 3574(defun ad-activate-advised-definition (function compile)
3579 ;;"Redefines FUNCTION with its advised definition from cache or scratch. 3575 ;;"Redefines FUNCTION with its advised definition from cache or scratch.
3580 ;;If COMPILE is true the resulting FUNCTION will be compiled. The current 3576 ;;If COMPILE is true the resulting FUNCTION will be compiled. The current
3581 ;;definition and its cache-id will be put into the cache." 3577 ;;definition and its cache-id will be put into the cache."
3582 (let ((verified-cached-definition 3578 (let ((verified-cached-definition
3583 (if (ad-verify-cache-id function) 3579 (if (ad-verify-cache-id function)
@@ -3602,12 +3598,12 @@ advised definition from scratch."
3602 "Handles re/definition of an advised FUNCTION during de/activation. 3598 "Handles re/definition of an advised FUNCTION during de/activation.
3603If FUNCTION does not have an original definition associated with it and 3599If FUNCTION does not have an original definition associated with it and
3604the current definition is usable, then it will be stored as FUNCTION's 3600the current definition is usable, then it will be stored as FUNCTION's
3605original definition. If no current definition is available (even in the 3601original definition. If no current definition is available (even in the
3606case of undefinition) nothing will be done. In the case of redefinition 3602case of undefinition) nothing will be done. In the case of redefinition
3607the action taken depends on the value of `ad-redefinition-action' (which 3603the action taken depends on the value of `ad-redefinition-action' (which
3608see). Redefinition occurs when FUNCTION already has an original definition 3604see). Redefinition occurs when FUNCTION already has an original definition
3609associated with it but got redefined with a new definition and then 3605associated with it but got redefined with a new definition and then
3610de/activated. If you do not like the current redefinition action change 3606de/activated. If you do not like the current redefinition action change
3611the value of `ad-redefinition-action' and de/activate again." 3607the value of `ad-redefinition-action' and de/activate again."
3612 (let ((original-definition (ad-get-orig-definition function)) 3608 (let ((original-definition (ad-get-orig-definition function))
3613 (current-definition (if (ad-real-definition function) 3609 (current-definition (if (ad-real-definition function)
@@ -3646,14 +3642,14 @@ the value of `ad-redefinition-action' and de/activate again."
3646 "Activates all the advice information of an advised FUNCTION. 3642 "Activates all the advice information of an advised FUNCTION.
3647If FUNCTION has a proper original definition then an advised 3643If FUNCTION has a proper original definition then an advised
3648definition will be generated from FUNCTION's advice info and the 3644definition will be generated from FUNCTION's advice info and the
3649definition of FUNCTION will be replaced with it. If a previously 3645definition of FUNCTION will be replaced with it. If a previously
3650cached advised definition was available, it will be used. With an 3646cached advised definition was available, it will be used. With an
3651argument (compile is non-NIL) the resulting function (or a compilable 3647argument (COMPILE is non-nil) the resulting function (or a compilable
3652cached definition) will also be compiled. Activation of an advised 3648cached definition) will also be compiled. Activation of an advised
3653function that has an advice info but no actual pieces of advice is 3649function that has an advice info but no actual pieces of advice is
3654equivalent to a call to `ad-unadvise'. Activation of an advised 3650equivalent to a call to `ad-unadvise'. Activation of an advised
3655function that has actual pieces of advice but none of them are enabled 3651function that has actual pieces of advice but none of them are enabled
3656is equivalent to a call to `ad-deactivate'. The current advised 3652is equivalent to a call to `ad-deactivate'. The current advised
3657definition will always be cached for later usage." 3653definition will always be cached for later usage."
3658 (interactive 3654 (interactive
3659 (list (ad-read-advised-function "Activate advice of: ") 3655 (list (ad-read-advised-function "Activate advice of: ")
@@ -3677,7 +3673,7 @@ definition will always be cached for later usage."
3677(defun ad-deactivate (function) 3673(defun ad-deactivate (function)
3678 "Deactivates the advice of an actively advised FUNCTION. 3674 "Deactivates the advice of an actively advised FUNCTION.
3679If FUNCTION has a proper original definition, then the current 3675If FUNCTION has a proper original definition, then the current
3680definition of FUNCTION will be replaced with it. All the advice 3676definition of FUNCTION will be replaced with it. All the advice
3681information will still be available so it can be activated again with 3677information will still be available so it can be activated again with
3682a call to `ad-activate'." 3678a call to `ad-activate'."
3683 (interactive 3679 (interactive
@@ -3789,62 +3785,70 @@ With prefix argument compiles resulting advised definitions."
3789 (ad-unadvise function))) 3785 (ad-unadvise function)))
3790 3786
3791(defun ad-recover-all () 3787(defun ad-recover-all ()
3792 "Recovers all currently advised functions. Use in emergencies." 3788 "Recovers all currently advised functions. Use in emergencies."
3793 (interactive) 3789 (interactive)
3794 (ad-do-advised-functions (function) 3790 (ad-do-advised-functions (function)
3795 (condition-case ignore-errors 3791 (condition-case nil
3796 (ad-recover function) 3792 (ad-recover function)
3797 (error nil)))) 3793 (error nil))))
3798 3794
3799 3795
3800;; Completion alist of legal `defadvice' flags 3796;; Completion alist of legal `defadvice' flags
3801(defvar ad-defadvice-flags 3797(defvar ad-defadvice-flags
3802 '(("protect") ("disable") ("activate") ("compile") ("preactivate"))) 3798 '(("protect") ("disable") ("activate")
3799 ("compile") ("preactivate") ("freeze")))
3803 3800
3804;;;###autoload 3801;;;###autoload
3805(defmacro defadvice (function args &rest body) 3802(defmacro defadvice (function args &rest body)
3806 "Defines a piece of advice for FUNCTION (a symbol). 3803 "Defines a piece of advice for FUNCTION (a symbol).
3807 3804The syntax of `defadvice' is as follows:
3808 (defadvice <function> (<class> <name> [<position>] [<arglist>] {<flags>}*) 3805
3809 [ [<documentation-string>] [<interactive-form>] ] 3806 (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
3810 {<body-form>}* ) 3807 [DOCSTRING] [INTERACTIVE-FORM]
3811 3808 BODY... )
3812<function> ::= name of the function to be advised 3809
3813<class> ::= before | around | after | activation | deactivation 3810FUNCTION ::= Name of the function to be advised.
3814<name> ::= non-NIL symbol that names this piece of advice 3811CLASS ::= `before' | `around' | `after' | `activation' | `deactivation'.
3815<position> ::= first | last | <number> (optional, defaults to `first', 3812NAME ::= Non-nil symbol that names this piece of advice.
3816 see also `ad-add-advice') 3813POSITION ::= `first' | `last' | NUMBER. Optional, defaults to `first',
3817<arglist> ::= an optional argument list to be used for the advised function 3814 see also `ad-add-advice'.
3818 instead of the argument list of the original. The first one found in 3815ARGLIST ::= An optional argument list to be used for the advised function
3819 before/around/after advices will be used. 3816 instead of the argument list of the original. The first one found in
3820<flags> ::= protect | disable | activate | compile | preactivate 3817 before/around/after-advices will be used.
3818FLAG ::= `protect'|`disable'|`activate'|`compile'|`preactivate'|`freeze'.
3821 All flags can be specified with unambiguous initial substrings. 3819 All flags can be specified with unambiguous initial substrings.
3822<documentation-string> ::= optional documentation for this piece of advice 3820DOCSTRING ::= Optional documentation for this piece of advice.
3823<interactive-form> ::= optional interactive form to be used for the advised 3821INTERACTIVE-FORM ::= Optional interactive form to be used for the advised
3824 function. The first one found in before/around/after advices will be used. 3822 function. The first one found in before/around/after-advices will be used.
3825<body-form> ::= any s-expression 3823BODY ::= Any s-expression.
3826 3824
3827Semantics of the various flags: 3825Semantics of the various flags:
3828`protect': The piece of advice will be protected against non-local exits in 3826`protect': The piece of advice will be protected against non-local exits in
3829any code that precedes it. If any around advice of a function is protected 3827any code that precedes it. If any around-advice of a function is protected
3830then automatically all around advices will be protected (the complete onion). 3828then automatically all around-advices will be protected (the complete onion).
3831 3829
3832`activate': All advice of FUNCTION will be activated immediately if 3830`activate': All advice of FUNCTION will be activated immediately if
3833FUNCTION has been properly defined prior to the defadvice. 3831FUNCTION has been properly defined prior to this application of `defadvice'.
3834 3832
3835`compile': In conjunction with `activate' specifies that the resulting 3833`compile': In conjunction with `activate' specifies that the resulting
3836advised function should be compiled. 3834advised function should be compiled.
3837 3835
3838`disable': The defined advice will be disabled, hence it will not be used 3836`disable': The defined advice will be disabled, hence, it will not be used
3839during activation until somebody enables it. 3837during activation until somebody enables it.
3840 3838
3841`preactivate': Preactivates the advised FUNCTION at macro expansion/compile 3839`preactivate': Preactivates the advised FUNCTION at macro-expansion/compile
3842time. This generates a compiled advised definition according to the current 3840time. This generates a compiled advised definition according to the current
3843advice state that will be used during activation if appropriate. Only use 3841advice state that will be used during activation if appropriate. Only use
3844this if the defadvice gets actually compiled (with a v18 byte-compiler put 3842this if the `defadvice' gets actually compiled.
3845the defadvice into the body of a defun).
3846 3843
3847Look at the file advice.el for comprehensive documentation." 3844`freeze': Expands the `defadvice' into a redefining `defun/defmacro' according
3845to the current advice state. No other advice information will be saved.
3846Frozen advices cannot be undone, they behave like a hard redefinition of
3847the advised function. `freeze' implies `activate' and `preactivate'. The
3848documentation of the advised function can be dumped onto the `DOC' file
3849during preloading.
3850
3851Look at the file `advice.el' for comprehensive documentation."
3848 (if (not (ad-name-p function)) 3852 (if (not (ad-name-p function))
3849 (error "defadvice: Illegal function name: %s" function)) 3853 (error "defadvice: Illegal function name: %s" function))
3850 (let* ((class (car args)) 3854 (let* ((class (car args))
@@ -3878,26 +3882,59 @@ Look at the file advice.el for comprehensive documentation."
3878 (` (advice lambda (, arglist) (,@ body))))) 3882 (` (advice lambda (, arglist) (,@ body)))))
3879 (preactivation (if (memq 'preactivate flags) 3883 (preactivation (if (memq 'preactivate flags)
3880 (ad-preactivate-advice 3884 (ad-preactivate-advice
3881 function advice class position)))) 3885 function advice class position)))
3886 unique-origname
3887 (redefinition
3888 (if (memq 'freeze flags)
3889 (ad-with-originals (ad-make-advised-definition-docstring
3890 ad-make-origname)
3891 ;; Make sure we construct the actual docstring:
3892 (fset 'ad-make-advised-definition-docstring
3893 'ad-make-freeze-docstring)
3894 ;; With a unique origname we can have multiple freeze advices
3895 ;; for the same function, each overloading the previous one:
3896 (setq unique-origname
3897 (intern (format "%s-%s-%s"
3898 (ad-make-origname function) class name)))
3899 (fset 'ad-make-origname '(lambda (x) unique-origname))
3900 (if (not (ad-has-proper-definition function))
3901 (error
3902 "defadvice: `freeze' needs proper definition of `%s'"
3903 function))
3904 (ad-preactivate-advice function advice class position)))))
3882 ;; Now for the things to be done at evaluation time: 3905 ;; Now for the things to be done at evaluation time:
3883 (` (progn 3906 (if redefinition
3884 (ad-add-advice '(, function) '(, advice) '(, class) '(, position)) 3907 ;; jwz's idea: Freeze the advised definition into a dumpable
3885 (,@ (if preactivation 3908 ;; defun/defmacro whose docs can be written to the DOC file:
3886 (` ((ad-set-cache 3909 (let* ((macro-p (ad-macro-p (car redefinition)))
3887 '(, function) 3910 (body (cdr (if macro-p
3888 ;; the function will get compiled: 3911 (ad-lambdafy (car redefinition))
3889 (, (cond ((ad-macro-p (car preactivation)) 3912 (car redefinition)))))
3890 (` (ad-macrofy 3913 (` (progn
3891 (function 3914 (if (not (fboundp '(, unique-origname)))
3892 (, (ad-lambdafy 3915 (fset '(, unique-origname) (symbol-function '(, function))))
3893 (car preactivation))))))) 3916 ((, (if macro-p 'defmacro 'defun))
3894 (t (` (function 3917 (, function)
3895 (, (car preactivation))))))) 3918 (,@ body)))))
3896 '(, (car (cdr preactivation)))))))) 3919 ;; the normal case:
3897 (,@ (if (memq 'activate flags) 3920 (` (progn
3898 (` ((ad-activate '(, function) 3921 (ad-add-advice '(, function) '(, advice) '(, class) '(, position))
3899 (, (if (memq 'compile flags) t))))))) 3922 (,@ (if preactivation
3900 '(, function))))) 3923 (` ((ad-set-cache
3924 '(, function)
3925 ;; the function will get compiled:
3926 (, (cond ((ad-macro-p (car preactivation))
3927 (` (ad-macrofy
3928 (function
3929 (, (ad-lambdafy
3930 (car preactivation)))))))
3931 (t (` (function
3932 (, (car preactivation)))))))
3933 '(, (car (cdr preactivation))))))))
3934 (,@ (if (memq 'activate flags)
3935 (` ((ad-activate '(, function)
3936 (, (if (memq 'compile flags) t)))))))
3937 '(, function))))))
3901 3938
3902 3939
3903;; @@ Tools: 3940;; @@ Tools:
@@ -3906,7 +3943,7 @@ Look at the file advice.el for comprehensive documentation."
3906(defmacro ad-with-originals (functions &rest body) 3943(defmacro ad-with-originals (functions &rest body)
3907 "Binds FUNCTIONS to their original definitions and executes BODY. 3944 "Binds FUNCTIONS to their original definitions and executes BODY.
3908For any members of FUNCTIONS that are not currently advised the rebinding will 3945For any members of FUNCTIONS that are not currently advised the rebinding will
3909be a noop. Any modifications done to the definitions of FUNCTIONS will be 3946be a noop. Any modifications done to the definitions of FUNCTIONS will be
3910undone on exit of this macro." 3947undone on exit of this macro."
3911 (let* ((index -1) 3948 (let* ((index -1)
3912 ;; Make let-variables to store current definitions: 3949 ;; Make let-variables to store current definitions:
@@ -3964,7 +4001,7 @@ undone on exit of this macro."
3964(defun ad-activate-defined-function (&optional function) 4001(defun ad-activate-defined-function (&optional function)
3965 "Activates the advice of an advised and defined FUNCTION. 4002 "Activates the advice of an advised and defined FUNCTION.
3966If the current definition of FUNCTION is byte-compiled then the advised 4003If the current definition of FUNCTION is byte-compiled then the advised
3967definition will be compiled too. FUNCTION defaults to the value of 4004definition will be compiled too. FUNCTION defaults to the value of
3968`ad-defined-function'." 4005`ad-defined-function'."
3969 (if (and (null function) 4006 (if (and (null function)
3970 ad-defined-function) 4007 ad-defined-function)
@@ -3973,15 +4010,10 @@ definition will be compiled too. FUNCTION defaults to the value of
3973 (ad-real-definition function)) 4010 (ad-real-definition function))
3974 (ad-activate function (ad-compiled-p (symbol-function function))))) 4011 (ad-activate function (ad-compiled-p (symbol-function function)))))
3975 4012
3976;; Define some subr arglists for the benefit of v18. Do this here because 4013(defvar ad-advised-definers
3977;; they have to be available at compile/preactivation time. Use the same 4014 '(defun defmacro fset defalias define-function))
3978;; as defined in Lemacs' DOC file: 4015(defvar ad-advised-byte-compilers
3979(cond ((not ad-emacs19-p) 4016 '(byte-compile-from-buffer byte-compile-top-level))
3980 (ad-define-subr-args 'documentation '(fun1))
3981 (ad-define-subr-args 'fset '(sym newdef))))
3982
3983;; A kludge to get `defadvice's compiled with a v18 compiler:
3984(defun ad-execute-defadvices ()
3985 4017
3986(defadvice defun (after ad-definition-hooks first disable preact) 4018(defadvice defun (after ad-definition-hooks first disable preact)
3987 "Whenever a function gets re/defined with `defun' all hook functions 4019 "Whenever a function gets re/defined with `defun' all hook functions
@@ -4000,7 +4032,7 @@ in `ad-definition-hooks' will be run after the re/definition with
4000(defadvice fset (after ad-definition-hooks first disable preact) 4032(defadvice fset (after ad-definition-hooks first disable preact)
4001 "Whenever a function gets re/defined with `fset' all hook functions 4033 "Whenever a function gets re/defined with `fset' all hook functions
4002in `ad-definition-hooks' will be run after the re/definition with 4034in `ad-definition-hooks' will be run after the re/definition with
4003`ad-defined-function' bound to the name of the function. This advice was 4035`ad-defined-function' bound to the name of the function. This advice was
4004mainly created to handle forward-advice for byte-compiled files created 4036mainly created to handle forward-advice for byte-compiled files created
4005by jwz's byte-compiler used in Lemacs. 4037by jwz's byte-compiler used in Lemacs.
4006CAUTION: If you need the primitive `fset' behavior either deactivate 4038CAUTION: If you need the primitive `fset' behavior either deactivate
@@ -4008,24 +4040,22 @@ CAUTION: If you need the primitive `fset' behavior either deactivate
4008 (let ((ad-defined-function (ad-get-arg 0))) 4040 (let ((ad-defined-function (ad-get-arg 0)))
4009 (run-hooks 'ad-definition-hooks))) 4041 (run-hooks 'ad-definition-hooks)))
4010 4042
4011;; Needed for GNU Emacs-19 (in v18s and Lemacs this is just a noop): 4043;; In Lemacs this is just a noop:
4012(defadvice defalias (after ad-definition-hooks first disable preact) 4044(defadvice defalias (after ad-definition-hooks first disable preact)
4013 "Whenever a function gets re/defined with `defalias' all hook functions 4045 "Whenever a function gets re/defined with `defalias' all hook functions
4014in `ad-definition-hooks' will be run after the re/definition with 4046in `ad-definition-hooks' will be run after the re/definition with
4015`ad-defined-function' bound to the name of the function. This advice was 4047`ad-defined-function' bound to the name of the function."
4016mainly created to handle forward-advice for byte-compiled files created
4017by jwz's byte-compiler used in GNU Emacs-19."
4018 (let ((ad-defined-function (ad-get-arg 0))) 4048 (let ((ad-defined-function (ad-get-arg 0)))
4019 ;; The new `byte-compile' uses `defalias' to set the definition which 4049 ;; The new `byte-compile' uses `defalias' to set the definition which
4020 ;; leads to infinite recursion if it gets to use the advised version 4050 ;; leads to infinite recursion if it gets to use the advised version
4021 ;; (with `fset' this didn't matter because the compiled `byte-compile' 4051 ;; (with `fset' this didn't matter because the compiled `byte-compile'
4022 ;; called it via its byte-code). Should there be a general provision to 4052 ;; called it via its byte-code). Should there be a general provision to
4023 ;; avoid recursive application of definition hooks? 4053 ;; avoid recursive application of definition hooks?
4024 (ad-with-originals (defalias) 4054 (ad-with-originals (defalias)
4025 (run-hooks 'ad-definition-hooks)))) 4055 (run-hooks 'ad-definition-hooks))))
4026 4056
4027;; Needed for GNU Emacs-19 (seems to be an identical copy of `defalias', 4057;; Needed for Emacs (seems to be an identical copy of `defalias', but
4028;; it is used by simple.el and might be used later, hence, advise it): 4058;; it is used in `simple.el' and might be used later, hence, advise it):
4029(defadvice define-function (after ad-definition-hooks first disable preact) 4059(defadvice define-function (after ad-definition-hooks first disable preact)
4030 "Whenever a function gets re/defined with `define-function' all hook 4060 "Whenever a function gets re/defined with `define-function' all hook
4031functions in `ad-definition-hooks' will be run after the re/definition with 4061functions in `ad-definition-hooks' will be run after the re/definition with
@@ -4046,24 +4076,44 @@ functions in `ad-definition-hooks' will be run after the re/definition with
4046 ad-return-value (match-beginning 1) (match-end 1))))) 4076 ad-return-value (match-beginning 1) (match-end 1)))))
4047 (cond ((ad-is-advised function) 4077 (cond ((ad-is-advised function)
4048 (setq ad-return-value (ad-make-advised-docstring function)) 4078 (setq ad-return-value (ad-make-advised-docstring function))
4049 ;; Handle GNU Emacs-19's optional `raw' argument: 4079 ;; Handle optional `raw' argument:
4050 (if (not (ad-get-arg 1)) 4080 (if (not (ad-get-arg 1))
4051 (setq ad-return-value 4081 (setq ad-return-value
4052 (substitute-command-keys ad-return-value)))))))) 4082 (substitute-command-keys ad-return-value))))))))
4053 4083
4054;; Make sure advice-infos are not allocated in pure space (right now they 4084;; The following two advised functions are a (hopefully temporary) kludge
4055;; are constants that are part of `ad-execute-defadvices's definition): 4085;; to fix a problem with the compilation of embedded (or non-top-level)
4056(ad-dolist (advised-function '(defun defmacro fset defalias 4086;; `defun/defmacro's when automatic activation of advice is enabled. For
4057 define-function documentation)) 4087;; the time of the compilation they backdefine `defun/defmacro' to their
4088;; original definition to make sure they are not treated as plain macros.
4089;; Both advices are forward advices, hence, they will only be activated if
4090;; automatic advice activation is enabled, but since that is the actual
4091;; situation where we have a problem, we can be sure that the advices will
4092;; be active when we need it.
4093
4094(defadvice byte-compile-from-buffer (around ad-deactivate-defun-defmacro
4095 first disable preact)
4096 "Deactivates `defun/defmacro' for proper compilation when they are embedded."
4097 (let (;; make sure no `require' starts them again by accident:
4098 (ad-advised-definers '(fset defalias define-function)))
4099 (ad-with-originals (defun defmacro)
4100 ad-do-it)))
4101
4102(defadvice byte-compile-top-level (around ad-deactivate-defun-defmacro
4103 first disable preact)
4104 "Deactivates `defun/defmacro' for proper compilation when they are embedded."
4105 (let (;; make sure no `require' starts them again by accident:
4106 (ad-advised-definers '(fset defalias define-function)))
4107 (ad-with-originals (defun defmacro)
4108 ad-do-it)))
4109
4110;; Make sure advice-infos are not allocated in pure space
4111;; (this might not be necessary anymore):
4112(ad-dolist (advised-function (cons 'documentation
4113 (append ad-advised-definers
4114 ad-advised-byte-compilers)))
4058 (ad-set-advice-info advised-function (ad-copy-advice-info advised-function))) 4115 (ad-set-advice-info advised-function (ad-copy-advice-info advised-function)))
4059 4116
4060) ;; end of ad-execute-defadvices
4061
4062;; Only run this once we are compiled. Expanding the defadvices
4063;; with only interpreted advice functions available takes forever:
4064(if (ad-compiled-p (symbol-function 'ad-execute-defadvices))
4065 (ad-execute-defadvices))
4066
4067 4117
4068;; @@ Forward advice support for jwz's byte-compiler (M-x serious-HACK-mode-on) 4118;; @@ Forward advice support for jwz's byte-compiler (M-x serious-HACK-mode-on)
4069;; ============================================================================ 4119;; ============================================================================
@@ -4071,20 +4121,20 @@ functions in `ad-definition-hooks' will be run after the re/definition with
4071;; folks in v18) produces compiled files that do not define functions via 4121;; folks in v18) produces compiled files that do not define functions via
4072;; explicit calls to `defun/defmacro', it rather uses `fset' for functions with 4122;; explicit calls to `defun/defmacro', it rather uses `fset' for functions with
4073;; documentation strings, and hunks of byte-code for sets of functions without 4123;; documentation strings, and hunks of byte-code for sets of functions without
4074;; any documentation. In Jamie's byte-compiler a series of compiled functions 4124;; any documentation. In Jamie's byte-compiler a series of compiled functions
4075;; without docstrings get hunked as 4125;; without docstrings get hunked as
4076;; (progn (fset 'f1 <code1>) (fset 'f2 <code2>) ...). 4126;; (progn (fset 'f1 <code1>) (fset 'f2 <code2>) ...).
4077;; The resulting progn will be compiled and the compiled form will be written 4127;; The resulting progn will be compiled and the compiled form will be written
4078;; to the compiled file as `(byte-code [progn-code] [constants] [depth])'. To 4128;; to the compiled file as `(byte-code [progn-code] [constants] [depth])'. To
4079;; handle forward advice we have to know when functions get defined so we can 4129;; handle forward advice we have to know when functions get defined so we can
4080;; activate any advice there might be. For standard v18 byte-compiled files 4130;; activate any advice there might be. For standard v18 byte-compiled files
4081;; we can do this by simply advising `defun/defmacro' because these subrs are 4131;; we can do this by simply advising `defun/defmacro' because these subrs are
4082;; evaluated explicitly when such a file is loaded. For Jamie's v19 compiler 4132;; evaluated explicitly when such a file is loaded. For Jamie's v19 compiler
4083;; our only choice is to additionally advise `fset' and change the subr 4133;; our only choice is to additionally advise `fset' and change the subr
4084;; `byte-code' such that it analyzes its byte-code string looking for fset's 4134;; `byte-code' such that it analyzes its byte-code string looking for fset's
4085;; when we are currently loading a file. In v19 the general overhead caused 4135;; when we are currently loading a file. In v19 the general overhead caused
4086;; by the advice of `byte-code' shouldn't be too bad, because byte-compiled 4136;; by the advice of `byte-code' shouldn't be too bad, because byte-compiled
4087;; functions do not call byte-code explicitly (as done in v18). In v18 this 4137;; functions do not call byte-code explicitly (as done in v18). In v18 this
4088;; is a problem because with the changed `byte-code' function function calls 4138;; is a problem because with the changed `byte-code' function function calls
4089;; become more expensive. 4139;; become more expensive.
4090;; 4140;;
@@ -4100,8 +4150,8 @@ functions in `ad-definition-hooks' will be run after the re/definition with
4100;; an `fset' opcode (M in ascii) that is preceded by two constant references, 4150;; an `fset' opcode (M in ascii) that is preceded by two constant references,
4101;; the first of which points to the function name and the second to its code. 4151;; the first of which points to the function name and the second to its code.
4102;; A constant reference can either be a simple one-byte one, or a three-byte 4152;; A constant reference can either be a simple one-byte one, or a three-byte
4103;; one if the function has more than 64 constants. The scanning can pretty 4153;; one if the function has more than 64 constants. The scanning can pretty
4104;; efficiently be done with a regular expression. Here it goes: 4154;; efficiently be done with a regular expression. Here it goes:
4105 4155
4106;; Have to hardcode these opcodes if I don't 4156;; Have to hardcode these opcodes if I don't
4107;; want to require the byte-compiler: 4157;; want to require the byte-compiler:
@@ -4158,10 +4208,10 @@ functions in `ad-definition-hooks' will be run after the re/definition with
4158 4208
4159(defun ad-scan-byte-code-for-fsets (ad-code ad-constants) 4209(defun ad-scan-byte-code-for-fsets (ad-code ad-constants)
4160 ;; In case anything in here goes wrong we reset `byte-code' to its real 4210 ;; In case anything in here goes wrong we reset `byte-code' to its real
4161 ;; identity. In particular, the handler of the condition-case uses 4211 ;; identity. In particular, the handler of the condition-case uses
4162 ;; `byte-code', so it better be the real one if we have an error: 4212 ;; `byte-code', so it better be the real one if we have an error:
4163 (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code)) 4213 (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code))
4164 (condition-case ignore-errors 4214 (condition-case nil
4165 (let ((fset-args '(0 0 0))) 4215 (let ((fset-args '(0 0 0)))
4166 (while (setq fset-args (ad-find-fset-in-byte-code 4216 (while (setq fset-args (ad-find-fset-in-byte-code
4167 ad-code ad-constants 4217 ad-code ad-constants
@@ -4193,83 +4243,44 @@ functions in `ad-definition-hooks' will be run after the re/definition with
4193;; The arguments will scope around the body of every byte-compiled 4243;; The arguments will scope around the body of every byte-compiled
4194;; function, hence they have to be obscure enough to not be equal to any 4244;; function, hence they have to be obscure enough to not be equal to any
4195;; global or argument variable referenced by any compiled function: 4245;; global or argument variable referenced by any compiled function:
4196(defun ad-advised-byte-code-definition (ad-cOdE ad-cOnStAnTs ad-dEpTh) 4246(defun ad-advised-byte-code (ad-cOdE ad-cOnStAnTs ad-dEpTh)
4197 "Modified version of `byte-code' subr used by the advice package. 4247 "Modified version of `byte-code' subr used by the Advice package.
4198`byte-code' has been modified to allow automatic activation of forward 4248`byte-code' has been modified to allow automatic activation of forward
4199advice for functions that are defined in byte-compiled files generated 4249advice for functions that are defined in byte-compiled files.
4200by jwz's byte-compiler (as standardly used in v19s).
4201See `ad-real-byte-code' for original documentation." 4250See `ad-real-byte-code' for original documentation."
4202 (prog1 (ad-real-byte-code ad-cOdE ad-cOnStAnTs ad-dEpTh) 4251 (prog1 (ad-real-byte-code ad-cOdE ad-cOnStAnTs ad-dEpTh)
4203 (if load-in-progress 4252 (if load-in-progress
4204 (ad-scan-byte-code-for-fsets ad-cOdE ad-cOnStAnTs)))) 4253 (ad-scan-byte-code-for-fsets ad-cOdE ad-cOnStAnTs))))
4205 4254
4206(ad-real-byte-codify 'ad-advised-byte-code-definition)
4207
4208;; ad-advised-byte-code cannot be defined with `defun', because that would
4209;; use `byte-code' for its body --> major disaster if forward advice is
4210;; enabled and this file gets loaded:
4211(ad-real-fset
4212 'ad-advised-byte-code (symbol-function 'ad-advised-byte-code-definition))
4213
4214(defun ad-recover-byte-code () 4255(defun ad-recover-byte-code ()
4215 "Recovers the real `byte-code' functionality." 4256 "Recovers the real `byte-code' functionality."
4216 (interactive) 4257 (interactive)
4217 (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code))) 4258 (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code)))
4218 4259
4219;; Make sure this is usable even if `byte-code' is screwed up:
4220(ad-real-byte-codify 'ad-recover-byte-code)
4221
4222;; Store original stack sizes because we might have to change them:
4223(defvar ad-orig-max-lisp-eval-depth max-lisp-eval-depth)
4224(defvar ad-orig-max-specpdl-size max-specpdl-size)
4225
4226(defun ad-adjust-stack-sizes (&optional reset)
4227 "Increases stack sizes for the advised `byte-code' function.
4228When called with a prefix argument the stack sizes will be reset
4229to their original values. Calling this function should only be necessary
4230if you get stack overflows because you run highly recursive v18 compiled
4231code in a v19 Emacs with definition hooks enabled."
4232 (interactive "P")
4233 (cond (reset
4234 (setq max-lisp-eval-depth ad-orig-max-lisp-eval-depth)
4235 (setq max-specpdl-size ad-orig-max-specpdl-size))
4236 (t ;; The redefined `byte-code' needs more execution stack
4237 ;; (5 cells per function invocation) and variable stack
4238 ;; (3 vars per function invocation):
4239 (setq max-lisp-eval-depth (* ad-orig-max-lisp-eval-depth 3))
4240 (setq max-specpdl-size
4241 (+ ad-orig-max-specpdl-size (* (/ max-lisp-eval-depth 5) 3))))))
4242
4243(defun ad-enable-definition-hooks () 4260(defun ad-enable-definition-hooks ()
4244 ;;"Enables definition hooks by redefining definition primitives. 4261 ;;"Enables definition hooks by redefining definition primitives.
4245 ;;Activates the advice of defun/defmacro/fset and possibly redefines 4262 ;;Activates the advice of defun/defmacro/fset and redefines `byte-code'.
4246 ;;`byte-code' if a v19 byte-compiler is used. Redefining these primitives 4263 ;;Redefining these primitives might lead to problems. Use
4247 ;;might lead to problems. Use `ad-disable-definition-hooks' or 4264 ;;`ad-disable-definition-hooks' or `ad-stop-advice' in such a case
4248 ;;`ad-stop-advice' in such a case to establish a safe state." 4265 ;;to establish a safe state."
4249 (ad-dolist (definer '(defun defmacro fset defalias define-function)) 4266 (ad-dolist (definer ad-advised-definers)
4250 (ad-enable-advice definer 'after 'ad-definition-hooks) 4267 (ad-enable-advice definer 'after 'ad-definition-hooks)
4251 (ad-activate definer 'compile)) 4268 (ad-activate definer 'compile))
4252 (cond (ad-use-jwz-byte-compiler 4269 (ad-dolist (byte-compiler ad-advised-byte-compilers)
4253 (ad-real-byte-codify 'ad-advised-byte-code) 4270 (ad-enable-advice byte-compiler 'around 'ad-deactivate-defun-defmacro)
4254 (ad-real-byte-codify 'ad-scan-byte-code-for-fsets) 4271 (ad-activate byte-compiler 'compile))
4255 ;; Now redefine byte-code... 4272 ;; Now redefine byte-code...
4256 (ad-real-fset 'byte-code (symbol-function 'ad-advised-byte-code)) 4273 (ad-real-fset 'byte-code (symbol-function 'ad-advised-byte-code)))
4257 ;; Only increase stack sizes in v18s, even though old-fashioned
4258 ;; v18 byte-code might be run in a v19, in which case one can call
4259 ;; `ad-adjust-stack-sizes' interactively if stacks become too small:
4260 (if (not ad-emacs19-p)
4261 (ad-adjust-stack-sizes)))))
4262 4274
4263(defun ad-disable-definition-hooks () 4275(defun ad-disable-definition-hooks ()
4264 ;;"Disables definition hooks by resetting definition primitives." 4276 ;;"Disables definition hooks by resetting definition primitives."
4265 (ad-recover-byte-code) 4277 (ad-recover-byte-code)
4266 (ad-dolist (definer '(defun defmacro fset defalias define-function)) 4278 (ad-dolist (definer ad-advised-definers)
4267 (ad-disable-advice definer 'after 'ad-definition-hooks) 4279 (ad-disable-advice definer 'after 'ad-definition-hooks)
4268 (ad-update definer)) 4280 (ad-update definer))
4269 (if (not ad-emacs19-p) 4281 (ad-dolist (byte-compiler ad-advised-byte-compilers)
4270 (ad-adjust-stack-sizes 'reset))) 4282 (ad-disable-advice byte-compiler 'around 'ad-deactivate-defun-defmacro)
4271 4283 (ad-update byte-compiler 'compile)))
4272(ad-real-byte-codify 'ad-disable-definition-hooks)
4273 4284
4274 4285
4275;; @@ Starting, stopping and recovering from the advice package magic: 4286;; @@ Starting, stopping and recovering from the advice package magic:
@@ -4281,10 +4292,10 @@ code in a v19 Emacs with definition hooks enabled."
4281If `ad-activate-on-definition' is t then advice information will 4292If `ad-activate-on-definition' is t then advice information will
4282automatically get activated whenever an advised function gets defined or 4293automatically get activated whenever an advised function gets defined or
4283redefined. This will enable goodies such as forward advice and 4294redefined. This will enable goodies such as forward advice and
4284automatically enable function definition hooks. If its value is nil but 4295automatically enable function definition hooks. If its value is nil but
4285the value of `ad-enable-definition-hooks' is t then definition hooks 4296the value of `ad-enable-definition-hooks' is t then definition hooks
4286will be enabled without having automatic advice activation, otherwise 4297will be enabled without having automatic advice activation, otherwise
4287function definition hooks will be disabled too. If definition hooks are 4298function definition hooks will be disabled too. If definition hooks are
4288enabled then functions stored in `ad-definition-hooks' are run whenever 4299enabled then functions stored in `ad-definition-hooks' are run whenever
4289a function gets defined or redefined." 4300a function gets defined or redefined."
4290 (interactive) 4301 (interactive)
@@ -4312,8 +4323,6 @@ This can also be used to recover from advice related emergencies."
4312 (setq ad-definition-hooks 4323 (setq ad-definition-hooks
4313 (delq 'ad-activate-defined-function ad-definition-hooks))) 4324 (delq 'ad-activate-defined-function ad-definition-hooks)))
4314 4325
4315(ad-real-byte-codify 'ad-stop-advice)
4316
4317(defun ad-recover-normality () 4326(defun ad-recover-normality ()
4318 "Undoes all advice related redefinitions and unadvises everything. 4327 "Undoes all advice related redefinitions and unadvises everything.
4319Use only in REAL emergencies." 4328Use only in REAL emergencies."
@@ -4322,11 +4331,9 @@ Use only in REAL emergencies."
4322 (ad-recover-all) 4331 (ad-recover-all)
4323 (setq ad-advised-functions nil)) 4332 (setq ad-advised-functions nil))
4324 4333
4325(ad-real-byte-codify 'ad-recover-normality)
4326
4327(if (and ad-start-advice-on-load 4334(if (and ad-start-advice-on-load
4328 ;; ...but only if we are compiled: 4335 ;; ...but only if we are compiled:
4329 (ad-compiled-p (symbol-function 'ad-execute-defadvices))) 4336 (ad-compiled-p (symbol-function 'ad-start-advice)))
4330 (ad-start-advice)) 4337 (ad-start-advice))
4331 4338
4332(provide 'advice) 4339(provide 'advice)