Mercurial > emacs
annotate lisp/emacs-lisp/advice.el @ 87498:566965810b9e
*** empty log message ***
author | Magnus Henoch <mange@freemail.hu> |
---|---|
date | Mon, 31 Dec 2007 00:57:51 +0000 |
parents | bd2837f89a3b |
children | 107ccd98fa12 880960b70474 |
rev | line source |
---|---|
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1 ;;; advice.el --- an overloading mechanism for Emacs Lisp functions |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2 |
74466 | 3 ;; Copyright (C) 1993, 1994, 2000, 2001, 2002, 2003, 2004, |
75346 | 4 ;; 2005, 2006, 2007 Free Software Foundation, Inc. |
4110 | 5 |
6 ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> | |
26622 | 7 ;; Maintainer: FSF |
4110 | 8 ;; Created: 12 Dec 1992 |
5140 | 9 ;; Keywords: extensions, lisp, tools |
4110 | 10 |
11 ;; This file is part of GNU Emacs. | |
12 | |
13 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
14 ;; it under the terms of the GNU General Public License as published by | |
78217
935157c0b596
Switch license to GPLv3 or later.
Glenn Morris <rgm@gnu.org>
parents:
78150
diff
changeset
|
15 ;; the Free Software Foundation; either version 3, or (at your option) |
4110 | 16 ;; any later version. |
17 | |
18 ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 ;; GNU General Public License for more details. | |
22 | |
23 ;; You should have received a copy of the GNU General Public License | |
14169 | 24 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
64085 | 25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
26 ;; Boston, MA 02110-1301, USA. | |
4110 | 27 |
28 ;; LCD Archive Entry: | |
29 ;; advice|Hans Chalupsky|hans@cs.buffalo.edu| | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
30 ;; Overloading mechanism for Emacs Lisp functions| |
8458
a95ca44cec95
(ad-subr-arglist): Adapted to new DOC file format.
Richard M. Stallman <rms@gnu.org>
parents:
8445
diff
changeset
|
31 ;; 1994/08/05 03:42:04|2.14|~/packages/advice.el.Z| |
4110 | 32 |
33 | |
34 ;;; Commentary: | |
35 | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
36 ;; NOTE: This documentation is slightly out of date. In particular, all the |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
37 ;; references to Emacs-18 are obsolete now, because it is not any longer |
26217 | 38 ;; supported by this version of Advice. |
39 | |
40 ;; Advice is documented in the Emacs Lisp Manual. | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
41 |
4110 | 42 ;; @ Introduction: |
43 ;; =============== | |
44 ;; This package implements a full-fledged Lisp-style advice mechanism | |
26217 | 45 ;; for Emacs Lisp. Advice is a clean and efficient way to modify the |
4110 | 46 ;; behavior of Emacs Lisp functions without having to keep personal |
26217 | 47 ;; modified copies of such functions around. A great number of such |
48 ;; modifications can be achieved by treating the original function as a | |
49 ;; black box and specifying a different execution environment for it | |
4110 | 50 ;; with a piece of advice. Think of a piece of advice as a kind of fancy |
51 ;; hook that you can attach to any function/macro/subr. | |
52 | |
53 ;; @ Highlights: | |
54 ;; ============= | |
55 ;; - Clean definition of multiple, named before/around/after advices | |
56 ;; for functions, macros, subrs and special forms | |
57 ;; - Full control over the arguments an advised function will receive, | |
58 ;; the binding environment in which it will be executed, as well as the | |
59 ;; value it will return. | |
60 ;; - Allows re/definition of interactive behavior for functions and subrs | |
26217 | 61 ;; - Every piece of advice can have its documentation string which will be |
4110 | 62 ;; combined with the original documentation of the advised function at |
63 ;; call-time of `documentation' for proper command-key substitution. | |
64 ;; - The execution of every piece of advice can be protected against error | |
65 ;; and non-local exits in preceding code or advices. | |
66 ;; - Simple argument access either by name, or, more portable but as | |
67 ;; efficient, via access macros | |
68 ;; - Allows the specification of a different argument list for the advised | |
69 ;; version of a function. | |
70 ;; - Advised functions can be byte-compiled either at file-compile time | |
71 ;; (see preactivation) or activation time. | |
72 ;; - Separation of advice definition and activation | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
73 ;; - Forward advice is possible, that is |
4110 | 74 ;; as yet undefined or autoload functions can be advised without having to |
26217 | 75 ;; preload the file in which they are defined. |
4110 | 76 ;; - Forward redefinition is possible because around advice can be used to |
77 ;; completely redefine a function. | |
78 ;; - A caching mechanism for advised definition provides for cheap deactivation | |
79 ;; and reactivation of advised functions. | |
80 ;; - Preactivation allows efficient construction and compilation of advised | |
81 ;; definitions at file compile time without giving up the flexibility of | |
82 ;; the advice mechanism. | |
83 ;; - En/disablement mechanism allows the use of different "views" of advised | |
84 ;; functions depending on what pieces of advice are currently en/disabled | |
26217 | 85 ;; - Provides manipulation mechanisms for sets of advised functions via |
4110 | 86 ;; regular expressions that match advice names |
87 | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
88 ;; @ How to get Advice for Emacs-18: |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
89 ;; ================================= |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
90 ;; `advice18.el', a version of Advice that also works in Emacs-18 is available |
26217 | 91 ;; either via anonymous ftp from `ftp.cs.buffalo.edu (128.205.32.9)' with |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
92 ;; pathname `/pub/Emacs/advice18.el', or from one of the Emacs Lisp archive |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
93 ;; sites, or send email to <hans@cs.buffalo.edu> and I'll mail it to you. |
4110 | 94 |
95 ;; @ Overview, or how to read this file: | |
96 ;; ===================================== | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
97 ;; NOTE: This documentation is slightly out of date. In particular, all the |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
98 ;; references to Emacs-18 are obsolete now, because it is not any longer |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
99 ;; supported by this version of Advice. An up-to-date version will soon be |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
100 ;; available as an info file (thanks to the kind help of Jack Vinson and |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
101 ;; David M. Smith). Until then you can use `outline-mode' to help you read |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
102 ;; this documentation (set `outline-regexp' to `";; @+"'). |
4110 | 103 ;; |
104 ;; The four major sections of this file are: | |
105 ;; | |
106 ;; @ This initial information ...installation, customization etc. | |
107 ;; @ Advice documentation: ...general documentation | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
108 ;; @ Foo games: An advice tutorial ...teaches about Advice by example |
4110 | 109 ;; @ Advice implementation: ...actual code, yeah!! |
110 ;; | |
111 ;; The latter three are actual headings which you can search for | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
112 ;; directly in case `outline-mode' doesn't work for you. |
4110 | 113 |
114 ;; @ Restrictions: | |
115 ;; =============== | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
116 ;; - This version of Advice only works for Emacs 19.26 and later. It uses |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
117 ;; new versions of the built-in functions `fset/defalias' which are not |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
118 ;; yet available in Lucid Emacs, hence, it won't work there. |
4110 | 119 ;; - Advised functions/macros/subrs will only exhibit their advised behavior |
120 ;; when they are invoked via their function cell. This means that advice will | |
121 ;; not work for the following: | |
26217 | 122 ;; + advised subrs that are called directly from other subrs or C-code |
123 ;; + advised subrs that got replaced with their byte-code during | |
4110 | 124 ;; byte-compilation (e.g., car) |
125 ;; + advised macros which were expanded during byte-compilation before | |
126 ;; their advice was activated. | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
127 |
4110 | 128 ;; @ Credits: |
129 ;; ========== | |
130 ;; This package is an extension and generalization of packages such as | |
131 ;; insert-hooks.el written by Noah S. Friedman, and advise.el written by | |
132 ;; Raul J. Acevedo. Some ideas used in here come from these packages, | |
133 ;; others come from the various Lisp advice mechanisms I've come across | |
134 ;; so far, and a few are simply mine. | |
135 | |
136 ;; @ Comments, suggestions, bug reports: | |
137 ;; ===================================== | |
138 ;; If you find any bugs, have suggestions for new advice features, find the | |
139 ;; documentation wrong, confusing, incomplete, or otherwise unsatisfactory, | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
140 ;; have any questions about Advice, or have otherwise enlightening |
4110 | 141 ;; comments feel free to send me email at <hans@cs.buffalo.edu>. |
142 | |
143 ;; @ Safety Rules and Emergency Exits: | |
144 ;; =================================== | |
145 ;; Before we begin: CAUTION!! | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
146 ;; Advice provides you with a lot of rope to hang yourself on very |
4110 | 147 ;; easily accessible trees, so, here are a few important things you |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
148 ;; should know: Once Advice has been started with `ad-start-advice' |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
149 ;; (which happens automatically when you load this file), it |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
150 ;; generates an advised definition of the `documentation' function, and |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
151 ;; it will enable automatic advice activation when functions get defined. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
152 ;; All of this can be undone at any time with `M-x ad-stop-advice'. |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
153 ;; |
4110 | 154 ;; If you experience any strange behavior/errors etc. that you attribute to |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
155 ;; Advice or to some ill-advised function do one of the following: |
4110 | 156 |
157 ;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what | |
158 ;; function gives you problems) | |
159 ;; - M-x ad-deactivate-all (if you don't have a clue what's going wrong) | |
160 ;; - M-x ad-stop-advice (if you think the problem is related to the | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
161 ;; advised functions used by Advice itself) |
4110 | 162 ;; - M-x ad-recover-normality (for real emergencies) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
163 ;; - If none of the above solves your Advice-related problem go to another |
4110 | 164 ;; terminal, kill your Emacs process and send me some hate mail. |
165 | |
166 ;; The first three measures have restarts, i.e., once you've figured out | |
167 ;; the problem you can reactivate advised functions with either `ad-activate', | |
168 ;; `ad-activate-all', or `ad-start-advice'. `ad-recover-normality' unadvises | |
169 ;; everything so you won't be able to reactivate any advised functions, you'll | |
170 ;; have to stick with their standard incarnations for the rest of the session. | |
171 | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
172 ;; IMPORTANT: With Advice loaded always do `M-x ad-deactivate-all' before |
4110 | 173 ;; you byte-compile a file, because advised special forms and macros can lead |
174 ;; to unwanted compilation results. When you are done compiling use | |
26217 | 175 ;; `M-x ad-activate-all' to go back to the advised state of all your |
4110 | 176 ;; advised functions. |
177 | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
178 ;; RELAX: Advice is pretty safe even if you are oblivious to the above. |
4110 | 179 ;; I use it extensively and haven't run into any serious trouble in a long |
180 ;; time. Just wanted you to be warned. | |
181 | |
182 ;; @ Customization: | |
183 ;; ================ | |
184 | |
185 ;; Look at the documentation of `ad-redefinition-action' for possible values | |
186 ;; of this variable. Its default value is `warn' which will print a warning | |
187 ;; message when an already defined advised function gets redefined with a | |
188 ;; new original definition and de/activated. | |
189 | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
190 ;; Look at the documentation of `ad-default-compilation-action' for possible |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
191 ;; values of this variable. Its default value is `maybe' which will compile |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
192 ;; advised definitions during activation in case the byte-compiler is already |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
193 ;; loaded. Otherwise, it will leave them uncompiled. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
194 |
4110 | 195 ;; @ Motivation: |
196 ;; ============= | |
197 ;; Before I go on explaining how advice works, here are four simple examples | |
198 ;; how this package can be used. The first three are very useful, the last one | |
199 ;; is just a joke: | |
200 | |
201 ;;(defadvice switch-to-buffer (before existing-buffers-only activate) | |
26217 | 202 ;; "When called interactively switch to existing buffers only, unless |
4110 | 203 ;;when called with a prefix argument." |
26217 | 204 ;; (interactive |
205 ;; (list (read-buffer "Switch to buffer: " (other-buffer) | |
4110 | 206 ;; (null current-prefix-arg))))) |
207 ;; | |
208 ;;(defadvice switch-to-buffer (around confirm-non-existing-buffers activate) | |
209 ;; "Switch to non-existing buffers only upon confirmation." | |
210 ;; (interactive "BSwitch to buffer: ") | |
211 ;; (if (or (get-buffer (ad-get-arg 0)) | |
212 ;; (y-or-n-p (format "`%s' does not exist, create? " (ad-get-arg 0)))) | |
213 ;; ad-do-it)) | |
214 ;; | |
215 ;;(defadvice find-file (before existing-files-only activate) | |
216 ;; "Find existing files only" | |
217 ;; (interactive "fFind file: ")) | |
218 ;; | |
219 ;;(defadvice car (around interactive activate) | |
220 ;; "Make `car' an interactive function." | |
221 ;; (interactive "xCar of list: ") | |
222 ;; ad-do-it | |
223 ;; (if (interactive-p) | |
224 ;; (message "%s" ad-return-value))) | |
225 | |
226 | |
227 ;; @ Advice documentation: | |
228 ;; ======================= | |
229 ;; Below is general documentation of the various features of advice. For more | |
230 ;; concrete examples check the corresponding sections in the tutorial part. | |
231 | |
232 ;; @@ Terminology: | |
233 ;; =============== | |
24875 | 234 ;; - Emacs, Emacs-19: Emacs as released by the GNU Project |
4110 | 235 ;; - Lemacs: Lucid's version of Emacs with major version 19 |
236 ;; - v18: Any Emacs with major version 18 or built as an extension to that | |
237 ;; (such as Epoch) | |
238 ;; - v19: Any Emacs with major version 19 | |
26217 | 239 ;; - jwz: Jamie Zawinski - former keeper of Lemacs and creator of the optimizing |
4110 | 240 ;; byte-compiler used in v19s. |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
241 ;; - Advice: The name of this package. |
4110 | 242 ;; - advices: Short for "pieces of advice". |
243 | |
244 ;; @@ Defining a piece of advice with `defadvice': | |
245 ;; =============================================== | |
246 ;; The main means of defining a piece of advice is the macro `defadvice', | |
247 ;; there is no interactive way of specifying a piece of advice. A call to | |
248 ;; `defadvice' has the following syntax which is similar to the syntax of | |
249 ;; `defun/defmacro': | |
250 ;; | |
251 ;; (defadvice <function> (<class> <name> [<position>] [<arglist>] {<flags>}*) | |
252 ;; [ [<documentation-string>] [<interactive-form>] ] | |
253 ;; {<body-form>}* ) | |
254 | |
255 ;; <function> is the name of the function/macro/subr to be advised. | |
256 | |
257 ;; <class> is the class of the advice which has to be one of `before', | |
258 ;; `around', `after', `activation' or `deactivation' (the last two allow | |
259 ;; definition of special act/deactivation hooks). | |
260 | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
261 ;; <name> is the name of the advice which has to be a non-nil symbol. |
4110 | 262 ;; Names uniquely identify a piece of advice in a certain advice class, |
263 ;; hence, advices can be redefined by defining an advice with the same class | |
264 ;; and name. Advice names are global symbols, hence, the same name space | |
265 ;; conventions used for function names should be applied. | |
266 | |
267 ;; An optional <position> specifies where in the current list of advices of | |
268 ;; the specified <class> this new advice will be placed. <position> has to | |
269 ;; be either `first', `last' or a number that specifies a zero-based | |
270 ;; position (`first' is equivalent to 0). If no position is specified | |
271 ;; `first' will be used as a default. If this call to `defadvice' redefines | |
272 ;; an already existing advice (see above) then the position argument will | |
273 ;; be ignored and the position of the already existing advice will be used. | |
274 | |
275 ;; An optional <arglist> which has to be a list can be used to define the | |
276 ;; argument list of the advised function. This argument list should of | |
277 ;; course be compatible with the argument list of the original function, | |
278 ;; otherwise functions that call the advised function with the original | |
279 ;; argument list in mind will break. If more than one advice specify an | |
280 ;; argument list then the first one (the one with the smallest position) | |
281 ;; found in the list of before/around/after advices will be used. | |
282 | |
283 ;; <flags> is a list of symbols that specify further information about the | |
284 ;; advice. All flags can be specified with unambiguous initial substrings. | |
285 ;; `activate': Specifies that the advice information of the advised | |
286 ;; function should be activated right after this advice has been | |
26217 | 287 ;; defined. In forward advices `activate' will be ignored. |
4110 | 288 ;; `protect': Specifies that this advice should be protected against |
289 ;; non-local exits and errors in preceding code/advices. | |
290 ;; `compile': Specifies that the advised function should be byte-compiled. | |
291 ;; This flag will be ignored unless `activate' is also specified. | |
292 ;; `disable': Specifies that the defined advice should be disabled, hence, | |
293 ;; it will not be used in an activation until somebody enables it. | |
294 ;; `preactivate': Specifies that the advised function should get preactivated | |
295 ;; at macro-expansion/compile time of this `defadvice'. This | |
296 ;; generates a compiled advised definition according to the | |
297 ;; current advice state which will be used during activation | |
298 ;; if appropriate. Only use this if the `defadvice' gets | |
299 ;; actually compiled (with a v18 byte-compiler put the `defadvice' | |
300 ;; into the body of a `defun' to accomplish proper compilation). | |
301 | |
302 ;; An optional <documentation-string> can be supplied to document the advice. | |
303 ;; On call of the `documentation' function it will be combined with the | |
304 ;; documentation strings of the original function and other advices. | |
305 | |
306 ;; An optional <interactive-form> form can be supplied to change/add | |
307 ;; interactive behavior of the original function. If more than one advice | |
308 ;; has an `(interactive ...)' specification then the first one (the one | |
309 ;; with the smallest position) found in the list of before/around/after | |
310 ;; advices will be used. | |
311 | |
312 ;; A possibly empty list of <body-forms> specifies the body of the advice in | |
313 ;; an implicit progn. The body of an advice can access/change arguments, | |
26217 | 314 ;; the return value, the binding environment, and can have all sorts of |
4110 | 315 ;; other side effects. |
316 | |
317 ;; @@ Assembling advised definitions: | |
318 ;; ================================== | |
319 ;; Suppose a function/macro/subr/special-form has N pieces of before advice, | |
320 ;; M pieces of around advice and K pieces of after advice. Assuming none of | |
321 ;; the advices is protected, its advised definition will look like this | |
322 ;; (body-form indices correspond to the position of the respective advice in | |
323 ;; that advice class): | |
324 | |
325 ;; ([macro] lambda <arglist> | |
326 ;; [ [<advised-docstring>] [(interactive ...)] ] | |
327 ;; (let (ad-return-value) | |
328 ;; {<before-0-body-form>}* | |
329 ;; .... | |
330 ;; {<before-N-1-body-form>}* | |
331 ;; {<around-0-body-form>}* | |
332 ;; {<around-1-body-form>}* | |
333 ;; .... | |
334 ;; {<around-M-1-body-form>}* | |
335 ;; (setq ad-return-value | |
336 ;; <apply original definition to <arglist>>) | |
337 ;; {<other-around-M-1-body-form>}* | |
338 ;; .... | |
339 ;; {<other-around-1-body-form>}* | |
340 ;; {<other-around-0-body-form>}* | |
341 ;; {<after-0-body-form>}* | |
342 ;; .... | |
343 ;; {<after-K-1-body-form>}* | |
344 ;; ad-return-value)) | |
345 | |
346 ;; Macros and special forms will be redefined as macros, hence the optional | |
347 ;; [macro] in the beginning of the definition. | |
348 | |
349 ;; <arglist> is either the argument list of the original function or the | |
350 ;; first argument list defined in the list of before/around/after advices. | |
351 ;; The values of <arglist> variables can be accessed/changed in the body of | |
352 ;; an advice by simply referring to them by their original name, however, | |
353 ;; more portable argument access macros are also provided (see below). For | |
354 ;; subrs/special-forms for which neither explicit argument list definitions | |
355 ;; are available, nor their documentation strings contain such definitions | |
356 ;; (as they do v19s), `(&rest ad-subr-args)' will be used. | |
357 | |
358 ;; <advised-docstring> is an optional, special documentation string which will | |
359 ;; be expanded into a proper documentation string upon call of `documentation'. | |
360 | |
361 ;; (interactive ...) is an optional interactive form either taken from the | |
362 ;; original function or from a before/around/after advice. For advised | |
363 ;; interactive subrs that do not have an interactive form specified in any | |
364 ;; advice we have to use (interactive) and then call the subr interactively | |
365 ;; if the advised function was called interactively, because the | |
366 ;; interactive specification of subrs is not accessible. This is the only | |
367 ;; case where changing the values of arguments will not have an affect | |
368 ;; because they will be reset by the interactive specification of the subr. | |
369 ;; If this is a problem one can always specify an interactive form in a | |
370 ;; before/around/after advice to gain control over argument values that | |
371 ;; were supplied interactively. | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
372 ;; |
4110 | 373 ;; Then the body forms of the various advices in the various classes of advice |
374 ;; are assembled in order. The forms of around advice L are normally part of | |
375 ;; one of the forms of around advice L-1. An around advice can specify where | |
376 ;; the forms of the wrapped or surrounded forms should go with the special | |
377 ;; keyword `ad-do-it', which will be substituted with a `progn' containing the | |
378 ;; forms of the surrounded code. | |
379 | |
26217 | 380 ;; The innermost part of the around advice onion is |
4110 | 381 ;; <apply original definition to <arglist>> |
382 ;; whose form depends on the type of the original function. The variable | |
383 ;; `ad-return-value' will be set to its result. This variable is visible to | |
384 ;; all pieces of advice which can access and modify it before it gets returned. | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
385 ;; |
4110 | 386 ;; The semantic structure of advised functions that contain protected pieces |
387 ;; of advice is the same. The only difference is that `unwind-protect' forms | |
388 ;; make sure that the protected advice gets executed even if some previous | |
389 ;; piece of advice had an error or a non-local exit. If any around advice is | |
390 ;; protected then the whole around advice onion will be protected. | |
391 | |
392 ;; @@ Argument access in advised functions: | |
393 ;; ======================================== | |
394 ;; As already mentioned, the simplest way to access the arguments of an | |
395 ;; advised function in the body of an advice is to refer to them by name. To | |
396 ;; do that, the advice programmer needs to know either the names of the | |
397 ;; argument variables of the original function, or the names used in the | |
398 ;; argument list redefinition given in a piece of advice. While this simple | |
399 ;; method might be sufficient in many cases, it has the disadvantage that it | |
400 ;; is not very portable because it hardcodes the argument names into the | |
401 ;; advice. If the definition of the original function changes the advice | |
402 ;; might break even though the code might still be correct. Situations like | |
403 ;; that arise, for example, if one advises a subr like `eval-region' which | |
404 ;; gets redefined in a non-advice style into a function by the edebug | |
405 ;; package. If the advice assumes `eval-region' to be a subr it might break | |
406 ;; once edebug is loaded. Similar situations arise when one wants to use the | |
407 ;; same piece of advice across different versions of Emacs. Some subrs in a | |
408 ;; v18 Emacs are functions in v19 and vice versa, but for the most part the | |
409 ;; semantics remain the same, hence, the same piece of advice might be usable | |
410 ;; in both Emacs versions. | |
411 | |
412 ;; As a solution to that advice provides argument list access macros that get | |
413 ;; translated into the proper access forms at activation time, i.e., when the | |
414 ;; advised definition gets constructed. Access macros access actual arguments | |
415 ;; by position regardless of how these actual argument get distributed onto | |
416 ;; the argument variables of a function. The rational behind this is that in | |
417 ;; Emacs Lisp the semantics of an argument is strictly determined by its | |
418 ;; position (there are no keyword arguments). | |
419 | |
420 ;; Suppose the function `foo' is defined as | |
421 ;; | |
422 ;; (defun foo (x y &optional z &rest r) ....) | |
423 ;; | |
424 ;; and is then called with | |
425 ;; | |
426 ;; (foo 0 1 2 3 4 5 6) | |
427 | |
428 ;; which means that X=0, Y=1, Z=2 and R=(3 4 5 6). The assumption is that | |
429 ;; the semantics of an actual argument is determined by its position. It is | |
430 ;; this semantics that has to be known by the advice programmer. Then s/he | |
431 ;; can access these arguments in a piece of advice with some of the | |
432 ;; following macros (the arrows indicate what value they will return): | |
433 | |
434 ;; (ad-get-arg 0) -> 0 | |
435 ;; (ad-get-arg 1) -> 1 | |
436 ;; (ad-get-arg 2) -> 2 | |
437 ;; (ad-get-arg 3) -> 3 | |
438 ;; (ad-get-args 2) -> (2 3 4 5 6) | |
439 ;; (ad-get-args 4) -> (4 5 6) | |
440 | |
441 ;; `(ad-get-arg <position>)' will return the actual argument that was supplied | |
442 ;; at <position>, `(ad-get-args <position>)' will return the list of actual | |
443 ;; arguments supplied starting at <position>. Note that these macros can be | |
444 ;; used without any knowledge about the form of the actual argument list of | |
445 ;; the original function. | |
446 | |
447 ;; Similarly, `(ad-set-arg <position> <value-form>)' can be used to set the | |
448 ;; value of the actual argument at <position> to <value-form>. For example, | |
449 ;; | |
450 ;; (ad-set-arg 5 "five") | |
451 ;; | |
452 ;; will have the effect that R=(3 4 "five" 6) once the original function is | |
453 ;; called. `(ad-set-args <position> <value-list-form>)' can be used to set | |
454 ;; the list of actual arguments starting at <position> to <value-list-form>. | |
455 ;; For example, | |
456 ;; | |
457 ;; (ad-set-args 0 '(5 4 3 2 1 0)) | |
458 ;; | |
459 ;; will have the effect that X=5, Y=4, Z=3 and R=(2 1 0) once the original | |
460 ;; function is called. | |
461 | |
462 ;; All these access macros are text macros rather than real Lisp macros. When | |
463 ;; the advised definition gets constructed they get replaced with actual access | |
464 ;; forms depending on the argument list of the advised function, i.e., after | |
465 ;; that argument access is in most cases as efficient as using the argument | |
466 ;; variable names directly. | |
467 | |
468 ;; @@@ Accessing argument bindings of arbitrary functions: | |
469 ;; ======================================================= | |
470 ;; Some functions (such as `trace-function' defined in trace.el) need a | |
471 ;; method of accessing the names and bindings of the arguments of an | |
472 ;; arbitrary advised function. To do that within an advice one can use the | |
473 ;; special keyword `ad-arg-bindings' which is a text macro that will be | |
474 ;; substituted with a form that will evaluate to a list of binding | |
475 ;; specifications, one for every argument variable. These binding | |
476 ;; specifications can then be examined in the body of the advice. For | |
477 ;; example, somewhere in an advice we could do this: | |
478 ;; | |
479 ;; (let* ((bindings ad-arg-bindings) | |
480 ;; (firstarg (car bindings)) | |
481 ;; (secondarg (car (cdr bindings)))) | |
482 ;; ;; Print info about first argument | |
483 ;; (print (format "%s=%s (%s)" | |
484 ;; (ad-arg-binding-field firstarg 'name) | |
485 ;; (ad-arg-binding-field firstarg 'value) | |
486 ;; (ad-arg-binding-field firstarg 'type))) | |
487 ;; ....) | |
488 ;; | |
489 ;; The `type' of an argument is either `required', `optional' or `rest'. | |
490 ;; Wherever `ad-arg-bindings' appears a form will be inserted that evaluates | |
491 ;; to the list of bindings, hence, in order to avoid multiple unnecessary | |
492 ;; evaluations one should always bind it to some variable. | |
493 | |
494 ;; @@@ Argument list mapping: | |
495 ;; ========================== | |
496 ;; Because `defadvice' allows the specification of the argument list of the | |
497 ;; advised function we need a mapping mechanism that maps this argument list | |
498 ;; onto that of the original function. For example, somebody might specify | |
499 ;; `(sym newdef)' as the argument list of `fset', while advice might use | |
500 ;; `(&rest ad-subr-args)' as the argument list of the original function | |
501 ;; (depending on what Emacs version is used). Hence SYM and NEWDEF have to | |
502 ;; be properly mapped onto the &rest variable when the original definition is | |
26217 | 503 ;; called. Advice automatically takes care of that mapping, hence, the advice |
4110 | 504 ;; programmer can specify an argument list without having to know about the |
505 ;; exact structure of the original argument list as long as the new argument | |
506 ;; list takes a compatible number/magnitude of actual arguments. | |
507 | |
508 ;; @@@ Definition of subr argument lists: | |
509 ;; ====================================== | |
510 ;; When advice constructs the advised definition of a function it has to | |
511 ;; know the argument list of the original function. For functions and macros | |
512 ;; the argument list can be determined from the actual definition, however, | |
513 ;; for subrs there is no such direct access available. In Lemacs and for some | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
514 ;; subrs in Emacs-19 the argument list of a subr can be determined from |
4110 | 515 ;; its documentation string, in a v18 Emacs even that is not possible. If |
516 ;; advice cannot at all determine the argument list of a subr it uses | |
517 ;; `(&rest ad-subr-args)' which will always work but is inefficient because | |
518 ;; it conses up arguments. The macro `ad-define-subr-args' can be used by | |
519 ;; the advice programmer to explicitly tell advice about the argument list | |
520 ;; of a certain subr, for example, | |
521 ;; | |
522 ;; (ad-define-subr-args 'fset '(sym newdef)) | |
523 ;; | |
524 ;; is used by advice itself to tell a v18 Emacs about the arguments of `fset'. | |
525 ;; The following can be used to undo such a definition: | |
526 ;; | |
527 ;; (ad-undefine-subr-args 'fset) | |
528 ;; | |
529 ;; The argument list definition is stored on the property list of the subr | |
530 ;; name symbol. When an argument list could be determined from the | |
531 ;; documentation string it will be cached under that property. The general | |
532 ;; mechanism for looking up the argument list of a subr is the following: | |
533 ;; 1) look for a definition stored on the property list | |
534 ;; 2) if that failed try to infer it from the documentation string and | |
535 ;; if successful cache it on the property list | |
536 ;; 3) otherwise use `(&rest ad-subr-args)' | |
537 | |
538 ;; @@ Activation and deactivation: | |
539 ;; =============================== | |
540 ;; The definition of an advised function does not change until all its advice | |
541 ;; gets actually activated. Activation can either happen with the `activate' | |
542 ;; flag specified in the `defadvice', with an explicit call or interactive | |
543 ;; invocation of `ad-activate', or if forward advice is enabled (i.e., the | |
544 ;; value of `ad-activate-on-definition' is t) at the time an already advised | |
545 ;; function gets defined. | |
546 | |
547 ;; When a function gets first activated its original definition gets saved, | |
548 ;; all defined and enabled pieces of advice will get combined with the | |
549 ;; original definition, the resulting definition might get compiled depending | |
550 ;; on some conditions described below, and then the function will get | |
551 ;; redefined with the advised definition. This also means that undefined | |
552 ;; functions cannot get activated even though they might be already advised. | |
553 | |
554 ;; The advised definition will get compiled either if `ad-activate' was called | |
555 ;; interactively with a prefix argument, or called explicitly with its second | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
556 ;; argument as t, or, if `ad-default-compilation-action' justifies it according |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
557 ;; to the current system state. If the advised definition was |
4110 | 558 ;; constructed during "preactivation" (see below) then that definition will |
559 ;; be already compiled because it was constructed during byte-compilation of | |
560 ;; the file that contained the `defadvice' with the `preactivate' flag. | |
561 | |
562 ;; `ad-deactivate' can be used to back-define an advised function to its | |
563 ;; original definition. It can be called interactively or directly. Because | |
564 ;; `ad-activate' caches the advised definition the function can be | |
565 ;; reactivated via `ad-activate' with only minor overhead (it is checked | |
566 ;; whether the current advice state is consistent with the cached | |
567 ;; definition, see the section on caching below). | |
568 | |
569 ;; `ad-activate-regexp' and `ad-deactivate-regexp' can be used to de/activate | |
570 ;; all currently advised function that have a piece of advice with a name that | |
571 ;; contains a match for a regular expression. These functions can be used to | |
572 ;; de/activate sets of functions depending on certain advice naming | |
573 ;; conventions. | |
574 | |
575 ;; Finally, `ad-activate-all' and `ad-deactivate-all' can be used to | |
576 ;; de/activate all currently advised functions. These are useful to | |
577 ;; (temporarily) return to an un/advised state. | |
578 | |
579 ;; @@@ Reasons for the separation of advice definition and activation: | |
580 ;; =================================================================== | |
581 ;; As already mentioned, advising happens in two stages: | |
582 | |
583 ;; 1) definition of various pieces of advice | |
584 ;; 2) activation of all advice currently defined and enabled | |
585 | |
586 ;; The advantage of this is that various pieces of advice can be defined | |
587 ;; before they get combined into an advised definition which avoids | |
588 ;; unnecessary constructions of intermediate advised definitions. The more | |
589 ;; important advantage is that it allows the implementation of forward advice. | |
590 ;; Advice information for a certain function accumulates as the value of the | |
591 ;; `advice-info' property of the function symbol. This accumulation is | |
592 ;; completely independent of the fact that that function might not yet be | |
593 ;; defined. The special forms `defun' and `defmacro' have been advised to | |
594 ;; check whether the function/macro they defined had advice information | |
595 ;; associated with it. If so and forward advice is enabled, the original | |
596 ;; definition will be saved, and then the advice will be activated. When a | |
597 ;; file is loaded in a v18 Emacs the functions/macros it defines are also | |
598 ;; defined with calls to `defun/defmacro'. Hence, we can forward advise | |
599 ;; functions/macros which will be defined later during a load/autoload of some | |
600 ;; file (for compiled files generated by jwz's byte-compiler in a v19 Emacs | |
601 ;; this is slightly more complicated but the basic idea is the same). | |
602 | |
603 ;; @@ Enabling/disabling pieces or sets of advice: | |
604 ;; =============================================== | |
605 ;; A major motivation for the development of this advice package was to bring | |
606 ;; a little bit more structure into the function overloading chaos in Emacs | |
607 ;; Lisp. Many packages achieve some of their functionality by adding a little | |
608 ;; bit (or a lot) to the standard functionality of some Emacs Lisp function. | |
609 ;; ange-ftp is a very popular package that achieves its magic by overloading | |
610 ;; most Emacs Lisp functions that deal with files. A popular function that's | |
611 ;; overloaded by many packages is `expand-file-name'. The situation that one | |
612 ;; function is multiply overloaded can arise easily. | |
613 | |
614 ;; Once in a while it would be desirable to be able to disable some/all | |
615 ;; overloads of a particular package while keeping all the rest. Ideally - | |
616 ;; at least in my opinion - these overloads would all be done with advice, | |
617 ;; I know I am dreaming right now... In that ideal case the enable/disable | |
618 ;; mechanism of advice could be used to achieve just that. | |
619 | |
620 ;; Every piece of advice is associated with an enablement flag. When the | |
621 ;; advised definition of a particular function gets constructed (e.g., during | |
622 ;; activation) only the currently enabled pieces of advice will be considered. | |
623 ;; This mechanism allows one to have different "views" of an advised function | |
624 ;; dependent on what pieces of advice are currently enabled. | |
625 | |
626 ;; Another motivation for this mechanism is that it allows one to define a | |
627 ;; piece of advice for some function yet keep it dormant until a certain | |
628 ;; condition is met. Until then activation of the function will not make use | |
629 ;; of that piece of advice. Once the condition is met the advice can be | |
630 ;; enabled and a reactivation of the function will add its functionality as | |
631 ;; part of the new advised definition. For example, the advices of `defun' | |
632 ;; etc. used by advice itself will stay disabled until `ad-start-advice' is | |
633 ;; called and some variables have the proper values. Hence, if somebody | |
634 ;; else advised these functions too and activates them the advices defined | |
635 ;; by advice will get used only if they are intended to be used. | |
636 | |
637 ;; The main interface to this mechanism are the interactive functions | |
638 ;; `ad-enable-advice' and `ad-disable-advice'. For example, the following | |
639 ;; would disable a particular advice of the function `foo': | |
640 ;; | |
641 ;; (ad-disable-advice 'foo 'before 'my-advice) | |
642 ;; | |
643 ;; This call by itself only changes the flag, to get the proper effect in | |
644 ;; the advised definition too one has to activate `foo' with | |
645 ;; | |
646 ;; (ad-activate 'foo) | |
647 ;; | |
648 ;; or interactively. To disable whole sets of advices one can use a regular | |
649 ;; expression mechanism. For example, let us assume that ange-ftp actually | |
650 ;; used advice to overload all its functions, and that it used the | |
651 ;; "ange-ftp-" prefix for all its advice names, then we could temporarily | |
652 ;; disable all its advices with | |
653 ;; | |
654 ;; (ad-disable-regexp "^ange-ftp-") | |
655 ;; | |
656 ;; and the following call would put that actually into effect: | |
657 ;; | |
658 ;; (ad-activate-regexp "^ange-ftp-") | |
659 ;; | |
660 ;; A saver way would have been to use | |
661 ;; | |
662 ;; (ad-update-regexp "^ange-ftp-") | |
663 ;; | |
664 ;; instead which would have only reactivated currently actively advised | |
665 ;; functions, but not functions that were currently deactivated. All these | |
666 ;; functions can also be called interactively. | |
667 | |
668 ;; A certain piece of advice is considered a match if its name contains a | |
669 ;; match for the regular expression. To enable ange-ftp again we would use | |
670 ;; `ad-enable-regexp' and then activate or update again. | |
671 | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
672 ;; @@ Forward advice, automatic advice activation: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
673 ;; =============================================== |
4110 | 674 ;; Because most Emacs Lisp packages are loaded on demand via an autoload |
675 ;; mechanism it is essential to be able to "forward advise" functions. | |
676 ;; Otherwise, proper advice definition and activation would make it necessary | |
677 ;; to preload every file that defines a certain function before it can be | |
678 ;; advised, which would partly defeat the purpose of the advice mechanism. | |
679 | |
680 ;; In the following, "forward advice" always implies its automatic activation | |
681 ;; once a function gets defined, and not just the accumulation of advice | |
682 ;; information for a possibly undefined function. | |
683 | |
684 ;; Advice implements forward advice mainly via the following: 1) Separation | |
685 ;; of advice definition and activation that makes it possible to accumulate | |
686 ;; advice information without having the original function already defined, | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
687 ;; 2) special versions of the built-in functions `fset/defalias' which check |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
688 ;; for advice information whenever they define a function. If advice |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
689 ;; information was found then the advice will immediately get activated when |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
690 ;; the function gets defined. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
691 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
692 ;; Automatic advice activation means, that whenever a function gets defined |
4110 | 693 ;; with either `defun', `defmacro', `fset' or by loading a byte-compiled |
694 ;; file, and the function has some advice-info stored with it then that | |
695 ;; advice will get activated right away. | |
696 | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
697 ;; @@@ Enabling automatic advice activation: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
698 ;; ========================================= |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
699 ;; Automatic advice activation is enabled by default. It can be disabled by |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
700 ;; doint `M-x ad-stop-advice' and enabled again with `M-x ad-start-advice'. |
4110 | 701 |
702 ;; @@ Caching of advised definitions: | |
703 ;; ================================== | |
704 ;; After an advised definition got constructed it gets cached as part of the | |
705 ;; advised function's advice-info so it can be reused, for example, after an | |
706 ;; intermediate deactivation. Because the advice-info of a function might | |
707 ;; change between the time of caching and reuse a cached definition gets | |
708 ;; a cache-id associated with it so it can be verified whether the cached | |
709 ;; definition is still valid (the main application of this is preactivation | |
710 ;; - see below). | |
711 | |
712 ;; When an advised function gets activated and a verifiable cached definition | |
713 ;; is available, then that definition will be used instead of creating a new | |
714 ;; advised definition from scratch. If you want to make sure that a new | |
715 ;; definition gets constructed then you should use `ad-clear-cache' before you | |
716 ;; activate the advised function. | |
717 | |
718 ;; @@ Preactivation: | |
719 ;; ================= | |
720 ;; Constructing an advised definition is moderately expensive. In a situation | |
721 ;; where one package defines a lot of advised functions it might be | |
722 ;; prohibitively expensive to do all the advised definition construction at | |
723 ;; runtime. Preactivation is a mechanism that allows compile-time construction | |
724 ;; of compiled advised definitions that can be activated cheaply during | |
725 ;; runtime. Preactivation uses the caching mechanism to do that. Here's how it | |
726 ;; works: | |
727 | |
728 ;; When the byte-compiler compiles a `defadvice' that has the `preactivate' | |
729 ;; flag specified, it uses the current original definition of the advised | |
730 ;; function plus the advice specified in this `defadvice' (even if it is | |
731 ;; specified as disabled) and all other currently enabled pieces of advice to | |
732 ;; construct an advised definition and an identifying cache-id and makes them | |
733 ;; part of the `defadvice' expansion which will then be compiled by the | |
734 ;; byte-compiler (to ensure that in a v18 emacs you have to put the | |
735 ;; `defadvice' inside a `defun' to get it compiled and then you have to call | |
736 ;; that compiled `defun' in order to actually execute the `defadvice'). When | |
737 ;; the file with the compiled, preactivating `defadvice' gets loaded the | |
738 ;; precompiled advised definition will be cached on the advised function's | |
739 ;; advice-info. When it gets activated (can be immediately on execution of the | |
740 ;; `defadvice' or any time later) the cache-id gets checked against the | |
741 ;; current state of advice and if it is verified the precompiled definition | |
742 ;; will be used directly (the verification is pretty cheap). If it couldn't get | |
743 ;; verified a new advised definition for that function will be built from | |
744 ;; scratch, hence, the efficiency added by the preactivation mechanism does | |
745 ;; not at all impair the flexibility of the advice mechanism. | |
746 | |
747 ;; MORAL: In order get all the efficiency out of preactivation the advice | |
748 ;; state of an advised function at the time the file with the | |
749 ;; preactivating `defadvice' gets byte-compiled should be exactly | |
750 ;; the same as it will be when the advice of that function gets | |
751 ;; actually activated. If it is not there is a high chance that the | |
752 ;; cache-id will not match and hence a new advised definition will | |
753 ;; have to be constructed at runtime. | |
754 | |
755 ;; Preactivation and forward advice do not contradict each other. It is | |
756 ;; perfectly ok to load a file with a preactivating `defadvice' before the | |
757 ;; original definition of the advised function is available. The constructed | |
758 ;; advised definition will be used once the original function gets defined and | |
759 ;; its advice gets activated. The only constraint is that at the time the | |
760 ;; file with the preactivating `defadvice' got compiled the original function | |
761 ;; definition was available. | |
762 | |
763 ;; TIPS: Here are some indications that a preactivation did not work the way | |
764 ;; you intended it to work: | |
765 ;; - Activation of the advised function takes longer than usual/expected | |
766 ;; - The byte-compiler gets loaded while an advised function gets | |
767 ;; activated | |
768 ;; - `byte-compile' is part of the `features' variable even though you | |
769 ;; did not use the byte-compiler | |
770 ;; Right now advice does not provide an elegant way to find out whether | |
771 ;; and why a preactivation failed. What you can do is to trace the | |
772 ;; function `ad-cache-id-verification-code' (with the function | |
773 ;; `trace-function-background' defined in my trace.el package) before | |
774 ;; any of your advised functions get activated. After they got | |
775 ;; activated check whether all calls to `ad-cache-id-verification-code' | |
776 ;; returned `verified' as a result. Other values indicate why the | |
777 ;; verification failed which should give you enough information to | |
778 ;; fix your preactivation/compile/load/activation sequence. | |
779 | |
26217 | 780 ;; IMPORTANT: There is one case (that I am aware of) that can make |
4110 | 781 ;; preactivation fail, i.e., a preconstructed advised definition that does |
782 ;; NOT match the current state of advice gets used nevertheless. That case | |
783 ;; arises if one package defines a certain piece of advice which gets used | |
26217 | 784 ;; during preactivation, and another package incompatibly redefines that |
4110 | 785 ;; very advice (i.e., same function/class/name), and it is the second advice |
786 ;; that is available when the preconstructed definition gets activated, and | |
26217 | 787 ;; that was the only definition of that advice so far (`ad-add-advice' |
788 ;; catches advice redefinitions and clears the cache in such a case). | |
4110 | 789 ;; Catching that would make the cache verification too expensive. |
790 | |
791 ;; MORAL-II: Redefining somebody else's advice is BAAAAD (to speak with | |
792 ;; George Walker Bush), and why would you redefine your own advice anyway? | |
793 ;; Advice is a mechanism to facilitate function redefinition, not advice | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
794 ;; redefinition (wait until I write Meta-Advice :-). If you really have |
4110 | 795 ;; to undo somebody else's advice try to write a "neutralizing" advice. |
796 | |
797 ;; @@ Advising macros and special forms and other dangerous things: | |
798 ;; ================================================================ | |
799 ;; Look at the corresponding tutorial sections for more information on | |
800 ;; these topics. Here it suffices to point out that the special treatment | |
801 ;; of macros and special forms by the byte-compiler can lead to problems | |
802 ;; when they get advised. Macros can create problems because they get | |
803 ;; expanded at compile time, hence, they might not have all the necessary | |
804 ;; runtime support and such advice cannot be de/activated or changed as | |
805 ;; it is possible for functions. Special forms create problems because they | |
806 ;; have to be advised "into" macros, i.e., an advised special form is a | |
807 ;; implemented as a macro, hence, in most cases the byte-compiler will | |
808 ;; not recognize it as a special form anymore which can lead to very strange | |
809 ;; results. | |
810 ;; | |
811 ;; MORAL: - Only advise macros or special forms when you are absolutely sure | |
812 ;; what you are doing. | |
813 ;; - As a safety measure, always do `ad-deactivate-all' before you | |
814 ;; byte-compile a file to make sure that even if some inconsiderate | |
815 ;; person advised some special forms you'll get proper compilation | |
816 ;; results. After compilation do `ad-activate-all' to get back to | |
817 ;; the previous state. | |
818 | |
819 ;; @@ Adding a piece of advice with `ad-add-advice': | |
820 ;; ================================================= | |
821 ;; The non-interactive function `ad-add-advice' can be used to add a piece of | |
822 ;; advice to some function without using `defadvice'. This is useful if advice | |
823 ;; has to be added somewhere by a function (also look at `ad-make-advice'). | |
824 | |
825 ;; @@ Activation/deactivation advices, file load hooks: | |
826 ;; ==================================================== | |
827 ;; There are two special classes of advice called `activation' and | |
828 ;; `deactivation'. The body forms of these advices are not included into the | |
829 ;; advised definition of a function, rather they are assembled into a hook | |
830 ;; form which will be evaluated whenever the advice-info of the advised | |
831 ;; function gets activated or deactivated. One application of this mechanism | |
832 ;; is to define file load hooks for files that do not provide such hooks | |
833 ;; (v19s already come with a general file-load-hook mechanism, v18s don't). | |
834 ;; For example, suppose you want to print a message whenever `file-x' gets | |
835 ;; loaded, and suppose the last function defined in `file-x' is | |
836 ;; `file-x-last-fn'. Then we can define the following advice: | |
837 ;; | |
838 ;; (defadvice file-x-last-fn (activation file-x-load-hook) | |
839 ;; "Executed whenever file-x is loaded" | |
840 ;; (if load-in-progress (message "Loaded file-x"))) | |
841 ;; | |
842 ;; This will constitute a forward advice for function `file-x-last-fn' which | |
843 ;; will get activated when `file-x' is loaded (only if forward advice is | |
844 ;; enabled of course). Because there are no "real" pieces of advice | |
845 ;; available for it, its definition will not be changed, but the activation | |
846 ;; advice will be run during its activation which is equivalent to having a | |
847 ;; file load hook for `file-x'. | |
848 | |
849 ;; @@ Summary of main advice concepts: | |
850 ;; =================================== | |
851 ;; - Definition: | |
852 ;; A piece of advice gets defined with `defadvice' and added to the | |
853 ;; `advice-info' property of a function. | |
854 ;; - Enablement: | |
855 ;; Every piece of advice has an enablement flag associated with it. Only | |
856 ;; enabled advices are considered during construction of an advised | |
857 ;; definition. | |
858 ;; - Activation: | |
859 ;; Redefine an advised function with its advised definition. Constructs | |
860 ;; an advised definition from scratch if no verifiable cached advised | |
861 ;; definition is available and caches it. | |
862 ;; - Deactivation: | |
863 ;; Back-define an advised function to its original definition. | |
864 ;; - Update: | |
26217 | 865 ;; Reactivate an advised function but only if its advice is currently |
4110 | 866 ;; active. This can be used to bring all currently advised function up |
867 ;; to date with the current state of advice without also activating | |
868 ;; currently deactivated functions. | |
869 ;; - Caching: | |
870 ;; Is the saving of an advised definition and an identifying cache-id so | |
871 ;; it can be reused, for example, for activation after deactivation. | |
872 ;; - Preactivation: | |
873 ;; Is the construction of an advised definition according to the current | |
874 ;; state of advice during byte-compilation of a file with a preactivating | |
875 ;; `defadvice'. That advised definition can then rather cheaply be used | |
876 ;; during activation without having to construct an advised definition | |
877 ;; from scratch at runtime. | |
878 | |
879 ;; @@ Summary of interactive advice manipulation functions: | |
880 ;; ======================================================== | |
881 ;; The following interactive functions can be used to manipulate the state | |
882 ;; of advised functions (all of them support completion on function names, | |
883 ;; advice classes and advice names): | |
884 | |
885 ;; - ad-activate to activate the advice of a FUNCTION | |
886 ;; - ad-deactivate to deactivate the advice of a FUNCTION | |
887 ;; - ad-update to activate the advice of a FUNCTION unless it was not | |
888 ;; yet activated or is currently deactivated. | |
26217 | 889 ;; - ad-unadvise deactivates a FUNCTION and removes all of its advice |
4110 | 890 ;; information, hence, it cannot be activated again |
891 ;; - ad-recover tries to redefine a FUNCTION to its original definition and | |
892 ;; discards all advice information (a low-level `ad-unadvise'). | |
893 ;; Use only in emergencies. | |
894 | |
895 ;; - ad-remove-advice removes a particular piece of advice of a FUNCTION. | |
896 ;; You still have to do call `ad-activate' or `ad-update' to | |
897 ;; activate the new state of advice. | |
898 ;; - ad-enable-advice enables a particular piece of advice of a FUNCTION. | |
899 ;; - ad-disable-advice disables a particular piece of advice of a FUNCTION. | |
900 ;; - ad-enable-regexp maps over all currently advised functions and enables | |
901 ;; every advice whose name contains a match for a regular | |
902 ;; expression. | |
903 ;; - ad-disable-regexp disables matching advices. | |
904 | |
905 ;; - ad-activate-regexp activates all advised function with a matching advice | |
906 ;; - ad-deactivate-regexp deactivates all advised function with matching advice | |
907 ;; - ad-update-regexp updates all advised function with a matching advice | |
908 ;; - ad-activate-all activates all advised functions | |
909 ;; - ad-deactivate-all deactivates all advised functions | |
910 ;; - ad-update-all updates all advised functions | |
911 ;; - ad-unadvise-all unadvises all advised functions | |
912 ;; - ad-recover-all recovers all advised functions | |
913 | |
914 ;; - ad-compile byte-compiles a function/macro if it is compilable. | |
915 | |
916 ;; @@ Summary of forms with special meanings when used within an advice: | |
917 ;; ===================================================================== | |
918 ;; ad-return-value name of the return value variable (get/settable) | |
919 ;; ad-subr-args name of &rest argument variable used for advised | |
920 ;; subrs whose actual argument list cannot be | |
921 ;; determined (get/settable) | |
922 ;; (ad-get-arg <pos>), (ad-get-args <pos>), | |
923 ;; (ad-set-arg <pos> <value>), (ad-set-args <pos> <value-list>) | |
924 ;; argument access text macros to get/set the values of | |
925 ;; actual arguments at a certain position | |
926 ;; ad-arg-bindings text macro that returns the actual names, values | |
927 ;; and types of the arguments as a list of bindings. The | |
928 ;; order of the bindings corresponds to the order of the | |
929 ;; arguments. The individual fields of every binding (name, | |
930 ;; value and type) can be accessed with the function | |
931 ;; `ad-arg-binding-field' (see example above). | |
932 ;; ad-do-it text macro that identifies the place where the original | |
933 ;; or wrapped definition should go in an around advice | |
934 | |
935 | |
936 ;; @ Foo games: An advice tutorial | |
937 ;; =============================== | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
938 ;; The following tutorial was created in Emacs 18.59. Left-justified |
4110 | 939 ;; s-expressions are input forms followed by one or more result forms. |
940 ;; First we have to start the advice magic: | |
941 ;; | |
942 ;; (ad-start-advice) | |
943 ;; nil | |
944 ;; | |
945 ;; We start by defining an innocent looking function `foo' that simply | |
946 ;; adds 1 to its argument X: | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
947 ;; |
4110 | 948 ;; (defun foo (x) |
949 ;; "Add 1 to X." | |
950 ;; (1+ x)) | |
951 ;; foo | |
952 ;; | |
953 ;; (foo 3) | |
954 ;; 4 | |
955 ;; | |
956 ;; @@ Defining a simple piece of advice: | |
957 ;; ===================================== | |
958 ;; Now let's define the first piece of advice for `foo'. To do that we | |
959 ;; use the macro `defadvice' which takes a function name, a list of advice | |
960 ;; specifiers and a list of body forms as arguments. The first element of | |
961 ;; the advice specifiers is the class of the advice, the second is its name, | |
962 ;; the third its position and the rest are some flags. The class of our | |
963 ;; first advice is `before', its name is `fg-add2', its position among the | |
964 ;; currently defined before advices (none so far) is `first', and the advice | |
965 ;; will be `activate'ed immediately. Advice names are global symbols, hence, | |
966 ;; the name space conventions used for function names should be applied. All | |
967 ;; advice names in this tutorial will be prefixed with `fg' for `Foo Games' | |
968 ;; (because everybody has the right to be inconsistent all the function names | |
969 ;; used in this tutorial do NOT follow this convention). | |
970 ;; | |
971 ;; In the body of an advice we can refer to the argument variables of the | |
972 ;; original function by name. Here we add 1 to X so the effect of calling | |
973 ;; `foo' will be to actually add 2. All of the advice definitions below only | |
974 ;; have one body form for simplicity, but there is no restriction to that | |
975 ;; extent. Every piece of advice can have a documentation string which will | |
976 ;; be combined with the documentation of the original function. | |
977 ;; | |
978 ;; (defadvice foo (before fg-add2 first activate) | |
979 ;; "Add 2 to X." | |
980 ;; (setq x (1+ x))) | |
981 ;; foo | |
982 ;; | |
983 ;; (foo 3) | |
984 ;; 5 | |
985 ;; | |
986 ;; @@ Specifying the position of an advice: | |
987 ;; ======================================== | |
988 ;; Now we define the second before advice which will cancel the effect of | |
989 ;; the previous advice. This time we specify the position as 0 which is | |
990 ;; equivalent to `first'. A number can be used to specify the zero-based | |
991 ;; position of an advice among the list of advices in the same class. This | |
992 ;; time we already have one before advice hence the position specification | |
993 ;; actually has an effect. So, after the following definition the position | |
994 ;; of the previous advice will be 1 even though we specified it with `first' | |
995 ;; above, the reason for this is that the position argument is relative to | |
996 ;; the currently defined pieces of advice which by now has changed. | |
997 ;; | |
998 ;; (defadvice foo (before fg-cancel-add2 0 activate) | |
999 ;; "Again only add 1 to X." | |
1000 ;; (setq x (1- x))) | |
1001 ;; foo | |
1002 ;; | |
1003 ;; (foo 3) | |
1004 ;; 4 | |
1005 ;; | |
1006 ;; @@ Redefining a piece of advice: | |
1007 ;; ================================ | |
1008 ;; Now we define an advice with the same class and same name but with a | |
1009 ;; different position. Defining an advice in a class in which an advice with | |
1010 ;; that name already exists is interpreted as a redefinition of that | |
1011 ;; particular advice, in which case the position argument will be ignored | |
1012 ;; and the previous position of the redefined piece of advice is used. | |
1013 ;; Advice flags can be specified with non-ambiguous initial substrings, hence, | |
1014 ;; from now on we'll use `act' instead of the verbose `activate'. | |
1015 ;; | |
1016 ;; (defadvice foo (before fg-cancel-add2 last act) | |
1017 ;; "Again only add 1 to X." | |
1018 ;; (setq x (1- x))) | |
1019 ;; foo | |
1020 ;; | |
1021 ;; @@ Assembly of advised documentation: | |
1022 ;; ===================================== | |
1023 ;; The documentation strings of the various pieces of advice are assembled | |
1024 ;; in order which shows that advice `fg-cancel-add2' is still the first | |
1025 ;; `before' advice even though we specified position `last' above: | |
1026 ;; | |
1027 ;; (documentation 'foo) | |
1028 ;; "Add 1 to X. | |
1029 ;; | |
1030 ;; This function is advised with the following advice(s): | |
1031 ;; | |
1032 ;; fg-cancel-add2 (before): | |
1033 ;; Again only add 1 to X. | |
1034 ;; | |
1035 ;; fg-add2 (before): | |
1036 ;; Add 2 to X." | |
1037 ;; | |
1038 ;; @@ Advising interactive behavior: | |
1039 ;; ================================= | |
1040 ;; We can make a function interactive (or change its interactive behavior) | |
1041 ;; by specifying an interactive form in one of the before or around | |
1042 ;; advices (there could also be body forms in this advice). The particular | |
1043 ;; definition always assigns 5 as an argument to X which gives us 6 as a | |
1044 ;; result when we call foo interactively: | |
1045 ;; | |
1046 ;; (defadvice foo (before fg-inter last act) | |
1047 ;; "Use 5 as argument when called interactively." | |
1048 ;; (interactive (list 5))) | |
1049 ;; foo | |
1050 ;; | |
1051 ;; (call-interactively 'foo) | |
1052 ;; 6 | |
1053 ;; | |
1054 ;; If more than one advice have an interactive declaration, then the one of | |
1055 ;; the advice with the smallest position will be used (before advices go | |
1056 ;; before around and after advices), hence, the declaration below does | |
1057 ;; not have any effect: | |
1058 ;; | |
1059 ;; (defadvice foo (before fg-inter2 last act) | |
1060 ;; (interactive (list 6))) | |
1061 ;; foo | |
1062 ;; | |
1063 ;; (call-interactively 'foo) | |
1064 ;; 6 | |
1065 ;; | |
26217 | 1066 ;; Let's have a look at what the definition of `foo' looks like now |
4110 | 1067 ;; (indentation added by hand for legibility): |
1068 ;; | |
1069 ;; (symbol-function 'foo) | |
1070 ;; (lambda (x) | |
1071 ;; "$ad-doc: foo$" | |
1072 ;; (interactive (list 5)) | |
26217 | 1073 ;; (let (ad-return-value) |
1074 ;; (setq x (1- x)) | |
1075 ;; (setq x (1+ x)) | |
1076 ;; (setq ad-return-value (ad-Orig-foo x)) | |
4110 | 1077 ;; ad-return-value)) |
1078 ;; | |
1079 ;; @@ Around advices: | |
1080 ;; ================== | |
1081 ;; Now we'll try some `around' advices. An around advice is a wrapper around | |
1082 ;; the original definition. It can shadow or establish bindings for the | |
1083 ;; original definition, and it can look at and manipulate the value returned | |
1084 ;; by the original function. The position of the special keyword `ad-do-it' | |
1085 ;; specifies where the code of the original function will be executed. The | |
1086 ;; keyword can appear multiple times which will result in multiple calls of | |
1087 ;; the original function in the resulting advised code. Note, that if we don't | |
26217 | 1088 ;; specify a position argument (i.e., `first', `last' or a number), then |
4110 | 1089 ;; `first' (or 0) is the default): |
1090 ;; | |
1091 ;; (defadvice foo (around fg-times-2 act) | |
1092 ;; "First double X." | |
1093 ;; (let ((x (* x 2))) | |
1094 ;; ad-do-it)) | |
1095 ;; foo | |
1096 ;; | |
1097 ;; (foo 3) | |
1098 ;; 7 | |
1099 ;; | |
1100 ;; Around advices are assembled like onion skins where the around advice | |
1101 ;; with position 0 is the outermost skin and the advice at the last position | |
1102 ;; is the innermost skin which is directly wrapped around the call of the | |
1103 ;; original definition of the function. Hence, after the next `defadvice' we | |
1104 ;; will first multiply X by 2 then add 1 and then call the original | |
1105 ;; definition (i.e., add 1 again): | |
1106 ;; | |
1107 ;; (defadvice foo (around fg-add-1 last act) | |
1108 ;; "Add 1 to X." | |
1109 ;; (let ((x (1+ x))) | |
1110 ;; ad-do-it)) | |
1111 ;; foo | |
1112 ;; | |
1113 ;; (foo 3) | |
1114 ;; 8 | |
1115 ;; | |
1116 ;; Again, let's see what the definition of `foo' looks like so far: | |
1117 ;; | |
1118 ;; (symbol-function 'foo) | |
26217 | 1119 ;; (lambda (x) |
4110 | 1120 ;; "$ad-doc: foo$" |
26217 | 1121 ;; (interactive (list 5)) |
1122 ;; (let (ad-return-value) | |
1123 ;; (setq x (1- x)) | |
1124 ;; (setq x (1+ x)) | |
1125 ;; (let ((x (* x 2))) | |
1126 ;; (let ((x (1+ x))) | |
1127 ;; (setq ad-return-value (ad-Orig-foo x)))) | |
4110 | 1128 ;; ad-return-value)) |
1129 ;; | |
1130 ;; @@ Controlling advice activation: | |
1131 ;; ================================= | |
1132 ;; In every `defadvice' so far we have used the flag `activate' to activate | |
1133 ;; the advice immediately after its definition, and that's what we want in | |
1134 ;; most cases. However, if we define multiple pieces of advice for a single | |
1135 ;; function then activating every advice immediately is inefficient. A | |
1136 ;; better way to do this is to only activate the last defined advice. | |
1137 ;; For example: | |
1138 ;; | |
1139 ;; (defadvice foo (after fg-times-x) | |
1140 ;; "Multiply the result with X." | |
1141 ;; (setq ad-return-value (* ad-return-value x))) | |
1142 ;; foo | |
1143 ;; | |
1144 ;; This still yields the same result as before: | |
1145 ;; (foo 3) | |
1146 ;; 8 | |
1147 ;; | |
1148 ;; Now we define another advice and activate which will also activate the | |
1149 ;; previous advice `fg-times-x'. Note the use of the special variable | |
1150 ;; `ad-return-value' in the body of the advice which is set to the result of | |
1151 ;; the original function. If we change its value then the value returned by | |
1152 ;; the advised function will be changed accordingly: | |
1153 ;; | |
1154 ;; (defadvice foo (after fg-times-x-again act) | |
1155 ;; "Again multiply the result with X." | |
1156 ;; (setq ad-return-value (* ad-return-value x))) | |
1157 ;; foo | |
1158 ;; | |
1159 ;; Now the advices have an effect: | |
1160 ;; | |
1161 ;; (foo 3) | |
1162 ;; 72 | |
1163 ;; | |
1164 ;; @@ Protecting advice execution: | |
1165 ;; =============================== | |
26217 | 1166 ;; Once in a while we define an advice to perform some cleanup action, |
4110 | 1167 ;; for example: |
1168 ;; | |
1169 ;; (defadvice foo (after fg-cleanup last act) | |
1170 ;; "Do some cleanup." | |
1171 ;; (print "Let's clean up now!")) | |
1172 ;; foo | |
1173 ;; | |
1174 ;; However, in case of an error the cleanup won't be performed: | |
1175 ;; | |
1176 ;; (condition-case error | |
1177 ;; (foo t) | |
1178 ;; (error 'error-in-foo)) | |
1179 ;; error-in-foo | |
1180 ;; | |
1181 ;; To make sure a certain piece of advice gets executed even if some error or | |
1182 ;; non-local exit occurred in any preceding code, we can protect it by using | |
1183 ;; the `protect' keyword. (if any of the around advices is protected then the | |
1184 ;; whole around advice onion will be protected): | |
1185 ;; | |
1186 ;; (defadvice foo (after fg-cleanup prot act) | |
1187 ;; "Do some protected cleanup." | |
1188 ;; (print "Let's clean up now!")) | |
1189 ;; foo | |
1190 ;; | |
1191 ;; Now the cleanup form will be executed even in case of an error: | |
1192 ;; | |
1193 ;; (condition-case error | |
1194 ;; (foo t) | |
1195 ;; (error 'error-in-foo)) | |
1196 ;; "Let's clean up now!" | |
1197 ;; error-in-foo | |
1198 ;; | |
1199 ;; Again, let's see what `foo' looks like: | |
1200 ;; | |
1201 ;; (symbol-function 'foo) | |
26217 | 1202 ;; (lambda (x) |
4110 | 1203 ;; "$ad-doc: foo$" |
26217 | 1204 ;; (interactive (list 5)) |
1205 ;; (let (ad-return-value) | |
1206 ;; (unwind-protect | |
1207 ;; (progn (setq x (1- x)) | |
1208 ;; (setq x (1+ x)) | |
1209 ;; (let ((x (* x 2))) | |
1210 ;; (let ((x (1+ x))) | |
1211 ;; (setq ad-return-value (ad-Orig-foo x)))) | |
1212 ;; (setq ad-return-value (* ad-return-value x)) | |
1213 ;; (setq ad-return-value (* ad-return-value x))) | |
1214 ;; (print "Let's clean up now!")) | |
4110 | 1215 ;; ad-return-value)) |
1216 ;; | |
1217 ;; @@ Compilation of advised definitions: | |
1218 ;; ====================================== | |
1219 ;; Finally, we can specify the `compile' keyword in a `defadvice' to say | |
1220 ;; that we want the resulting advised function to be byte-compiled | |
1221 ;; (`compile' will be ignored unless we also specified `activate'): | |
1222 ;; | |
1223 ;; (defadvice foo (after fg-cleanup prot act comp) | |
1224 ;; "Do some protected cleanup." | |
1225 ;; (print "Let's clean up now!")) | |
1226 ;; foo | |
1227 ;; | |
1228 ;; Now `foo' is byte-compiled: | |
1229 ;; | |
1230 ;; (symbol-function 'foo) | |
26217 | 1231 ;; (lambda (x) |
4110 | 1232 ;; "$ad-doc: foo$" |
26217 | 1233 ;; (interactive (byte-code "....." [5] 1)) |
4110 | 1234 ;; (byte-code "....." [ad-return-value x nil ((byte-code "....." [print "Let's clean up now!"] 2)) * 2 ad-Orig-foo] 6)) |
1235 ;; | |
1236 ;; (foo 3) | |
1237 ;; "Let's clean up now!" | |
1238 ;; 72 | |
1239 ;; | |
1240 ;; @@ Enabling and disabling pieces of advice: | |
1241 ;; =========================================== | |
1242 ;; Once in a while it is desirable to temporarily disable a piece of advice | |
1243 ;; so that it won't be considered during activation, for example, if two | |
1244 ;; different packages advise the same function and one wants to temporarily | |
1245 ;; neutralize the effect of the advice of one of the packages. | |
1246 ;; | |
1247 ;; The following disables the after advice `fg-times-x' in the function `foo'. | |
1248 ;; All that does is to change a flag for this particular advice. All the | |
1249 ;; other information defining it will be left unchanged (e.g., its relative | |
1250 ;; position in this advice class, etc.). | |
1251 ;; | |
1252 ;; (ad-disable-advice 'foo 'after 'fg-times-x) | |
1253 ;; nil | |
1254 ;; | |
1255 ;; For this to have an effect we have to activate `foo': | |
1256 ;; | |
1257 ;; (ad-activate 'foo) | |
1258 ;; foo | |
1259 ;; | |
1260 ;; (foo 3) | |
1261 ;; "Let's clean up now!" | |
1262 ;; 24 | |
1263 ;; | |
1264 ;; If we want to disable all multiplication advices in `foo' we can use a | |
1265 ;; regular expression that matches the names of such advices. Actually, any | |
1266 ;; advice name that contains a match for the regular expression will be | |
1267 ;; called a match. A special advice class `any' can be used to consider | |
1268 ;; all advice classes: | |
1269 ;; | |
1270 ;; (ad-disable-advice 'foo 'any "^fg-.*times") | |
1271 ;; nil | |
1272 ;; | |
1273 ;; (ad-activate 'foo) | |
1274 ;; foo | |
1275 ;; | |
1276 ;; (foo 3) | |
1277 ;; "Let's clean up now!" | |
1278 ;; 5 | |
1279 ;; | |
1280 ;; To enable the disabled advice we could use either `ad-enable-advice' | |
1281 ;; similar to `ad-disable-advice', or as an alternative `ad-enable-regexp' | |
1282 ;; which will enable matching advices in ALL currently advised functions. | |
1283 ;; Hence, this can be used to dis/enable advices made by a particular | |
1284 ;; package to a set of functions as long as that package obeys standard | |
1285 ;; advice name conventions. We prefixed all advice names with `fg-', hence | |
1286 ;; the following will do the trick (`ad-enable-regexp' returns the number | |
1287 ;; of matched advices): | |
1288 ;; | |
1289 ;; (ad-enable-regexp "^fg-") | |
1290 ;; 9 | |
1291 ;; | |
1292 ;; The following will activate all currently active advised functions that | |
1293 ;; contain some advice matched by the regular expression. This is a save | |
1294 ;; way to update the activation of advised functions whose advice changed | |
1295 ;; in some way or other without accidentally also activating currently | |
1296 ;; deactivated functions: | |
1297 ;; | |
1298 ;; (ad-update-regexp "^fg-") | |
1299 ;; nil | |
1300 ;; | |
1301 ;; (foo 3) | |
1302 ;; "Let's clean up now!" | |
1303 ;; 72 | |
1304 ;; | |
1305 ;; Another use for the dis/enablement mechanism is to define a piece of advice | |
1306 ;; and keep it "dormant" until a particular condition is satisfied, i.e., until | |
1307 ;; then the advice will not be used during activation. The `disable' flag lets | |
1308 ;; one do that with `defadvice': | |
1309 ;; | |
1310 ;; (defadvice foo (before fg-1-more dis) | |
1311 ;; "Add yet 1 more." | |
1312 ;; (setq x (1+ x))) | |
1313 ;; foo | |
1314 ;; | |
1315 ;; (ad-activate 'foo) | |
1316 ;; foo | |
1317 ;; | |
1318 ;; (foo 3) | |
1319 ;; "Let's clean up now!" | |
1320 ;; 72 | |
1321 ;; | |
1322 ;; (ad-enable-advice 'foo 'before 'fg-1-more) | |
1323 ;; nil | |
1324 ;; | |
1325 ;; (ad-activate 'foo) | |
1326 ;; foo | |
1327 ;; | |
1328 ;; (foo 3) | |
1329 ;; "Let's clean up now!" | |
1330 ;; 160 | |
1331 ;; | |
1332 ;; @@ Caching: | |
1333 ;; =========== | |
1334 ;; Advised definitions get cached to allow efficient activation/deactivation | |
1335 ;; without having to reconstruct them if nothing in the advice-info of a | |
1336 ;; function has changed. The following idiom can be used to temporarily | |
1337 ;; deactivate functions that have a piece of advice defined by a certain | |
1338 ;; package (we save the old definition to check out caching): | |
1339 ;; | |
1340 ;; (setq old-definition (symbol-function 'foo)) | |
1341 ;; (lambda (x) ....) | |
1342 ;; | |
1343 ;; (ad-deactivate-regexp "^fg-") | |
1344 ;; nil | |
1345 ;; | |
1346 ;; (foo 3) | |
1347 ;; 4 | |
1348 ;; | |
1349 ;; (ad-activate-regexp "^fg-") | |
1350 ;; nil | |
1351 ;; | |
1352 ;; (eq old-definition (symbol-function 'foo)) | |
1353 ;; t | |
1354 ;; | |
1355 ;; (foo 3) | |
1356 ;; "Let's clean up now!" | |
1357 ;; 160 | |
1358 ;; | |
1359 ;; @@ Forward advice: | |
1360 ;; ================== | |
1361 ;; To enable automatic activation of forward advice we first have to set | |
1362 ;; `ad-activate-on-definition' to t and restart advice: | |
1363 ;; | |
1364 ;; (setq ad-activate-on-definition t) | |
1365 ;; t | |
1366 ;; | |
1367 ;; (ad-start-advice) | |
1368 ;; (ad-activate-defined-function) | |
1369 ;; | |
1370 ;; Let's define a piece of advice for an undefined function: | |
1371 ;; | |
1372 ;; (defadvice bar (before fg-sub-1-more act) | |
1373 ;; "Subtract one more from X." | |
1374 ;; (setq x (1- x))) | |
1375 ;; bar | |
1376 ;; | |
1377 ;; `bar' is not yet defined: | |
1378 ;; (fboundp 'bar) | |
1379 ;; nil | |
1380 ;; | |
1381 ;; Now we define it and the forward advice will get activated (only because | |
1382 ;; `ad-activate-on-definition' was t when we started advice above with | |
1383 ;; `ad-start-advice'): | |
1384 ;; | |
1385 ;; (defun bar (x) | |
1386 ;; "Subtract 1 from X." | |
1387 ;; (1- x)) | |
1388 ;; bar | |
1389 ;; | |
1390 ;; (bar 4) | |
1391 ;; 2 | |
1392 ;; | |
1393 ;; Redefinition will activate any available advice if the value of | |
1394 ;; `ad-redefinition-action' is either `warn', `accept' or `discard': | |
1395 ;; | |
1396 ;; (defun bar (x) | |
1397 ;; "Subtract 2 from X." | |
1398 ;; (- x 2)) | |
1399 ;; bar | |
1400 ;; | |
1401 ;; (bar 4) | |
1402 ;; 1 | |
1403 ;; | |
1404 ;; @@ Preactivation: | |
1405 ;; ================= | |
1406 ;; Constructing advised definitions is moderately expensive, hence, it is | |
1407 ;; desirable to have a way to construct them at byte-compile time. | |
1408 ;; Preactivation is a mechanism that allows one to do that. | |
1409 ;; | |
1410 ;; (defun fie (x) | |
1411 ;; "Multiply X by 2." | |
1412 ;; (* x 2)) | |
1413 ;; fie | |
1414 ;; | |
1415 ;; (defadvice fie (before fg-times-4 preact) | |
1416 ;; "Multiply X by 4." | |
1417 ;; (setq x (* x 2))) | |
1418 ;; fie | |
1419 ;; | |
1420 ;; This advice did not affect `fie'... | |
1421 ;; | |
1422 ;; (fie 2) | |
1423 ;; 4 | |
1424 ;; | |
1425 ;; ...but it constructed a cached definition that will be used once `fie' gets | |
1426 ;; activated as long as its current advice state is the same as it was during | |
1427 ;; preactivation: | |
1428 ;; | |
1429 ;; (setq cached-definition (ad-get-cache-definition 'fie)) | |
1430 ;; (lambda (x) ....) | |
1431 ;; | |
1432 ;; (ad-activate 'fie) | |
1433 ;; fie | |
1434 ;; | |
1435 ;; (eq cached-definition (symbol-function 'fie)) | |
1436 ;; t | |
1437 ;; | |
1438 ;; (fie 2) | |
1439 ;; 8 | |
1440 ;; | |
11035 | 1441 ;; If you put a preactivating `defadvice' into a Lisp file that gets byte- |
4110 | 1442 ;; compiled then the constructed advised definition will get compiled by |
1443 ;; the byte-compiler. For that to occur in a v18 emacs you have to put the | |
1444 ;; `defadvice' inside a `defun' because the v18 compiler does not compile | |
1445 ;; top-level forms other than `defun' or `defmacro', for example, | |
1446 ;; | |
1447 ;; (defun fg-defadvice-fum () | |
1448 ;; (defadvice fum (before fg-times-4 preact act) | |
1449 ;; "Multiply X by 4." | |
1450 ;; (setq x (* x 2)))) | |
1451 ;; fg-defadvice-fum | |
1452 ;; | |
1453 ;; So far, no `defadvice' for `fum' got executed, but when we compile | |
1454 ;; `fg-defadvice-fum' the `defadvice' will be expanded by the byte compiler. | |
1455 ;; In order for preactivation to be effective we have to have a proper | |
1456 ;; definition of `fum' around at preactivation time, hence, we define it now: | |
1457 ;; | |
1458 ;; (defun fum (x) | |
1459 ;; "Multiply X by 2." | |
1460 ;; (* x 2)) | |
1461 ;; fum | |
1462 ;; | |
1463 ;; Now we compile the defining function which will construct an advised | |
1464 ;; definition during expansion of the `defadvice', compile it and store it | |
1465 ;; as part of the compiled `fg-defadvice-fum': | |
1466 ;; | |
1467 ;; (ad-compile-function 'fg-defadvice-fum) | |
1468 ;; (lambda nil (byte-code ...)) | |
1469 ;; | |
1470 ;; `fum' is still completely unaffected: | |
1471 ;; | |
1472 ;; (fum 2) | |
1473 ;; 4 | |
1474 ;; | |
1475 ;; (ad-get-advice-info 'fum) | |
1476 ;; nil | |
1477 ;; | |
1478 ;; (fg-defadvice-fum) | |
1479 ;; fum | |
1480 ;; | |
1481 ;; Now the advised version of `fum' is compiled because the compiled definition | |
1482 ;; constructed during preactivation was used, even though we did not specify | |
1483 ;; the `compile' flag: | |
1484 ;; | |
1485 ;; (symbol-function 'fum) | |
26217 | 1486 ;; (lambda (x) |
4110 | 1487 ;; "$ad-doc: fum$" |
1488 ;; (byte-code "....." [ad-return-value x nil * 2 ad-Orig-fum] 4)) | |
1489 ;; | |
1490 ;; (fum 2) | |
1491 ;; 8 | |
1492 ;; | |
1493 ;; A preactivated definition will only be used if it matches the current | |
1494 ;; function definition and advice information. If it does not match it | |
1495 ;; will simply be discarded and a new advised definition will be constructed | |
1496 ;; from scratch. For example, let's first remove all advice-info for `fum': | |
1497 ;; | |
1498 ;; (ad-unadvise 'fum) | |
1499 ;; (("fie") ("bar") ("foo") ...) | |
1500 ;; | |
1501 ;; And now define a new piece of advice: | |
1502 ;; | |
1503 ;; (defadvice fum (before fg-interactive act) | |
1504 ;; "Make fum interactive." | |
1505 ;; (interactive "nEnter x: ")) | |
1506 ;; fum | |
1507 ;; | |
1508 ;; When we now try to use a preactivation it will not be used because the | |
1509 ;; current advice state is different from the one at preactivation time. This | |
1510 ;; is no tragedy, everything will work as expected just not as efficient, | |
1511 ;; because a new advised definition has to be constructed from scratch: | |
1512 ;; | |
1513 ;; (fg-defadvice-fum) | |
1514 ;; fum | |
1515 ;; | |
1516 ;; A new uncompiled advised definition got constructed: | |
1517 ;; | |
1518 ;; (ad-compiled-p (symbol-function 'fum)) | |
1519 ;; nil | |
1520 ;; | |
1521 ;; (fum 2) | |
1522 ;; 8 | |
1523 ;; | |
1524 ;; MORAL: To get all the efficiency out of preactivation the function | |
1525 ;; definition and advice state at preactivation time must be the same as the | |
1526 ;; state at activation time. Preactivation does work with forward advice, all | |
1527 ;; that's necessary is that the definition of the forward advised function is | |
1528 ;; available when the `defadvice' with the preactivation gets compiled. | |
1529 ;; | |
1530 ;; @@ Portable argument access: | |
1531 ;; ============================ | |
1532 ;; So far, we always used the actual argument variable names to access an | |
1533 ;; argument in a piece of advice. For many advice applications this is | |
1534 ;; perfectly ok and keeps advices simple. However, it decreases portability | |
1535 ;; of advices because it assumes specific argument variable names. For example, | |
1536 ;; if one advises a subr such as `eval-region' which then gets redefined by | |
1537 ;; some package (e.g., edebug) into a function with different argument names, | |
1538 ;; then a piece of advice written for `eval-region' that was written with | |
1539 ;; the subr arguments in mind will break. Similar situations arise when one | |
1540 ;; switches between major Emacs versions, e.g., certain subrs in v18 are | |
1541 ;; functions in v19 and vice versa. Also, in v19s subr argument lists | |
1542 ;; are available and will be used, while they are not available in v18. | |
1543 ;; | |
1544 ;; Argument access text macros allow one to access arguments of an advised | |
1545 ;; function in a portable way without having to worry about all these | |
1546 ;; possibilities. These macros will be translated into the proper access forms | |
1547 ;; at activation time, hence, argument access will be as efficient as if | |
1548 ;; the arguments had been used directly in the definition of the advice. | |
1549 ;; | |
1550 ;; (defun fuu (x y z) | |
1551 ;; "Add 3 numbers." | |
1552 ;; (+ x y z)) | |
1553 ;; fuu | |
1554 ;; | |
1555 ;; (fuu 1 1 1) | |
1556 ;; 3 | |
1557 ;; | |
1558 ;; Argument access macros specify actual arguments at a certain position. | |
1559 ;; Position 0 access the first actual argument, position 1 the second etc. | |
1560 ;; For example, the following advice adds 1 to each of the 3 arguments: | |
1561 ;; | |
1562 ;; (defadvice fuu (before fg-add-1-to-all act) | |
1563 ;; "Adds 1 to all arguments." | |
1564 ;; (ad-set-arg 0 (1+ (ad-get-arg 0))) | |
1565 ;; (ad-set-arg 1 (1+ (ad-get-arg 1))) | |
1566 ;; (ad-set-arg 2 (1+ (ad-get-arg 2)))) | |
1567 ;; fuu | |
1568 ;; | |
1569 ;; (fuu 1 1 1) | |
1570 ;; 6 | |
1571 ;; | |
1572 ;; Now suppose somebody redefines `fuu' with a rest argument. Our advice | |
1573 ;; will still work because we used access macros (note, that automatic | |
1574 ;; advice activation is still in effect, hence, the redefinition of `fuu' | |
1575 ;; will automatically activate all its advice): | |
1576 ;; | |
1577 ;; (defun fuu (&rest numbers) | |
1578 ;; "Add NUMBERS." | |
1579 ;; (apply '+ numbers)) | |
1580 ;; fuu | |
1581 ;; | |
1582 ;; (fuu 1 1 1) | |
1583 ;; 6 | |
1584 ;; | |
1585 ;; (fuu 1 1 1 1 1 1) | |
1586 ;; 9 | |
1587 ;; | |
1588 ;; What's important to notice is that argument access macros access actual | |
1589 ;; arguments regardless of how they got distributed onto argument variables. | |
1590 ;; In Emacs Lisp the semantics of an actual argument is determined purely | |
1591 ;; by position, hence, as long as nobody changes the semantics of what a | |
1592 ;; certain actual argument at a certain position means the access macros | |
1593 ;; will do the right thing. | |
1594 ;; | |
1595 ;; Because of &rest arguments we need a second kind of access macro that | |
1596 ;; can access all actual arguments starting from a certain position: | |
1597 ;; | |
1598 ;; (defadvice fuu (before fg-print-args act) | |
1599 ;; "Print all arguments." | |
1600 ;; (print (ad-get-args 0))) | |
1601 ;; fuu | |
1602 ;; | |
1603 ;; (fuu 1 2 3 4 5) | |
1604 ;; (1 2 3 4 5) | |
1605 ;; 18 | |
1606 ;; | |
1607 ;; (defadvice fuu (before fg-set-args act) | |
1608 ;; "Swaps 2nd and 3rd arg and discards all the rest." | |
1609 ;; (ad-set-args 1 (list (ad-get-arg 2) (ad-get-arg 1)))) | |
1610 ;; fuu | |
1611 ;; | |
1612 ;; (fuu 1 2 3 4 4 4 4 4 4) | |
1613 ;; (1 3 2) | |
1614 ;; 9 | |
1615 ;; | |
1616 ;; (defun fuu (x y z) | |
1617 ;; "Add 3 numbers." | |
1618 ;; (+ x y z)) | |
1619 ;; | |
1620 ;; (fuu 1 2 3) | |
1621 ;; (1 3 2) | |
1622 ;; 9 | |
1623 ;; | |
1624 ;; @@ Defining the argument list of an advised function: | |
1625 ;; ===================================================== | |
1626 ;; Once in a while it might be desirable to advise a function and additionally | |
1627 ;; give it an extra argument that controls the advised code, for example, one | |
1628 ;; might want to make an interactive function sensitive to a prefix argument. | |
1629 ;; For such cases `defadvice' allows the specification of an argument list | |
26217 | 1630 ;; for the advised function. Similar to the redefinition of interactive |
4110 | 1631 ;; behavior, the first argument list specification found in the list of before/ |
1632 ;; around/after advices will be used. Of course, the specified argument list | |
1633 ;; should be downward compatible with the original argument list, otherwise | |
1634 ;; functions that call the advised function with the original argument list | |
1635 ;; in mind will break. | |
1636 ;; | |
1637 ;; (defun fii (x) | |
1638 ;; "Add 1 to X." | |
1639 ;; (1+ x)) | |
1640 ;; fii | |
1641 ;; | |
1642 ;; Now we advise `fii' to use an optional second argument that controls the | |
1643 ;; amount of incrementation. A list following the (optional) position | |
1644 ;; argument of the advice will be interpreted as an argument list | |
1645 ;; specification. This means you cannot specify an empty argument list, and | |
1646 ;; why would you want to anyway? | |
1647 ;; | |
1648 ;; (defadvice fii (before fg-inc-x (x &optional incr) act) | |
1649 ;; "Increment X by INCR (default is 1)." | |
1650 ;; (setq x (+ x (1- (or incr 1))))) | |
1651 ;; fii | |
1652 ;; | |
1653 ;; (fii 3) | |
1654 ;; 4 | |
1655 ;; | |
1656 ;; (fii 3 2) | |
1657 ;; 5 | |
1658 ;; | |
1659 ;; @@ Specifying argument lists of subrs: | |
1660 ;; ====================================== | |
1661 ;; The argument lists of subrs cannot be determined directly from Lisp. | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1662 ;; This means that Advice has to use `(&rest ad-subr-args)' as the |
4110 | 1663 ;; argument list of the advised subr which is not very efficient. In Lemacs |
1664 ;; subr argument lists can be determined from their documentation string, in | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1665 ;; Emacs-19 this is the case for some but not all subrs. To accommodate |
4110 | 1666 ;; for the cases where the argument lists cannot be determined (e.g., in a |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1667 ;; v18 Emacs) Advice comes with a specification mechanism that allows the |
4110 | 1668 ;; advice programmer to tell advice what the argument list of a certain subr |
1669 ;; really is. | |
1670 ;; | |
1671 ;; In a v18 Emacs the following will return the &rest idiom: | |
1672 ;; | |
1673 ;; (ad-arglist (symbol-function 'car)) | |
1674 ;; (&rest ad-subr-args) | |
1675 ;; | |
1676 ;; To tell advice what the argument list of `car' really is we | |
1677 ;; can do the following: | |
1678 ;; | |
1679 ;; (ad-define-subr-args 'car '(list)) | |
1680 ;; ((list)) | |
1681 ;; | |
1682 ;; Now `ad-arglist' will return the proper argument list (this method is | |
1683 ;; actually used by advice itself for the advised definition of `fset'): | |
1684 ;; | |
1685 ;; (ad-arglist (symbol-function 'car)) | |
1686 ;; (list) | |
1687 ;; | |
1688 ;; The defined argument list will be stored on the property list of the | |
1689 ;; subr name symbol. When advice looks for a subr argument list it first | |
1690 ;; checks for a definition on the property list, if that fails it tries | |
1691 ;; to infer it from the documentation string and caches it on the property | |
1692 ;; list if it was successful, otherwise `(&rest ad-subr-args)' will be used. | |
1693 ;; | |
1694 ;; @@ Advising interactive subrs: | |
1695 ;; ============================== | |
1696 ;; For the most part there is no difference between advising functions and | |
1697 ;; advising subrs. There is one situation though where one might have to write | |
1698 ;; slightly different advice code for subrs than for functions. This case | |
1699 ;; arises when one wants to access subr arguments in a before/around advice | |
1700 ;; when the arguments were determined by an interactive call to the subr. | |
1701 ;; Advice cannot determine what `interactive' form determines the interactive | |
1702 ;; behavior of the subr, hence, when it calls the original definition in an | |
1703 ;; interactive subr invocation it has to use `call-interactively' to generate | |
1704 ;; the proper interactive behavior. Thus up to that call the arguments of the | |
1705 ;; interactive subr will be nil. For example, the following advice for | |
1706 ;; `kill-buffer' will not work in an interactive invocation... | |
1707 ;; | |
1708 ;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp) | |
1709 ;; (my-before-kill-buffer-hook (ad-get-arg 0))) | |
1710 ;; kill-buffer | |
1711 ;; | |
1712 ;; ...because the buffer argument will be nil in that case. The way out of | |
1713 ;; this dilemma is to provide an `interactive' specification that mirrors | |
1714 ;; the interactive behavior of the unadvised subr, for example, the following | |
1715 ;; will do the right thing even when `kill-buffer' is called interactively: | |
1716 ;; | |
1717 ;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp) | |
1718 ;; (interactive "bKill buffer: ") | |
1719 ;; (my-before-kill-buffer-hook (ad-get-arg 0))) | |
1720 ;; kill-buffer | |
1721 ;; | |
1722 ;; @@ Advising macros: | |
1723 ;; =================== | |
1724 ;; Advising macros is slightly different because there are two significant | |
1725 ;; time points in the invocation of a macro: Expansion and evaluation time. | |
1726 ;; For an advised macro instead of evaluating the original definition we | |
1727 ;; use `macroexpand', that is, changing argument values and binding | |
1728 ;; environments by pieces of advice has an affect during macro expansion | |
1729 ;; but not necessarily during evaluation. In particular, any side effects | |
1730 ;; of pieces of advice will occur during macro expansion. To also affect | |
1731 ;; the behavior during evaluation time one has to change the value of | |
1732 ;; `ad-return-value' in a piece of after advice. For example: | |
1733 ;; | |
1734 ;; (defmacro foom (x) | |
1735 ;; (` (list (, x)))) | |
1736 ;; foom | |
1737 ;; | |
1738 ;; (foom '(a)) | |
1739 ;; ((a)) | |
1740 ;; | |
1741 ;; (defadvice foom (before fg-print-x act) | |
1742 ;; "Print the value of X." | |
1743 ;; (print x)) | |
1744 ;; foom | |
1745 ;; | |
1746 ;; The following works as expected because evaluation immediately follows | |
1747 ;; macro expansion: | |
1748 ;; | |
1749 ;; (foom '(a)) | |
1750 ;; (quote (a)) | |
1751 ;; ((a)) | |
1752 ;; | |
1753 ;; However, the printing happens during expansion (or byte-compile) time: | |
1754 ;; | |
1755 ;; (macroexpand '(foom '(a))) | |
1756 ;; (quote (a)) | |
1757 ;; (list (quote (a))) | |
1758 ;; | |
26217 | 1759 ;; If we want it to happen during evaluation time we have to do the |
4110 | 1760 ;; following (first remove the old advice): |
1761 ;; | |
1762 ;; (ad-remove-advice 'foom 'before 'fg-print-x) | |
1763 ;; nil | |
1764 ;; | |
1765 ;; (defadvice foom (after fg-print-x act) | |
1766 ;; "Print the value of X." | |
1767 ;; (setq ad-return-value | |
1768 ;; (` (progn (print (, x)) | |
1769 ;; (, ad-return-value))))) | |
1770 ;; foom | |
1771 ;; | |
1772 ;; (macroexpand '(foom '(a))) | |
1773 ;; (progn (print (quote (a))) (list (quote (a)))) | |
1774 ;; | |
1775 ;; (foom '(a)) | |
1776 ;; (a) | |
1777 ;; ((a)) | |
1778 ;; | |
1779 ;; While this method might seem somewhat cumbersome, it is very general | |
1780 ;; because it allows one to influence macro expansion as well as evaluation. | |
1781 ;; In general, advising macros should be a rather rare activity anyway, in | |
1782 ;; particular, because compile-time macro expansion takes away a lot of the | |
1783 ;; flexibility and effectiveness of the advice mechanism. Macros that were | |
1784 ;; compile-time expanded before the advice was activated will of course never | |
1785 ;; exhibit the advised behavior. | |
1786 ;; | |
1787 ;; @@ Advising special forms: | |
1788 ;; ========================== | |
1789 ;; Now for something that should be even more rare than advising macros: | |
1790 ;; Advising special forms. Because special forms are irregular in their | |
1791 ;; argument evaluation behavior (e.g., `setq' evaluates the second but not | |
1792 ;; the first argument) they have to be advised into macros. A dangerous | |
1793 ;; consequence of this is that the byte-compiler will not recognize them | |
1794 ;; as special forms anymore (well, in most cases) and use their expansion | |
1795 ;; rather than the proper byte-code. Also, because the original definition | |
1796 ;; of a special form cannot be `funcall'ed, `eval' has to be used instead | |
1797 ;; which is less efficient. | |
1798 ;; | |
1799 ;; MORAL: Do not advise special forms unless you are completely sure about | |
1800 ;; what you are doing (some of the forward advice behavior is | |
1801 ;; implemented via advice of the special forms `defun' and `defmacro'). | |
1802 ;; As a safety measure one should always do `ad-deactivate-all' before | |
1803 ;; one byte-compiles a file to avoid any interference of advised | |
1804 ;; special forms. | |
1805 ;; | |
1806 ;; Apart from the safety concerns advising special forms is not any different | |
1807 ;; from advising plain functions or subrs. | |
1808 | |
1809 | |
1810 ;;; Code: | |
1811 | |
1812 ;; @ Advice implementation: | |
1813 ;; ======================== | |
1814 | |
1815 ;; @@ Compilation idiosyncrasies: | |
1816 ;; ============================== | |
1817 | |
1818 ;; `defadvice' expansion needs quite a few advice functions and variables, | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1819 ;; hence, I need to preload the file before it can be compiled. To avoid |
4110 | 1820 ;; interference of bogus compiled files I always preload the source file: |
1821 (provide 'advice-preload) | |
1822 ;; During a normal load this is a noop: | |
1823 (require 'advice-preload "advice.el") | |
1824 | |
1825 | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
1826 ;; @@ Variable definitions: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
1827 ;; ======================== |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
1828 |
21365 | 1829 (defgroup advice nil |
1830 "An overloading mechanism for Emacs Lisp functions." | |
1831 :prefix "ad-" | |
26217 | 1832 :link '(custom-manual "(elisp)Advising Functions") |
21365 | 1833 :group 'lisp) |
1834 | |
8458
a95ca44cec95
(ad-subr-arglist): Adapted to new DOC file format.
Richard M. Stallman <rms@gnu.org>
parents:
8445
diff
changeset
|
1835 (defconst ad-version "2.14") |
4110 | 1836 |
1837 ;;;###autoload | |
21365 | 1838 (defcustom ad-redefinition-action 'warn |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
1839 "*Defines what to do with redefinitions during Advice de/activation. |
4110 | 1840 Redefinition occurs if a previously activated function that already has an |
1841 original definition associated with it gets redefined and then de/activated. | |
1842 In such a case we can either accept the current definition as the new | |
1843 original definition, discard the current definition and replace it with the | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1844 old original, or keep it and raise an error. The values `accept', `discard', |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1845 `error' or `warn' govern what will be done. `warn' is just like `accept' but |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1846 it additionally prints a warning message. All other values will be |
21365 | 1847 interpreted as `error'." |
22577 | 1848 :type '(choice (const accept) (const discard) (const warn) |
1849 (other :tag "error" error)) | |
21365 | 1850 :group 'advice) |
4110 | 1851 |
1852 ;;;###autoload | |
21365 | 1853 (defcustom ad-default-compilation-action 'maybe |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
1854 "*Defines whether to compile advised definitions during activation. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
1855 A value of `always' will result in unconditional compilation, `never' will |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
1856 always avoid compilation, `maybe' will compile if the byte-compiler is already |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
1857 loaded, and `like-original' will compile if the original definition of the |
26217 | 1858 advised function is compiled or a built-in function. Every other value will |
1859 be interpreted as `maybe'. This variable will only be considered if the | |
21365 | 1860 COMPILE argument of `ad-activate' was supplied as nil." |
22577 | 1861 :type '(choice (const always) (const never) (const like-original) |
1862 (other :tag "maybe" maybe)) | |
21365 | 1863 :group 'advice) |
1864 | |
4110 | 1865 |
1866 | |
1867 ;; @@ Some utilities: | |
1868 ;; ================== | |
1869 | |
1870 ;; We don't want the local arguments to interfere with anything | |
1871 ;; referenced in the supplied functions => the cryptic casing: | |
1872 (defun ad-substitute-tree (sUbTrEe-TeSt fUnCtIoN tReE) | |
26217 | 1873 "Substitute qualifying subTREEs with result of FUNCTION(subTREE). |
1874 Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4) | |
1875 then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are | |
1876 allowed too. Once a qualifying subtree has been found its subtrees will | |
1877 not be considered anymore. (ad-substitute-tree 'atom 'identity tree) | |
1878 generates a copy of TREE." | |
4110 | 1879 (cond ((consp tReE) |
1880 (cons (if (funcall sUbTrEe-TeSt (car tReE)) | |
1881 (funcall fUnCtIoN (car tReE)) | |
1882 (if (consp (car tReE)) | |
1883 (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN (car tReE)) | |
1884 (car tReE))) | |
1885 (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN (cdr tReE)))) | |
1886 ((funcall sUbTrEe-TeSt tReE) | |
1887 (funcall fUnCtIoN tReE)) | |
1888 (t tReE))) | |
1889 | |
1890 ;; this is just faster than `ad-substitute-tree': | |
1891 (defun ad-copy-tree (tree) | |
26217 | 1892 "Return a copy of the list structure of TREE." |
4110 | 1893 (cond ((consp tree) |
1894 (cons (ad-copy-tree (car tree)) | |
1895 (ad-copy-tree (cdr tree)))) | |
1896 (t tree))) | |
1897 | |
1898 (defmacro ad-dolist (varform &rest body) | |
1899 "A Common-Lisp-style dolist iterator with the following syntax: | |
1900 | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1901 (ad-dolist (VAR INIT-FORM [RESULT-FORM]) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1902 BODY-FORM...) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1903 |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1904 which will iterate over the list yielded by INIT-FORM binding VAR to the |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1905 current head at every iteration. If RESULT-FORM is supplied its value will |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1906 be returned at the end of the iteration, nil otherwise. The iteration can be |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1907 exited prematurely with `(ad-do-return [VALUE])'." |
4110 | 1908 (let ((expansion |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1909 `(let ((ad-dO-vAr ,(car (cdr varform))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1910 ,(car varform)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1911 (while ad-dO-vAr |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1912 (setq ,(car varform) (car ad-dO-vAr)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1913 ,@body |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1914 ;;work around a backquote bug: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1915 ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1916 ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1917 ,'(setq ad-dO-vAr (cdr ad-dO-vAr))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1918 ,(car (cdr (cdr varform)))))) |
4110 | 1919 ;;ok, this wastes some cons cells but only during compilation: |
1920 (if (catch 'contains-return | |
1921 (ad-substitute-tree | |
1922 (function (lambda (subtree) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1923 (cond ((eq (car-safe subtree) 'ad-dolist)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1924 ((eq (car-safe subtree) 'ad-do-return) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1925 (throw 'contains-return t))))) |
4110 | 1926 'identity body) |
1927 nil) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1928 `(catch 'ad-dO-eXiT ,expansion) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1929 expansion))) |
4110 | 1930 |
1931 (defmacro ad-do-return (value) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1932 `(throw 'ad-dO-eXiT ,value)) |
4110 | 1933 |
1934 (if (not (get 'ad-dolist 'lisp-indent-hook)) | |
1935 (put 'ad-dolist 'lisp-indent-hook 1)) | |
1936 | |
1937 | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1938 ;; @@ Save real definitions of subrs used by Advice: |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1939 ;; ================================================= |
26217 | 1940 ;; Advice depends on the real, unmodified functionality of various subrs, |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1941 ;; we save them here so advised versions will not interfere (eventually, |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1942 ;; we will save all subrs used in code generated by Advice): |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1943 |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1944 (defmacro ad-save-real-definition (function) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1945 (let ((saved-function (intern (format "ad-real-%s" function)))) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1946 ;; Make sure the compiler is loaded during macro expansion: |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1947 (require 'byte-compile "bytecomp") |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1948 `(if (not (fboundp ',saved-function)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1949 (progn (fset ',saved-function (symbol-function ',function)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1950 ;; Copy byte-compiler properties: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1951 ,@(if (get function 'byte-compile) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1952 `((put ',saved-function 'byte-compile |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1953 ',(get function 'byte-compile)))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1954 ,@(if (get function 'byte-opcode) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1955 `((put ',saved-function 'byte-opcode |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1956 ',(get function 'byte-opcode)))))))) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1957 |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1958 (defun ad-save-real-definitions () |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1959 ;; Macro expansion will hardcode the values of the various byte-compiler |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1960 ;; properties into the compiled version of this function such that the |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1961 ;; proper values will be available at runtime without loading the compiler: |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1962 (ad-save-real-definition fset) |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
1963 (ad-save-real-definition documentation)) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1964 |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1965 (ad-save-real-definitions) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1966 |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1967 |
4110 | 1968 ;; @@ Advice info access fns: |
1969 ;; ========================== | |
1970 | |
1971 ;; Advice information for a particular function is stored on the | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
1972 ;; advice-info property of the function symbol. It is stored as an |
4110 | 1973 ;; alist of the following format: |
1974 ;; | |
1975 ;; ((active . t/nil) | |
1976 ;; (before adv1 adv2 ...) | |
1977 ;; (around adv1 adv2 ...) | |
1978 ;; (after adv1 adv2 ...) | |
1979 ;; (activation adv1 adv2 ...) | |
1980 ;; (deactivation adv1 adv2 ...) | |
1981 ;; (origname . <symbol fbound to origdef>) | |
1982 ;; (cache . (<advised-definition> . <id>))) | |
1983 | |
1984 ;; List of currently advised though not necessarily activated functions | |
1985 ;; (this list is maintained as a completion table): | |
1986 (defvar ad-advised-functions nil) | |
1987 | |
1988 (defmacro ad-pushnew-advised-function (function) | |
26217 | 1989 "Add FUNCTION to `ad-advised-functions' unless its already there." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1990 `(if (not (assoc (symbol-name ,function) ad-advised-functions)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1991 (setq ad-advised-functions |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1992 (cons (list (symbol-name ,function)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1993 ad-advised-functions)))) |
4110 | 1994 |
1995 (defmacro ad-pop-advised-function (function) | |
26217 | 1996 "Remove FUNCTION from `ad-advised-functions'." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1997 `(setq ad-advised-functions |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1998 (delq (assoc (symbol-name ,function) ad-advised-functions) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
1999 ad-advised-functions))) |
4110 | 2000 |
2001 (defmacro ad-do-advised-functions (varform &rest body) | |
26217 | 2002 "`ad-dolist'-style iterator that maps over `ad-advised-functions'. |
2003 \(ad-do-advised-functions (VAR [RESULT-FORM]) | |
2004 BODY-FORM...) | |
2005 On each iteration VAR will be bound to the name of an advised function | |
2006 \(a symbol)." | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2007 `(ad-dolist (,(car varform) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2008 ad-advised-functions |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2009 ,(car (cdr varform))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2010 (setq ,(car varform) (intern (car ,(car varform)))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2011 ,@body)) |
4110 | 2012 |
2013 (if (not (get 'ad-do-advised-functions 'lisp-indent-hook)) | |
2014 (put 'ad-do-advised-functions 'lisp-indent-hook 1)) | |
2015 | |
85320
3ba42b3f9a45
(ad-get-advice-info): Change to a function.
Richard M. Stallman <rms@gnu.org>
parents:
85302
diff
changeset
|
2016 (defun ad-get-advice-info (function) |
3ba42b3f9a45
(ad-get-advice-info): Change to a function.
Richard M. Stallman <rms@gnu.org>
parents:
85302
diff
changeset
|
2017 (get function 'ad-advice-info)) |
3ba42b3f9a45
(ad-get-advice-info): Change to a function.
Richard M. Stallman <rms@gnu.org>
parents:
85302
diff
changeset
|
2018 |
3ba42b3f9a45
(ad-get-advice-info): Change to a function.
Richard M. Stallman <rms@gnu.org>
parents:
85302
diff
changeset
|
2019 (defmacro ad-get-advice-info-macro (function) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2020 `(get ,function 'ad-advice-info)) |
4110 | 2021 |
2022 (defmacro ad-set-advice-info (function advice-info) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2023 `(put ,function 'ad-advice-info ,advice-info)) |
4110 | 2024 |
2025 (defmacro ad-copy-advice-info (function) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2026 `(ad-copy-tree (get ,function 'ad-advice-info))) |
4110 | 2027 |
2028 (defmacro ad-is-advised (function) | |
26217 | 2029 "Return non-nil if FUNCTION has any advice info associated with it. |
2030 This does not mean that the advice is also active." | |
85320
3ba42b3f9a45
(ad-get-advice-info): Change to a function.
Richard M. Stallman <rms@gnu.org>
parents:
85302
diff
changeset
|
2031 (list 'ad-get-advice-info-macro function)) |
4110 | 2032 |
2033 (defun ad-initialize-advice-info (function) | |
26217 | 2034 "Initialize the advice info for FUNCTION. |
2035 Assumes that FUNCTION has not yet been advised." | |
4110 | 2036 (ad-pushnew-advised-function function) |
2037 (ad-set-advice-info function (list (cons 'active nil)))) | |
2038 | |
2039 (defmacro ad-get-advice-info-field (function field) | |
26217 | 2040 "Retrieve the value of the advice info FIELD of FUNCTION." |
85320
3ba42b3f9a45
(ad-get-advice-info): Change to a function.
Richard M. Stallman <rms@gnu.org>
parents:
85302
diff
changeset
|
2041 `(cdr (assq ,field (ad-get-advice-info-macro ,function)))) |
4110 | 2042 |
2043 (defun ad-set-advice-info-field (function field value) | |
26217 | 2044 "Destructively modify VALUE of the advice info FIELD of FUNCTION." |
4110 | 2045 (and (ad-is-advised function) |
85320
3ba42b3f9a45
(ad-get-advice-info): Change to a function.
Richard M. Stallman <rms@gnu.org>
parents:
85302
diff
changeset
|
2046 (cond ((assq field (ad-get-advice-info-macro function)) |
4110 | 2047 ;; A field with that name is already present: |
85320
3ba42b3f9a45
(ad-get-advice-info): Change to a function.
Richard M. Stallman <rms@gnu.org>
parents:
85302
diff
changeset
|
2048 (rplacd (assq field (ad-get-advice-info-macro function)) value)) |
4110 | 2049 (t;; otherwise, create a new field with that name: |
85320
3ba42b3f9a45
(ad-get-advice-info): Change to a function.
Richard M. Stallman <rms@gnu.org>
parents:
85302
diff
changeset
|
2050 (nconc (ad-get-advice-info-macro function) |
4110 | 2051 (list (cons field value))))))) |
2052 | |
2053 ;; Don't make this a macro so we can use it as a predicate: | |
2054 (defun ad-is-active (function) | |
26217 | 2055 "Return non-nil if FUNCTION is advised and activated." |
4110 | 2056 (ad-get-advice-info-field function 'active)) |
2057 | |
2058 | |
2059 ;; @@ Access fns for single pieces of advice and related predicates: | |
2060 ;; ================================================================= | |
2061 | |
2062 (defun ad-make-advice (name protect enable definition) | |
2063 "Constructs single piece of advice to be stored in some advice-info. | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2064 NAME should be a non-nil symbol, PROTECT and ENABLE should each be |
4110 | 2065 either t or nil, and DEFINITION should be a list of the form |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2066 `(advice lambda ARGLIST [DOCSTRING] [INTERACTIVE-FORM] BODY...)'." |
4110 | 2067 (list name protect enable definition)) |
2068 | |
2069 ;; ad-find-advice uses the alist structure directly -> | |
2070 ;; change if this data structure changes!! | |
2071 (defmacro ad-advice-name (advice) | |
2072 (list 'car advice)) | |
2073 (defmacro ad-advice-protected (advice) | |
2074 (list 'nth 1 advice)) | |
2075 (defmacro ad-advice-enabled (advice) | |
2076 (list 'nth 2 advice)) | |
2077 (defmacro ad-advice-definition (advice) | |
2078 (list 'nth 3 advice)) | |
2079 | |
2080 (defun ad-advice-set-enabled (advice flag) | |
2081 (rplaca (cdr (cdr advice)) flag)) | |
2082 | |
2083 (defun ad-class-p (thing) | |
2084 (memq thing ad-advice-classes)) | |
2085 (defun ad-name-p (thing) | |
2086 (and thing (symbolp thing))) | |
2087 (defun ad-position-p (thing) | |
2088 (or (natnump thing) | |
2089 (memq thing '(first last)))) | |
2090 | |
2091 | |
2092 ;; @@ Advice access functions: | |
2093 ;; =========================== | |
2094 | |
2095 ;; List of defined advice classes: | |
2096 (defvar ad-advice-classes '(before around after activation deactivation)) | |
2097 | |
2098 (defun ad-has-enabled-advice (function class) | |
26217 | 2099 "True if at least one of FUNCTION's advices in CLASS is enabled." |
4110 | 2100 (ad-dolist (advice (ad-get-advice-info-field function class)) |
2101 (if (ad-advice-enabled advice) (ad-do-return t)))) | |
2102 | |
2103 (defun ad-has-redefining-advice (function) | |
26217 | 2104 "True if FUNCTION's advice info defines at least 1 redefining advice. |
2105 Redefining advices affect the construction of an advised definition." | |
4110 | 2106 (and (ad-is-advised function) |
2107 (or (ad-has-enabled-advice function 'before) | |
2108 (ad-has-enabled-advice function 'around) | |
2109 (ad-has-enabled-advice function 'after)))) | |
2110 | |
2111 (defun ad-has-any-advice (function) | |
26217 | 2112 "True if the advice info of FUNCTION defines at least one advice." |
4110 | 2113 (and (ad-is-advised function) |
2114 (ad-dolist (class ad-advice-classes nil) | |
2115 (if (ad-get-advice-info-field function class) | |
2116 (ad-do-return t))))) | |
2117 | |
2118 (defun ad-get-enabled-advices (function class) | |
26217 | 2119 "Return the list of enabled advices of FUNCTION in CLASS." |
4110 | 2120 (let (enabled-advices) |
2121 (ad-dolist (advice (ad-get-advice-info-field function class)) | |
2122 (if (ad-advice-enabled advice) | |
50800
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2123 (push advice enabled-advices))) |
4110 | 2124 (reverse enabled-advices))) |
2125 | |
2126 | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2127 ;; @@ Dealing with automatic advice activation via `fset/defalias': |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2128 ;; ================================================================ |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2129 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2130 ;; Since Emacs 19.26 the built-in versions of `fset' and `defalias' |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2131 ;; take care of automatic advice activation, hence, we don't have to |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2132 ;; hack it anymore by advising `fset/defun/defmacro/byte-code/etc'. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2133 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2134 ;; The functionality of the new `fset' is as follows: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2135 ;; |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2136 ;; fset(sym,newdef) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2137 ;; assign NEWDEF to SYM |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2138 ;; if (get SYM 'ad-advice-info) |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
2139 ;; ad-activate-internal(SYM, nil) |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2140 ;; return (symbol-function SYM) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2141 ;; |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2142 ;; Whether advised definitions created by automatic activations will be |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2143 ;; compiled depends on the value of `ad-default-compilation-action'. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2144 |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
2145 ;; Since calling `ad-activate-internal' in the built-in definition of `fset' can |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2146 ;; create major disasters we have to be a bit careful. One precaution is |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
2147 ;; to provide a dummy definition for `ad-activate-internal' which can be used to |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2148 ;; turn off automatic advice activation (e.g., when `ad-stop-advice' or |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2149 ;; `ad-recover-normality' are called). Another is to avoid recursive calls |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
2150 ;; to `ad-activate' by using `ad-with-auto-activation-disabled' where |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2151 ;; appropriate, especially in a safe version of `fset'. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2152 |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
2153 ;; For now define `ad-activate-internal' to the dummy definition: |
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
2154 (defun ad-activate-internal (function &optional compile) |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2155 "Automatic advice activation is disabled. `ad-start-advice' enables it." |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2156 nil) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2157 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2158 ;; This is just a copy of the above: |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
2159 (defun ad-activate-internal-off (function &optional compile) |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2160 "Automatic advice activation is disabled. `ad-start-advice' enables it." |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2161 nil) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2162 |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
2163 ;; This will be t for top-level calls to `ad-activate-internal-on': |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2164 (defvar ad-activate-on-top-level t) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2165 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2166 (defmacro ad-with-auto-activation-disabled (&rest body) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2167 `(let ((ad-activate-on-top-level nil)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2168 ,@body)) |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2169 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2170 (defun ad-safe-fset (symbol definition) |
26217 | 2171 "A safe `fset' which will never call `ad-activate-internal' recursively." |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2172 (ad-with-auto-activation-disabled |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2173 (ad-real-fset symbol definition))) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2174 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2175 |
4110 | 2176 ;; @@ Access functions for original definitions: |
2177 ;; ============================================ | |
2178 ;; The advice-info of an advised function contains its `origname' which is | |
2179 ;; a symbol that is fbound to the original definition available at the first | |
60923
08f8c7042636
* emacs-lisp/advice.el: Replace `legal' with `valid'.
Werner LEMBERG <wl@gnu.org>
parents:
57879
diff
changeset
|
2180 ;; proper activation of the function after a valid re/definition. If the |
4110 | 2181 ;; original was defined via fcell indirection then `origname' will be defined |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2182 ;; just so. Hence, to get hold of the actual original definition of a function |
4110 | 2183 ;; we need to use `ad-real-orig-definition'. |
2184 | |
2185 (defun ad-make-origname (function) | |
26217 | 2186 "Make name to be used to call the original FUNCTION." |
4110 | 2187 (intern (format "ad-Orig-%s" function))) |
2188 | |
2189 (defmacro ad-get-orig-definition (function) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2190 `(let ((origname (ad-get-advice-info-field ,function 'origname))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2191 (if (fboundp origname) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2192 (symbol-function origname)))) |
4110 | 2193 |
2194 (defmacro ad-set-orig-definition (function definition) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2195 `(ad-safe-fset |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2196 (ad-get-advice-info-field function 'origname) ,definition)) |
4110 | 2197 |
2198 (defmacro ad-clear-orig-definition (function) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2199 `(fmakunbound (ad-get-advice-info-field ,function 'origname))) |
4110 | 2200 |
2201 | |
2202 ;; @@ Interactive input functions: | |
2203 ;; =============================== | |
2204 | |
2205 (defun ad-read-advised-function (&optional prompt predicate default) | |
26217 | 2206 "Read name of advised function with completion from the minibuffer. |
2207 An optional PROMPT will be used to prompt for the function. PREDICATE | |
2208 plays the same role as for `try-completion' (which see). DEFAULT will | |
2209 be returned on empty input (defaults to the first advised function for | |
2210 which PREDICATE returns non-nil)." | |
4110 | 2211 (if (null ad-advised-functions) |
2212 (error "ad-read-advised-function: There are no advised functions")) | |
2213 (setq default | |
2214 (or default | |
2215 (ad-do-advised-functions (function) | |
2216 (if (or (null predicate) | |
2217 (funcall predicate function)) | |
2218 (ad-do-return function))) | |
2219 (error "ad-read-advised-function: %s" | |
2220 "There are no qualifying advised functions"))) | |
2221 (let* ((ad-pReDiCaTe predicate) | |
2222 (function | |
2223 (completing-read | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2224 (format "%s (default %s): " (or prompt "Function") default) |
4110 | 2225 ad-advised-functions |
2226 (if predicate | |
2227 (function | |
2228 (lambda (function) | |
2229 ;; Oops, no closures - the joys of dynamic scoping: | |
2230 ;; `predicate' clashed with the `predicate' argument | |
2231 ;; of Lemacs' `completing-read'..... | |
2232 (funcall ad-pReDiCaTe (intern (car function)))))) | |
2233 t))) | |
2234 (if (equal function "") | |
2235 (if (ad-is-advised default) | |
2236 default | |
2237 (error "ad-read-advised-function: `%s' is not advised" default)) | |
2238 (intern function)))) | |
2239 | |
2240 (defvar ad-advice-class-completion-table | |
29579
05016ef95d0f
(ad-advice-class-completion-table)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
26627
diff
changeset
|
2241 (mapcar (lambda (class) (list (symbol-name class))) |
4110 | 2242 ad-advice-classes)) |
2243 | |
2244 (defun ad-read-advice-class (function &optional prompt default) | |
60923
08f8c7042636
* emacs-lisp/advice.el: Replace `legal' with `valid'.
Werner LEMBERG <wl@gnu.org>
parents:
57879
diff
changeset
|
2245 "Read a valid advice class with completion from the minibuffer. |
26217 | 2246 An optional PROMPT will be used to prompt for the class. DEFAULT will |
2247 be returned on empty input (defaults to the first non-empty advice | |
2248 class of FUNCTION)." | |
4110 | 2249 (setq default |
2250 (or default | |
2251 (ad-dolist (class ad-advice-classes) | |
2252 (if (ad-get-advice-info-field function class) | |
2253 (ad-do-return class))) | |
2254 (error "ad-read-advice-class: `%s' has no advices" function))) | |
2255 (let ((class (completing-read | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2256 (format "%s (default %s): " (or prompt "Class") default) |
4110 | 2257 ad-advice-class-completion-table nil t))) |
2258 (if (equal class "") | |
2259 default | |
2260 (intern class)))) | |
2261 | |
2262 (defun ad-read-advice-name (function class &optional prompt) | |
26217 | 2263 "Read name of existing advice of CLASS for FUNCTION with completion. |
2264 An optional PROMPT is used to prompt for the name." | |
4110 | 2265 (let* ((name-completion-table |
2266 (mapcar (function (lambda (advice) | |
2267 (list (symbol-name (ad-advice-name advice))))) | |
2268 (ad-get-advice-info-field function class))) | |
2269 (default | |
2270 (if (null name-completion-table) | |
2271 (error "ad-read-advice-name: `%s' has no %s advice" | |
2272 function class) | |
2273 (car (car name-completion-table)))) | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2274 (prompt (format "%s (default %s): " (or prompt "Name") default)) |
4110 | 2275 (name (completing-read prompt name-completion-table nil t))) |
2276 (if (equal name "") | |
2277 (intern default) | |
2278 (intern name)))) | |
2279 | |
2280 (defun ad-read-advice-specification (&optional prompt) | |
26217 | 2281 "Read a complete function/class/name specification from minibuffer. |
2282 The list of read symbols will be returned. The optional PROMPT will | |
2283 be used to prompt for the function." | |
4110 | 2284 (let* ((function (ad-read-advised-function prompt)) |
2285 (class (ad-read-advice-class function)) | |
2286 (name (ad-read-advice-name function class))) | |
2287 (list function class name))) | |
2288 | |
2289 ;; Use previous regexp as a default: | |
2290 (defvar ad-last-regexp "") | |
2291 | |
2292 (defun ad-read-regexp (&optional prompt) | |
26217 | 2293 "Read a regular expression from the minibuffer." |
4110 | 2294 (let ((regexp (read-from-minibuffer |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2295 (concat (or prompt "Regular expression") |
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2296 (if (equal ad-last-regexp "") ": " |
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2297 (format " (default %s): " ad-last-regexp)))))) |
4110 | 2298 (setq ad-last-regexp |
2299 (if (equal regexp "") ad-last-regexp regexp)))) | |
2300 | |
2301 | |
2302 ;; @@ Finding, enabling, adding and removing pieces of advice: | |
2303 ;; =========================================================== | |
2304 | |
2305 (defmacro ad-find-advice (function class name) | |
26217 | 2306 "Find the first advice of FUNCTION in CLASS with NAME." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2307 `(assq ,name (ad-get-advice-info-field ,function ,class))) |
4110 | 2308 |
2309 (defun ad-advice-position (function class name) | |
26217 | 2310 "Return position of first advice of FUNCTION in CLASS with NAME." |
4110 | 2311 (let* ((found-advice (ad-find-advice function class name)) |
2312 (advices (ad-get-advice-info-field function class))) | |
2313 (if found-advice | |
2314 (- (length advices) (length (memq found-advice advices)))))) | |
2315 | |
2316 (defun ad-find-some-advice (function class name) | |
26217 | 2317 "Find the first of FUNCTION's advices in CLASS matching NAME. |
4110 | 2318 NAME can be a symbol or a regular expression matching part of an advice name. |
60923
08f8c7042636
* emacs-lisp/advice.el: Replace `legal' with `valid'.
Werner LEMBERG <wl@gnu.org>
parents:
57879
diff
changeset
|
2319 If CLASS is `any' all valid advice classes will be checked." |
4110 | 2320 (if (ad-is-advised function) |
2321 (let (found-advice) | |
2322 (ad-dolist (advice-class ad-advice-classes) | |
2323 (if (or (eq class 'any) (eq advice-class class)) | |
2324 (setq found-advice | |
2325 (ad-dolist (advice (ad-get-advice-info-field | |
2326 function advice-class)) | |
2327 (if (or (and (stringp name) | |
2328 (string-match | |
2329 name (symbol-name | |
2330 (ad-advice-name advice)))) | |
2331 (eq name (ad-advice-name advice))) | |
2332 (ad-do-return advice))))) | |
2333 (if found-advice (ad-do-return found-advice)))))) | |
2334 | |
2335 (defun ad-enable-advice-internal (function class name flag) | |
26217 | 2336 "Set enable FLAG of FUNCTION's advices in CLASS matching NAME. |
2337 If NAME is a string rather than a symbol then it's interpreted as a regular | |
2338 expression and all advices whose name contain a match for it will be | |
60923
08f8c7042636
* emacs-lisp/advice.el: Replace `legal' with `valid'.
Werner LEMBERG <wl@gnu.org>
parents:
57879
diff
changeset
|
2339 affected. If CLASS is `any' advices in all valid advice classes will be |
26217 | 2340 considered. The number of changed advices will be returned (or nil if |
2341 FUNCTION was not advised)." | |
4110 | 2342 (if (ad-is-advised function) |
2343 (let ((matched-advices 0)) | |
2344 (ad-dolist (advice-class ad-advice-classes) | |
2345 (if (or (eq class 'any) (eq advice-class class)) | |
2346 (ad-dolist (advice (ad-get-advice-info-field | |
2347 function advice-class)) | |
2348 (cond ((or (and (stringp name) | |
2349 (string-match | |
2350 name (symbol-name (ad-advice-name advice)))) | |
2351 (eq name (ad-advice-name advice))) | |
2352 (setq matched-advices (1+ matched-advices)) | |
2353 (ad-advice-set-enabled advice flag)))))) | |
2354 matched-advices))) | |
2355 | |
70899
b920ab84fba8
(ad-enable-advice, ad-activate, ad-disable-advice): Add autoloads.
Richard M. Stallman <rms@gnu.org>
parents:
68648
diff
changeset
|
2356 ;;;###autoload |
4110 | 2357 (defun ad-enable-advice (function class name) |
2358 "Enables the advice of FUNCTION with CLASS and NAME." | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2359 (interactive (ad-read-advice-specification "Enable advice of")) |
4110 | 2360 (if (ad-is-advised function) |
2361 (if (eq (ad-enable-advice-internal function class name t) 0) | |
2362 (error "ad-enable-advice: `%s' has no %s advice matching `%s'" | |
2363 function class name)) | |
2364 (error "ad-enable-advice: `%s' is not advised" function))) | |
2365 | |
70899
b920ab84fba8
(ad-enable-advice, ad-activate, ad-disable-advice): Add autoloads.
Richard M. Stallman <rms@gnu.org>
parents:
68648
diff
changeset
|
2366 ;;;###autoload |
4110 | 2367 (defun ad-disable-advice (function class name) |
26217 | 2368 "Disable the advice of FUNCTION with CLASS and NAME." |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2369 (interactive (ad-read-advice-specification "Disable advice of")) |
4110 | 2370 (if (ad-is-advised function) |
2371 (if (eq (ad-enable-advice-internal function class name nil) 0) | |
2372 (error "ad-disable-advice: `%s' has no %s advice matching `%s'" | |
2373 function class name)) | |
2374 (error "ad-disable-advice: `%s' is not advised" function))) | |
2375 | |
2376 (defun ad-enable-regexp-internal (regexp class flag) | |
26217 | 2377 "Set enable FLAGs of all CLASS advices whose name contains a REGEXP match. |
60923
08f8c7042636
* emacs-lisp/advice.el: Replace `legal' with `valid'.
Werner LEMBERG <wl@gnu.org>
parents:
57879
diff
changeset
|
2378 If CLASS is `any' all valid advice classes are considered. The number of |
26217 | 2379 affected advices will be returned." |
4110 | 2380 (let ((matched-advices 0)) |
2381 (ad-do-advised-functions (advised-function) | |
2382 (setq matched-advices | |
2383 (+ matched-advices | |
2384 (or (ad-enable-advice-internal | |
2385 advised-function class regexp flag) | |
2386 0)))) | |
2387 matched-advices)) | |
2388 | |
2389 (defun ad-enable-regexp (regexp) | |
2390 "Enables all advices with names that contain a match for REGEXP. | |
2391 All currently advised functions will be considered." | |
2392 (interactive | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2393 (list (ad-read-regexp "Enable advices via regexp"))) |
4110 | 2394 (let ((matched-advices (ad-enable-regexp-internal regexp 'any t))) |
2395 (if (interactive-p) | |
2396 (message "%d matching advices enabled" matched-advices)) | |
2397 matched-advices)) | |
2398 | |
2399 (defun ad-disable-regexp (regexp) | |
26217 | 2400 "Disable all advices with names that contain a match for REGEXP. |
4110 | 2401 All currently advised functions will be considered." |
2402 (interactive | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2403 (list (ad-read-regexp "Disable advices via regexp"))) |
4110 | 2404 (let ((matched-advices (ad-enable-regexp-internal regexp 'any nil))) |
2405 (if (interactive-p) | |
2406 (message "%d matching advices disabled" matched-advices)) | |
2407 matched-advices)) | |
2408 | |
2409 (defun ad-remove-advice (function class name) | |
26217 | 2410 "Remove FUNCTION's advice with NAME from its advices in CLASS. |
4110 | 2411 If such an advice was found it will be removed from the list of advices |
2412 in that CLASS." | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
2413 (interactive (ad-read-advice-specification "Remove advice of")) |
4110 | 2414 (if (ad-is-advised function) |
73251
25e1db3fd0ed
(ad-remove-advice, ad-parse-arglist, ad-make-mapped-call):
Juanma Barranquero <lekktu@gmail.com>
parents:
70899
diff
changeset
|
2415 (let ((advice-to-remove (ad-find-advice function class name))) |
4110 | 2416 (if advice-to-remove |
2417 (ad-set-advice-info-field | |
2418 function class | |
2419 (delq advice-to-remove (ad-get-advice-info-field function class))) | |
2420 (error "ad-remove-advice: `%s' has no %s advice `%s'" | |
2421 function class name))) | |
2422 (error "ad-remove-advice: `%s' is not advised" function))) | |
2423 | |
2424 ;;;###autoload | |
2425 (defun ad-add-advice (function advice class position) | |
26217 | 2426 "Add a piece of ADVICE to FUNCTION's list of advices in CLASS. |
4110 | 2427 If FUNCTION already has one or more pieces of advice of the specified |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2428 CLASS then POSITION determines where the new piece will go. The value |
4110 | 2429 of POSITION can either be `first', `last' or a number where 0 corresponds |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2430 to `first'. Numbers outside the range will be mapped to the closest |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2431 extreme position. If there was already a piece of ADVICE with the same |
4110 | 2432 name, then the position argument will be ignored and the old advice |
2433 will be overwritten with the new one. | |
26217 | 2434 If the FUNCTION was not advised already, then its advice info will be |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2435 initialized. Redefining a piece of advice whose name is part of the cache-id |
4110 | 2436 will clear the cache." |
2437 (cond ((not (ad-is-advised function)) | |
2438 (ad-initialize-advice-info function) | |
2439 (ad-set-advice-info-field | |
2440 function 'origname (ad-make-origname function)))) | |
2441 (let* ((previous-position | |
2442 (ad-advice-position function class (ad-advice-name advice))) | |
2443 (advices (ad-get-advice-info-field function class)) | |
2444 ;; Determine a numerical position for the new advice: | |
2445 (position (cond (previous-position) | |
2446 ((eq position 'first) 0) | |
2447 ((eq position 'last) (length advices)) | |
2448 ((numberp position) | |
2449 (max 0 (min position (length advices)))) | |
2450 (t 0)))) | |
2451 ;; Check whether we have to clear the cache: | |
2452 (if (memq (ad-advice-name advice) (ad-get-cache-class-id function class)) | |
2453 (ad-clear-cache function)) | |
2454 (if previous-position | |
2455 (setcar (nthcdr position advices) advice) | |
2456 (if (= position 0) | |
2457 (ad-set-advice-info-field function class (cons advice advices)) | |
2458 (setcdr (nthcdr (1- position) advices) | |
2459 (cons advice (nthcdr position advices))))))) | |
2460 | |
2461 | |
2462 ;; @@ Accessing and manipulating function definitions: | |
2463 ;; =================================================== | |
2464 | |
2465 (defmacro ad-macrofy (definition) | |
26217 | 2466 "Take a lambda function DEFINITION and make a macro out of it." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2467 `(cons 'macro ,definition)) |
4110 | 2468 |
2469 (defmacro ad-lambdafy (definition) | |
26217 | 2470 "Take a macro function DEFINITION and make a lambda out of it." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2471 `(cdr ,definition)) |
4110 | 2472 |
80879
cdee0fbb5943
(ad-special-forms): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
75346
diff
changeset
|
2473 (defun ad-special-form-p (definition) |
cdee0fbb5943
(ad-special-forms): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
75346
diff
changeset
|
2474 "Non-nil iff DEFINITION is a special form." |
cdee0fbb5943
(ad-special-forms): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
75346
diff
changeset
|
2475 (if (and (symbolp definition) (fboundp definition)) |
cdee0fbb5943
(ad-special-forms): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
75346
diff
changeset
|
2476 (setq definition (indirect-function definition))) |
cdee0fbb5943
(ad-special-forms): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
75346
diff
changeset
|
2477 (and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled))) |
4110 | 2478 |
2479 (defmacro ad-subr-p (definition) | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2480 ;;"non-nil if DEFINITION is a subr." |
4110 | 2481 (list 'subrp definition)) |
2482 | |
2483 (defmacro ad-macro-p (definition) | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2484 ;;"non-nil if DEFINITION is a macro." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2485 `(eq (car-safe ,definition) 'macro)) |
4110 | 2486 |
2487 (defmacro ad-lambda-p (definition) | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2488 ;;"non-nil if DEFINITION is a lambda expression." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2489 `(eq (car-safe ,definition) 'lambda)) |
4110 | 2490 |
2491 ;; see ad-make-advice for the format of advice definitions: | |
2492 (defmacro ad-advice-p (definition) | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2493 ;;"non-nil if DEFINITION is a piece of advice." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2494 `(eq (car-safe ,definition) 'advice)) |
4110 | 2495 |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2496 ;; Emacs/Lemacs cross-compatibility |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2497 ;; (compiled-function-p is an obsolete function in Emacs): |
4110 | 2498 (if (and (not (fboundp 'byte-code-function-p)) |
2499 (fboundp 'compiled-function-p)) | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2500 (ad-safe-fset 'byte-code-function-p 'compiled-function-p)) |
4110 | 2501 |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2502 (defmacro ad-compiled-p (definition) |
26217 | 2503 "Return non-nil if DEFINITION is a compiled byte-code object." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2504 `(or (byte-code-function-p ,definition) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2505 (and (ad-macro-p ,definition) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2506 (byte-code-function-p (ad-lambdafy ,definition))))) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2507 |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2508 (defmacro ad-compiled-code (compiled-definition) |
26217 | 2509 "Return the byte-code object of a COMPILED-DEFINITION." |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2510 `(if (ad-macro-p ,compiled-definition) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2511 (ad-lambdafy ,compiled-definition) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2512 ,compiled-definition)) |
4110 | 2513 |
2514 (defun ad-lambda-expression (definition) | |
26217 | 2515 "Return the lambda expression of a function/macro/advice DEFINITION." |
4110 | 2516 (cond ((ad-lambda-p definition) |
2517 definition) | |
2518 ((ad-macro-p definition) | |
2519 (ad-lambdafy definition)) | |
2520 ((ad-advice-p definition) | |
2521 (cdr definition)) | |
2522 (t nil))) | |
2523 | |
2524 (defun ad-arglist (definition &optional name) | |
26217 | 2525 "Return the argument list of DEFINITION. |
2526 If DEFINITION could be from a subr then its NAME should be | |
2527 supplied to make subr arglist lookup more efficient." | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2528 (cond ((ad-compiled-p definition) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2529 (aref (ad-compiled-code definition) 0)) |
4110 | 2530 ((consp definition) |
2531 (car (cdr (ad-lambda-expression definition)))) | |
2532 ((ad-subr-p definition) | |
2533 (if name | |
2534 (ad-subr-arglist name) | |
2535 ;; otherwise get it from its printed representation: | |
2536 (setq name (format "%s" definition)) | |
2537 (string-match "^#<subr \\([^>]+\\)>$" name) | |
50800
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2538 (ad-subr-arglist (intern (match-string 1 name))))))) |
4110 | 2539 |
2540 ;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish | |
2541 ;; a defined empty arglist `(nil)' from an undefined arglist: | |
2542 (defmacro ad-define-subr-args (subr arglist) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2543 `(put ,subr 'ad-subr-arglist (list ,arglist))) |
4110 | 2544 (defmacro ad-undefine-subr-args (subr) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2545 `(put ,subr 'ad-subr-arglist nil)) |
4110 | 2546 (defmacro ad-subr-args-defined-p (subr) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2547 `(get ,subr 'ad-subr-arglist)) |
4110 | 2548 (defmacro ad-get-subr-args (subr) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2549 `(car (get ,subr 'ad-subr-arglist))) |
4110 | 2550 |
2551 (defun ad-subr-arglist (subr-name) | |
26217 | 2552 "Retrieve arglist of the subr with SUBR-NAME. |
2553 Either use the one stored under the `ad-subr-arglist' property, | |
2554 or try to retrieve it from the docstring and cache it under | |
2555 that property, or otherwise use `(&rest ad-subr-args)'." | |
54493
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2556 (if (ad-subr-args-defined-p subr-name) |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2557 (ad-get-subr-args subr-name) |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2558 ;; says jwz: Should use this for Lemacs 19.8 and above: |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2559 ;;((fboundp 'subr-min-args) |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2560 ;; ...) |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2561 ;; says hans: I guess what Jamie means is that I should use the values |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2562 ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2563 ;; without having to look it up via parsing the docstring, e.g., |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2564 ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2565 ;; argument list. However, that won't work because there is no |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2566 ;; way to distinguish a subr with args `(a &optional b &rest c)' from |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2567 ;; one with args `(a &rest c)' using that mechanism. Also, the argument |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2568 ;; names from the docstring are more meaningful. Hence, I'll stick with |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2569 ;; the old way of doing things. |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2570 (let ((doc (or (ad-real-documentation subr-name t) ""))) |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2571 (if (not (string-match "\n\n\\((.+)\\)\\'" doc)) |
54509
e20bae3e3270
(ad-subr-arglist): Undo part of last patch.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54493
diff
changeset
|
2572 ;; Signalling an error leads to bugs during bootstrapping because |
e20bae3e3270
(ad-subr-arglist): Undo part of last patch.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54493
diff
changeset
|
2573 ;; the DOC file is not yet built (which is an error, BTW). |
e20bae3e3270
(ad-subr-arglist): Undo part of last patch.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54493
diff
changeset
|
2574 ;; (error "The usage info is missing from the subr %s" subr-name) |
e20bae3e3270
(ad-subr-arglist): Undo part of last patch.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54493
diff
changeset
|
2575 '(&rest ad-subr-args) |
54493
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2576 (ad-define-subr-args |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2577 subr-name |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2578 (cdr (car (read-from-string |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2579 (downcase (match-string 1 doc)))))) |
d8586f19729a
(ad-subr-arglist): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
2580 (ad-get-subr-args subr-name))))) |
4110 | 2581 |
2582 (defun ad-docstring (definition) | |
26217 | 2583 "Return the unexpanded docstring of DEFINITION." |
4110 | 2584 (let ((docstring |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2585 (if (ad-compiled-p definition) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2586 (ad-real-documentation definition t) |
4110 | 2587 (car (cdr (cdr (ad-lambda-expression definition))))))) |
2588 (if (or (stringp docstring) | |
2589 (natnump docstring)) | |
2590 docstring))) | |
2591 | |
82192
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
2592 (defun ad-interactive-form (definition) |
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
2593 "Return the interactive form of DEFINITION. |
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
2594 Like `interactive-form', but also works on pieces of advice." |
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
2595 (interactive-form |
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
2596 (if (ad-advice-p definition) |
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
2597 (ad-lambda-expression definition) |
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
2598 definition))) |
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
2599 |
4110 | 2600 (defun ad-body-forms (definition) |
26217 | 2601 "Return the list of body forms of DEFINITION." |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2602 (cond ((ad-compiled-p definition) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2603 nil) |
4110 | 2604 ((consp definition) |
2605 (nthcdr (+ (if (ad-docstring definition) 1 0) | |
82192
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
2606 (if (ad-interactive-form definition) 1 0)) |
4110 | 2607 (cdr (cdr (ad-lambda-expression definition))))))) |
2608 | |
2609 (defun ad-make-advised-definition-docstring (function) | |
26217 | 2610 "Make an identifying docstring for the advised definition of FUNCTION. |
2611 Put function name into the documentation string so we can infer | |
2612 the name of the advised function from the docstring. This is needed | |
2613 to generate a proper advised docstring even if we are just given a | |
85302
bc8b741390b0
(documentation): Advice deleted. Doc for advised functions
Richard M. Stallman <rms@gnu.org>
parents:
83896
diff
changeset
|
2614 definition (see the code for `documentation')." |
bc8b741390b0
(documentation): Advice deleted. Doc for advised functions
Richard M. Stallman <rms@gnu.org>
parents:
83896
diff
changeset
|
2615 (propertize "Advice doc string" 'ad-advice-info function)) |
4110 | 2616 |
2617 (defun ad-advised-definition-p (definition) | |
26217 | 2618 "Return non-nil if DEFINITION was generated from advice information." |
4110 | 2619 (if (or (ad-lambda-p definition) |
2620 (ad-macro-p definition) | |
2621 (ad-compiled-p definition)) | |
2622 (let ((docstring (ad-docstring definition))) | |
2623 (and (stringp docstring) | |
85302
bc8b741390b0
(documentation): Advice deleted. Doc for advised functions
Richard M. Stallman <rms@gnu.org>
parents:
83896
diff
changeset
|
2624 (get-text-property 0 'ad-advice-info docstring))))) |
4110 | 2625 |
2626 (defun ad-definition-type (definition) | |
26217 | 2627 "Return symbol that describes the type of DEFINITION." |
4110 | 2628 (if (ad-macro-p definition) |
2629 'macro | |
2630 (if (ad-subr-p definition) | |
2631 (if (ad-special-form-p definition) | |
2632 'special-form | |
2633 'subr) | |
2634 (if (or (ad-lambda-p definition) | |
2635 (ad-compiled-p definition)) | |
2636 'function | |
2637 (if (ad-advice-p definition) | |
2638 'advice))))) | |
2639 | |
2640 (defun ad-has-proper-definition (function) | |
26217 | 2641 "True if FUNCTION is a symbol with a proper definition. |
2642 For that it has to be fbound with a non-autoload definition." | |
4110 | 2643 (and (symbolp function) |
2644 (fboundp function) | |
2645 (not (eq (car-safe (symbol-function function)) 'autoload)))) | |
2646 | |
2647 ;; The following two are necessary for the sake of packages such as | |
2648 ;; ange-ftp which redefine functions via fcell indirection: | |
2649 (defun ad-real-definition (function) | |
26217 | 2650 "Find FUNCTION's definition at the end of function cell indirection." |
4110 | 2651 (if (ad-has-proper-definition function) |
2652 (let ((definition (symbol-function function))) | |
2653 (if (symbolp definition) | |
2654 (ad-real-definition definition) | |
2655 definition)))) | |
2656 | |
2657 (defun ad-real-orig-definition (function) | |
26217 | 2658 "Find FUNCTION's real original definition starting from its `origname'." |
4110 | 2659 (if (ad-is-advised function) |
2660 (ad-real-definition (ad-get-advice-info-field function 'origname)))) | |
2661 | |
2662 (defun ad-is-compilable (function) | |
26217 | 2663 "True if FUNCTION has an interpreted definition that can be compiled." |
4110 | 2664 (and (ad-has-proper-definition function) |
2665 (or (ad-lambda-p (symbol-function function)) | |
2666 (ad-macro-p (symbol-function function))) | |
2667 (not (ad-compiled-p (symbol-function function))))) | |
2668 | |
2669 (defun ad-compile-function (function) | |
2670 "Byte-compiles FUNCTION (or macro) if it is not yet compiled." | |
2671 (interactive "aByte-compile function: ") | |
2672 (if (ad-is-compilable function) | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2673 ;; Need to turn off auto-activation |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2674 ;; because `byte-compile' uses `fset': |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
2675 (ad-with-auto-activation-disabled |
46196
73cafacdf14f
(ad-compile-function): Disable cl-function warnings if cl is loaded.
Richard M. Stallman <rms@gnu.org>
parents:
45019
diff
changeset
|
2676 (require 'bytecomp) |
73cafacdf14f
(ad-compile-function): Disable cl-function warnings if cl is loaded.
Richard M. Stallman <rms@gnu.org>
parents:
45019
diff
changeset
|
2677 (let ((symbol (make-symbol "advice-compilation")) |
85729
bd2837f89a3b
(ad-compile-function): Use byte-compile-disable-warning.
Glenn Morris <rgm@gnu.org>
parents:
85584
diff
changeset
|
2678 (byte-compile-warnings byte-compile-warnings)) |
46196
73cafacdf14f
(ad-compile-function): Disable cl-function warnings if cl is loaded.
Richard M. Stallman <rms@gnu.org>
parents:
45019
diff
changeset
|
2679 (if (featurep 'cl) |
85729
bd2837f89a3b
(ad-compile-function): Use byte-compile-disable-warning.
Glenn Morris <rgm@gnu.org>
parents:
85584
diff
changeset
|
2680 (byte-compile-disable-warning 'cl-functions)) |
41936 | 2681 (fset symbol (symbol-function function)) |
2682 (byte-compile symbol) | |
2683 (fset function (symbol-function symbol)))))) | |
4110 | 2684 |
2685 | |
2686 ;; @@ Constructing advised definitions: | |
2687 ;; ==================================== | |
2688 ;; | |
2689 ;; Main design decisions about the form of advised definitions: | |
2690 ;; | |
2691 ;; A) How will original definitions be called? | |
2692 ;; B) What will argument lists of advised functions look like? | |
2693 ;; | |
2694 ;; Ad A) | |
2695 ;; I chose to use function indirection for all four types of original | |
2696 ;; definitions (functions, macros, subrs and special forms), i.e., create | |
2697 ;; a unique symbol `ad-Orig-<name>' which is fbound to the original | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2698 ;; definition and call it according to type and arguments. Functions and |
4110 | 2699 ;; subrs that don't have any &rest arguments can be called directly in a |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2700 ;; `(ad-Orig-<name> ....)' form. If they have a &rest argument we have to |
26217 | 2701 ;; use `apply'. Macros will be called with |
4110 | 2702 ;; `(macroexpand '(ad-Orig-<name> ....))', and special forms also need a |
2703 ;; form like that with `eval' instead of `macroexpand'. | |
2704 ;; | |
2705 ;; Ad B) | |
2706 ;; Use original arguments where possible and `(&rest ad-subr-args)' | |
2707 ;; otherwise, even though this seems to be more complicated and less | |
2708 ;; uniform than a general `(&rest args)' approach. My reason to still | |
2709 ;; do it that way is that in most cases my approach leads to the more | |
2710 ;; efficient form for the advised function, and portability (e.g., to | |
2711 ;; make the same advice work regardless of whether something is a | |
2712 ;; function or a subr) can still be achieved with argument access macros. | |
2713 | |
2714 | |
2715 (defun ad-prognify (forms) | |
2716 (cond ((<= (length forms) 1) | |
2717 (car forms)) | |
2718 (t (cons 'progn forms)))) | |
2719 | |
2720 ;; @@@ Accessing argument lists: | |
2721 ;; ============================= | |
2722 | |
2723 (defun ad-parse-arglist (arglist) | |
26217 | 2724 "Parse ARGLIST into its required, optional and rest parameters. |
2725 A three-element list is returned, where the 1st element is the list of | |
2726 required arguments, the 2nd is the list of optional arguments, and the 3rd | |
2727 is the name of an optional rest parameter (or nil)." | |
73251
25e1db3fd0ed
(ad-remove-advice, ad-parse-arglist, ad-make-mapped-call):
Juanma Barranquero <lekktu@gmail.com>
parents:
70899
diff
changeset
|
2728 (let (required optional rest) |
4110 | 2729 (setq rest (car (cdr (memq '&rest arglist)))) |
2730 (if rest (setq arglist (reverse (cdr (memq '&rest (reverse arglist)))))) | |
2731 (setq optional (cdr (memq '&optional arglist))) | |
2732 (if optional | |
2733 (setq required (reverse (cdr (memq '&optional (reverse arglist))))) | |
2734 (setq required arglist)) | |
2735 (list required optional rest))) | |
2736 | |
2737 (defun ad-retrieve-args-form (arglist) | |
26217 | 2738 "Generate a form which evaluates into names/values/types of ARGLIST. |
2739 When the form gets evaluated within a function with that argument list | |
2740 it will result in a list with one entry for each argument, where the | |
2741 first element of each entry is the name of the argument, the second | |
2742 element is its actual current value, and the third element is either | |
2743 `required', `optional' or `rest' depending on the type of the argument." | |
4110 | 2744 (let* ((parsed-arglist (ad-parse-arglist arglist)) |
2745 (rest (nth 2 parsed-arglist))) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2746 `(list |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2747 ,@(mapcar (function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2748 (lambda (req) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2749 `(list ',req ,req 'required))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2750 (nth 0 parsed-arglist)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2751 ,@(mapcar (function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2752 (lambda (opt) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2753 `(list ',opt ,opt 'optional))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2754 (nth 1 parsed-arglist)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2755 ,@(if rest (list `(list ',rest ,rest 'rest)))))) |
4110 | 2756 |
2757 (defun ad-arg-binding-field (binding field) | |
2758 (cond ((eq field 'name) (car binding)) | |
2759 ((eq field 'value) (car (cdr binding))) | |
2760 ((eq field 'type) (car (cdr (cdr binding)))))) | |
2761 | |
2762 (defun ad-list-access (position list) | |
2763 (cond ((= position 0) list) | |
2764 ((= position 1) (list 'cdr list)) | |
2765 (t (list 'nthcdr position list)))) | |
2766 | |
2767 (defun ad-element-access (position list) | |
2768 (cond ((= position 0) (list 'car list)) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2769 ((= position 1) `(car (cdr ,list))) |
4110 | 2770 (t (list 'nth position list)))) |
2771 | |
2772 (defun ad-access-argument (arglist index) | |
26217 | 2773 "Tell how to access ARGLIST's actual argument at position INDEX. |
2774 For a required/optional arg it simply returns it, if a rest argument has | |
2775 to be accessed, it returns a list with the index and name." | |
4110 | 2776 (let* ((parsed-arglist (ad-parse-arglist arglist)) |
2777 (reqopt-args (append (nth 0 parsed-arglist) | |
2778 (nth 1 parsed-arglist))) | |
2779 (rest-arg (nth 2 parsed-arglist))) | |
2780 (cond ((< index (length reqopt-args)) | |
2781 (nth index reqopt-args)) | |
2782 (rest-arg | |
2783 (list (- index (length reqopt-args)) rest-arg))))) | |
2784 | |
2785 (defun ad-get-argument (arglist index) | |
26217 | 2786 "Return form to access ARGLIST's actual argument at position INDEX." |
4110 | 2787 (let ((argument-access (ad-access-argument arglist index))) |
2788 (cond ((consp argument-access) | |
2789 (ad-element-access | |
2790 (car argument-access) (car (cdr argument-access)))) | |
2791 (argument-access)))) | |
2792 | |
2793 (defun ad-set-argument (arglist index value-form) | |
26217 | 2794 "Return form to set ARGLIST's actual arg at INDEX to VALUE-FORM." |
4110 | 2795 (let ((argument-access (ad-access-argument arglist index))) |
2796 (cond ((consp argument-access) | |
2797 ;; should this check whether there actually is something to set? | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2798 `(setcar ,(ad-list-access |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2799 (car argument-access) (car (cdr argument-access))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2800 ,value-form)) |
4110 | 2801 (argument-access |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2802 `(setq ,argument-access ,value-form)) |
4110 | 2803 (t (error "ad-set-argument: No argument at position %d of `%s'" |
2804 index arglist))))) | |
2805 | |
2806 (defun ad-get-arguments (arglist index) | |
26217 | 2807 "Return form to access all actual arguments starting at position INDEX." |
4110 | 2808 (let* ((parsed-arglist (ad-parse-arglist arglist)) |
2809 (reqopt-args (append (nth 0 parsed-arglist) | |
2810 (nth 1 parsed-arglist))) | |
2811 (rest-arg (nth 2 parsed-arglist)) | |
2812 args-form) | |
2813 (if (< index (length reqopt-args)) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2814 (setq args-form `(list ,@(nthcdr index reqopt-args)))) |
4110 | 2815 (if rest-arg |
2816 (if args-form | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2817 (setq args-form `(nconc ,args-form ,rest-arg)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2818 (setq args-form (ad-list-access (- index (length reqopt-args)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2819 rest-arg)))) |
4110 | 2820 args-form)) |
2821 | |
2822 (defun ad-set-arguments (arglist index values-form) | |
26217 | 2823 "Make form to assign elements of VALUES-FORM as actual ARGLIST args. |
2824 The assignment starts at position INDEX." | |
4110 | 2825 (let ((values-index 0) |
2826 argument-access set-forms) | |
2827 (while (setq argument-access (ad-access-argument arglist index)) | |
2828 (if (symbolp argument-access) | |
2829 (setq set-forms | |
2830 (cons (ad-set-argument | |
2831 arglist index | |
2832 (ad-element-access values-index 'ad-vAlUeS)) | |
2833 set-forms)) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2834 (setq set-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2835 (cons (if (= (car argument-access) 0) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2836 (list 'setq |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2837 (car (cdr argument-access)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2838 (ad-list-access values-index 'ad-vAlUeS)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2839 (list 'setcdr |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2840 (ad-list-access (1- (car argument-access)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2841 (car (cdr argument-access))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2842 (ad-list-access values-index 'ad-vAlUeS))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2843 set-forms)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2844 ;; terminate loop |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2845 (setq arglist nil)) |
4110 | 2846 (setq index (1+ index)) |
2847 (setq values-index (1+ values-index))) | |
2848 (if (null set-forms) | |
2849 (error "ad-set-arguments: No argument at position %d of `%s'" | |
2850 index arglist) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2851 (if (= (length set-forms) 1) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2852 ;; For exactly one set-form we can use values-form directly,... |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2853 (ad-substitute-tree |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2854 (function (lambda (form) (eq form 'ad-vAlUeS))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2855 (function (lambda (form) values-form)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2856 (car set-forms)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2857 ;; ...if we have more we have to bind it to a variable: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2858 `(let ((ad-vAlUeS ,values-form)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2859 ,@(reverse set-forms) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2860 ;; work around the old backquote bug: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
2861 ,'ad-vAlUeS))))) |
4110 | 2862 |
2863 (defun ad-insert-argument-access-forms (definition arglist) | |
26217 | 2864 "Expands arg-access text macros in DEFINITION according to ARGLIST." |
4110 | 2865 (ad-substitute-tree |
2866 (function | |
2867 (lambda (form) | |
2868 (or (eq form 'ad-arg-bindings) | |
2869 (and (memq (car-safe form) | |
2870 '(ad-get-arg ad-get-args ad-set-arg ad-set-args)) | |
2871 (integerp (car-safe (cdr form))))))) | |
2872 (function | |
2873 (lambda (form) | |
2874 (if (eq form 'ad-arg-bindings) | |
2875 (ad-retrieve-args-form arglist) | |
2876 (let ((accessor (car form)) | |
2877 (index (car (cdr form))) | |
2878 (val (car (cdr (ad-insert-argument-access-forms | |
2879 (cdr form) arglist))))) | |
2880 (cond ((eq accessor 'ad-get-arg) | |
2881 (ad-get-argument arglist index)) | |
2882 ((eq accessor 'ad-set-arg) | |
2883 (ad-set-argument arglist index val)) | |
2884 ((eq accessor 'ad-get-args) | |
2885 (ad-get-arguments arglist index)) | |
2886 ((eq accessor 'ad-set-args) | |
2887 (ad-set-arguments arglist index val))))))) | |
2888 definition)) | |
2889 | |
2890 ;; @@@ Mapping argument lists: | |
2891 ;; =========================== | |
2892 ;; Here is the problem: | |
2893 ;; Suppose function foo was called with (foo 1 2 3 4 5), and foo has the | |
2894 ;; argument list (x y &rest z), and we want to call the function bar which | |
2895 ;; has argument list (a &rest b) with a combination of x, y and z so that | |
26217 | 2896 ;; the effect is just as if we had called (bar 1 2 3 4 5) directly. |
4110 | 2897 ;; The mapping should work for any two argument lists. |
2898 | |
2899 (defun ad-map-arglists (source-arglist target-arglist) | |
26217 | 2900 "Make `funcall/apply' form to map SOURCE-ARGLIST to TARGET-ARGLIST. |
4110 | 2901 The arguments supplied to TARGET-ARGLIST will be taken from SOURCE-ARGLIST just |
26217 | 2902 as if they had been supplied to a function with TARGET-ARGLIST directly. |
2903 Excess source arguments will be neglected, missing source arguments will be | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2904 supplied as nil. Returns a `funcall' or `apply' form with the second element |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2905 being `function' which has to be replaced by an actual function argument. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2906 Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2907 `(funcall function a (car args) (car (cdr args)) (nth 2 args))'." |
4110 | 2908 (let* ((parsed-source-arglist (ad-parse-arglist source-arglist)) |
2909 (source-reqopt-args (append (nth 0 parsed-source-arglist) | |
2910 (nth 1 parsed-source-arglist))) | |
2911 (source-rest-arg (nth 2 parsed-source-arglist)) | |
2912 (parsed-target-arglist (ad-parse-arglist target-arglist)) | |
2913 (target-reqopt-args (append (nth 0 parsed-target-arglist) | |
2914 (nth 1 parsed-target-arglist))) | |
2915 (target-rest-arg (nth 2 parsed-target-arglist)) | |
2916 (need-apply (and source-rest-arg target-rest-arg)) | |
2917 (target-arg-index -1)) | |
2918 ;; This produces ``error-proof'' target function calls with the exception | |
2919 ;; of a case like (&rest a) mapped onto (x &rest y) where the actual args | |
2920 ;; supplied to A might not be enough to supply the required target arg X | |
2921 (append (list (if need-apply 'apply 'funcall) 'function) | |
2922 (cond (need-apply | |
2923 ;; `apply' can take care of that directly: | |
2924 (append source-reqopt-args (list source-rest-arg))) | |
2925 (t (mapcar (function | |
2926 (lambda (arg) | |
2927 (setq target-arg-index (1+ target-arg-index)) | |
2928 (ad-get-argument | |
2929 source-arglist target-arg-index))) | |
2930 (append target-reqopt-args | |
2931 (and target-rest-arg | |
2932 ;; If we have a rest arg gobble up | |
2933 ;; remaining source args: | |
2934 (nthcdr (length target-reqopt-args) | |
2935 source-reqopt-args))))))))) | |
2936 | |
2937 (defun ad-make-mapped-call (source-arglist target-arglist target-function) | |
26217 | 2938 "Make form to call TARGET-FUNCTION with args from SOURCE-ARGLIST." |
73251
25e1db3fd0ed
(ad-remove-advice, ad-parse-arglist, ad-make-mapped-call):
Juanma Barranquero <lekktu@gmail.com>
parents:
70899
diff
changeset
|
2939 (let ((mapped-form (ad-map-arglists source-arglist target-arglist))) |
4110 | 2940 (if (eq (car mapped-form) 'funcall) |
2941 (cons target-function (cdr (cdr mapped-form))) | |
2942 (prog1 mapped-form | |
2943 (setcar (cdr mapped-form) (list 'quote target-function)))))) | |
2944 | |
2945 ;; @@@ Making an advised documentation string: | |
2946 ;; =========================================== | |
2947 ;; New policy: The documentation string for an advised function will be built | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2948 ;; at the time the advised `documentation' function is called. This has the |
4110 | 2949 ;; following advantages: |
2950 ;; 1) command-key substitutions will automatically be correct | |
2951 ;; 2) No wasted string space due to big advised docstrings in caches or | |
2952 ;; compiled files that contain preactivations | |
2953 ;; The overall overhead for this should be negligible because people normally | |
2954 ;; don't lookup documentation for the same function over and over again. | |
2955 | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2956 (defun ad-make-single-advice-docstring (advice class &optional style) |
4110 | 2957 (let ((advice-docstring (ad-docstring (ad-advice-definition advice)))) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2958 (cond ((eq style 'plain) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2959 advice-docstring) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2960 ((eq style 'freeze) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2961 (format "Permanent %s-advice `%s':%s%s" |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2962 class (ad-advice-name advice) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2963 (if advice-docstring "\n" "") |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2964 (or advice-docstring ""))) |
25208
76f5f50e7742
(ad-make-single-advice-docstring): Treat case with no doctring specially.
Dave Love <fx@gnu.org>
parents:
24875
diff
changeset
|
2965 (t (if advice-docstring |
76f5f50e7742
(ad-make-single-advice-docstring): Treat case with no doctring specially.
Dave Love <fx@gnu.org>
parents:
24875
diff
changeset
|
2966 (format "%s-advice `%s':\n%s" |
76f5f50e7742
(ad-make-single-advice-docstring): Treat case with no doctring specially.
Dave Love <fx@gnu.org>
parents:
24875
diff
changeset
|
2967 (capitalize (symbol-name class)) |
76f5f50e7742
(ad-make-single-advice-docstring): Treat case with no doctring specially.
Dave Love <fx@gnu.org>
parents:
24875
diff
changeset
|
2968 (ad-advice-name advice) |
76f5f50e7742
(ad-make-single-advice-docstring): Treat case with no doctring specially.
Dave Love <fx@gnu.org>
parents:
24875
diff
changeset
|
2969 advice-docstring) |
76f5f50e7742
(ad-make-single-advice-docstring): Treat case with no doctring specially.
Dave Love <fx@gnu.org>
parents:
24875
diff
changeset
|
2970 (format "%s-advice `%s'." |
76f5f50e7742
(ad-make-single-advice-docstring): Treat case with no doctring specially.
Dave Love <fx@gnu.org>
parents:
24875
diff
changeset
|
2971 (capitalize (symbol-name class)) |
76f5f50e7742
(ad-make-single-advice-docstring): Treat case with no doctring specially.
Dave Love <fx@gnu.org>
parents:
24875
diff
changeset
|
2972 (ad-advice-name advice))))))) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2973 |
50800
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2974 (require 'help-fns) ;For help-split-fundoc and help-add-fundoc-usage. |
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2975 |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2976 (defun ad-make-advised-docstring (function &optional style) |
50800
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2977 "Construct a documentation string for the advised FUNCTION. |
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2978 It concatenates the original documentation with the documentation |
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2979 strings of the individual pieces of advice which will be formatted |
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2980 according to STYLE. STYLE can be `plain' or `freeze', everything else |
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2981 will be interpreted as `default'. The order of the advice documentation |
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2982 strings corresponds to before/around/after and the individual ordering |
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2983 in any of these classes." |
4110 | 2984 (let* ((origdef (ad-real-orig-definition function)) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2985 (origtype (symbol-name (ad-definition-type origdef))) |
4110 | 2986 (origdoc |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2987 ;; Retrieve raw doc, key substitution will be taken care of later: |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2988 (ad-real-documentation origdef t)) |
50800
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2989 (usage (help-split-fundoc origdoc function)) |
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2990 paragraphs advice-docstring ad-usage) |
50842
b64d29a02737
(ad-make-advised-docstring): Adjust usage for new help-add-fundoc-usage.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
50800
diff
changeset
|
2991 (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2992 (if origdoc (setq paragraphs (list origdoc))) |
50800
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
2993 (unless (eq style 'plain) |
83896
0fc42eec71c0
Johan Bockg? <bojohan at dd.chalmers.se>
Glenn Morris <rgm@gnu.org>
parents:
82192
diff
changeset
|
2994 (push (propertize (concat "This " origtype " is advised.") |
0fc42eec71c0
Johan Bockg? <bojohan at dd.chalmers.se>
Glenn Morris <rgm@gnu.org>
parents:
82192
diff
changeset
|
2995 'face 'font-lock-warning-face) |
0fc42eec71c0
Johan Bockg? <bojohan at dd.chalmers.se>
Glenn Morris <rgm@gnu.org>
parents:
82192
diff
changeset
|
2996 paragraphs)) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2997 (ad-dolist (class ad-advice-classes) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2998 (ad-dolist (advice (ad-get-enabled-advices function class)) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
2999 (setq advice-docstring |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3000 (ad-make-single-advice-docstring advice class style)) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3001 (if advice-docstring |
50800
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
3002 (push advice-docstring paragraphs)))) |
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
3003 (setq origdoc (if paragraphs |
85584
91aa73da6526
(ad-make-advised-docstring): Add ad-advice-info text property to doc string.
Juanma Barranquero <lekktu@gmail.com>
parents:
85320
diff
changeset
|
3004 (propertize |
91aa73da6526
(ad-make-advised-docstring): Add ad-advice-info text property to doc string.
Juanma Barranquero <lekktu@gmail.com>
parents:
85320
diff
changeset
|
3005 ;; separate paragraphs with blank lines: |
91aa73da6526
(ad-make-advised-docstring): Add ad-advice-info text property to doc string.
Juanma Barranquero <lekktu@gmail.com>
parents:
85320
diff
changeset
|
3006 (mapconcat 'identity (nreverse paragraphs) "\n\n") |
91aa73da6526
(ad-make-advised-docstring): Add ad-advice-info text property to doc string.
Juanma Barranquero <lekktu@gmail.com>
parents:
85320
diff
changeset
|
3007 'ad-advice-info function))) |
50800
7fe53d25e220
(ad-get-enabled-advices, ad-special-forms)
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
46196
diff
changeset
|
3008 (help-add-fundoc-usage origdoc usage))) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3009 |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3010 (defun ad-make-plain-docstring (function) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3011 (ad-make-advised-docstring function 'plain)) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3012 (defun ad-make-freeze-docstring (function) |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3013 (ad-make-advised-docstring function 'freeze)) |
4110 | 3014 |
3015 ;; @@@ Accessing overriding arglists and interactive forms: | |
3016 ;; ======================================================== | |
3017 | |
3018 (defun ad-advised-arglist (function) | |
26217 | 3019 "Find first defined arglist in FUNCTION's redefining advices." |
4110 | 3020 (ad-dolist (advice (append (ad-get-enabled-advices function 'before) |
3021 (ad-get-enabled-advices function 'around) | |
3022 (ad-get-enabled-advices function 'after))) | |
3023 (let ((arglist (ad-arglist (ad-advice-definition advice)))) | |
3024 (if arglist | |
3025 ;; We found the first one, use it: | |
3026 (ad-do-return arglist))))) | |
3027 | |
3028 (defun ad-advised-interactive-form (function) | |
26217 | 3029 "Find first interactive form in FUNCTION's redefining advices." |
4110 | 3030 (ad-dolist (advice (append (ad-get-enabled-advices function 'before) |
3031 (ad-get-enabled-advices function 'around) | |
3032 (ad-get-enabled-advices function 'after))) | |
3033 (let ((interactive-form | |
82192
5800574abbcb
(ad-interactive-form): Re-introduce.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82146
diff
changeset
|
3034 (ad-interactive-form (ad-advice-definition advice)))) |
4110 | 3035 (if interactive-form |
3036 ;; We found the first one, use it: | |
3037 (ad-do-return interactive-form))))) | |
3038 | |
3039 ;; @@@ Putting it all together: | |
3040 ;; ============================ | |
3041 | |
3042 (defun ad-make-advised-definition (function) | |
26217 | 3043 "Generate an advised definition of FUNCTION from its advice info." |
4110 | 3044 (if (and (ad-is-advised function) |
3045 (ad-has-redefining-advice function)) | |
3046 (let* ((origdef (ad-real-orig-definition function)) | |
3047 (origname (ad-get-advice-info-field function 'origname)) | |
82146
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3048 (orig-interactive-p (commandp origdef)) |
4110 | 3049 (orig-subr-p (ad-subr-p origdef)) |
3050 (orig-special-form-p (ad-special-form-p origdef)) | |
3051 (orig-macro-p (ad-macro-p origdef)) | |
3052 ;; Construct the individual pieces that we need for assembly: | |
3053 (orig-arglist (ad-arglist origdef function)) | |
3054 (advised-arglist (or (ad-advised-arglist function) | |
3055 orig-arglist)) | |
3056 (advised-interactive-form (ad-advised-interactive-form function)) | |
3057 (interactive-form | |
3058 (cond (orig-macro-p nil) | |
3059 (advised-interactive-form) | |
82146
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3060 ((interactive-form origdef) |
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3061 (interactive-form |
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3062 (if (and (symbolp function) (get function 'elp-info)) |
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3063 (aref (get function 'elp-info) 2) |
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3064 origdef))))) |
4110 | 3065 (orig-form |
3066 (cond ((or orig-special-form-p orig-macro-p) | |
3067 ;; Special forms and macros will be advised into macros. | |
3068 ;; The trick is to construct an expansion for the advised | |
3069 ;; macro that does the correct thing when it gets eval'ed. | |
3070 ;; For macros we'll just use the expansion of the original | |
3071 ;; macro and return that. This way compiled advised macros | |
3072 ;; will be expanded into something useful. Note that after | |
3073 ;; advices have full control over whether they want to | |
3074 ;; evaluate the expansion (the value of `ad-return-value') | |
3075 ;; at macro expansion time or not. For special forms there | |
3076 ;; is no solution that interacts reasonably with the | |
3077 ;; compiler, hence we just evaluate the original at macro | |
3078 ;; expansion time and return the result. The moral of that | |
3079 ;; is that one should always deactivate advised special | |
3080 ;; forms before one byte-compiles a file. | |
37304
9ca19dfc32fb
(ad-make-advised-definition): Construct
Gerd Moellmann <gerd@gnu.org>
parents:
37056
diff
changeset
|
3081 `(,(if orig-macro-p 'macroexpand 'eval) |
9ca19dfc32fb
(ad-make-advised-definition): Construct
Gerd Moellmann <gerd@gnu.org>
parents:
37056
diff
changeset
|
3082 (cons ',origname |
9ca19dfc32fb
(ad-make-advised-definition): Construct
Gerd Moellmann <gerd@gnu.org>
parents:
37056
diff
changeset
|
3083 ,(ad-get-arguments advised-arglist 0)))) |
4110 | 3084 ((and orig-subr-p |
3085 orig-interactive-p | |
37304
9ca19dfc32fb
(ad-make-advised-definition): Construct
Gerd Moellmann <gerd@gnu.org>
parents:
37056
diff
changeset
|
3086 (not interactive-form) |
4110 | 3087 (not advised-interactive-form)) |
3088 ;; Check whether we were called interactively | |
3089 ;; in order to do proper prompting: | |
57879
7b2c608f3b0b
(ad-make-advised-definition): Use called-interactively-p.
Richard M. Stallman <rms@gnu.org>
parents:
54509
diff
changeset
|
3090 `(if (called-interactively-p) |
37304
9ca19dfc32fb
(ad-make-advised-definition): Construct
Gerd Moellmann <gerd@gnu.org>
parents:
37056
diff
changeset
|
3091 (call-interactively ',origname) |
66398
df04170ba46b
(ad-make-advised-definition): Fix arg-order.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
65680
diff
changeset
|
3092 ,(ad-make-mapped-call advised-arglist |
df04170ba46b
(ad-make-advised-definition): Fix arg-order.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
65680
diff
changeset
|
3093 orig-arglist |
37304
9ca19dfc32fb
(ad-make-advised-definition): Construct
Gerd Moellmann <gerd@gnu.org>
parents:
37056
diff
changeset
|
3094 origname))) |
4110 | 3095 ;; And now for normal functions and non-interactive subrs |
3096 ;; (or subrs whose interactive behavior was advised): | |
3097 (t (ad-make-mapped-call | |
3098 advised-arglist orig-arglist origname))))) | |
3099 | |
3100 ;; Finally, build the sucker: | |
3101 (ad-assemble-advised-definition | |
3102 (cond (orig-macro-p 'macro) | |
3103 (orig-special-form-p 'special-form) | |
3104 (t 'function)) | |
3105 advised-arglist | |
3106 (ad-make-advised-definition-docstring function) | |
3107 interactive-form | |
3108 orig-form | |
3109 (ad-get-enabled-advices function 'before) | |
3110 (ad-get-enabled-advices function 'around) | |
3111 (ad-get-enabled-advices function 'after))))) | |
3112 | |
3113 (defun ad-assemble-advised-definition | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3114 (type args docstring interactive orig &optional befores arounds afters) |
4110 | 3115 |
26217 | 3116 "Assembles an original and its advices into an advised function. |
3117 It constructs a function or macro definition according to TYPE which has to | |
3118 be either `macro', `function' or `special-form'. ARGS is the argument list | |
3119 that has to be used, DOCSTRING if non-nil defines the documentation of the | |
3120 definition, INTERACTIVE if non-nil is the interactive form to be used, | |
3121 ORIG is a form that calls the body of the original unadvised function, | |
3122 and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG | |
3123 should be modified. The assembled function will be returned." | |
4110 | 3124 |
3125 (let (before-forms around-form around-form-protected after-forms definition) | |
3126 (ad-dolist (advice befores) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3127 (cond ((and (ad-advice-protected advice) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3128 before-forms) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3129 (setq before-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3130 `((unwind-protect |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3131 ,(ad-prognify before-forms) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3132 ,@(ad-body-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3133 (ad-advice-definition advice)))))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3134 (t (setq before-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3135 (append before-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3136 (ad-body-forms (ad-advice-definition advice))))))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3137 |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3138 (setq around-form `(setq ad-return-value ,orig)) |
4110 | 3139 (ad-dolist (advice (reverse arounds)) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3140 ;; If any of the around advices is protected then we |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3141 ;; protect the complete around advice onion: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3142 (if (ad-advice-protected advice) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3143 (setq around-form-protected t)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3144 (setq around-form |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3145 (ad-substitute-tree |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3146 (function (lambda (form) (eq form 'ad-do-it))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3147 (function (lambda (form) around-form)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3148 (ad-prognify (ad-body-forms (ad-advice-definition advice)))))) |
4110 | 3149 |
3150 (setq after-forms | |
3151 (if (and around-form-protected before-forms) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3152 `((unwind-protect |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3153 ,(ad-prognify before-forms) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3154 ,around-form)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3155 (append before-forms (list around-form)))) |
4110 | 3156 (ad-dolist (advice afters) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3157 (cond ((and (ad-advice-protected advice) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3158 after-forms) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3159 (setq after-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3160 `((unwind-protect |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3161 ,(ad-prognify after-forms) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3162 ,@(ad-body-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3163 (ad-advice-definition advice)))))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3164 (t (setq after-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3165 (append after-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3166 (ad-body-forms (ad-advice-definition advice))))))) |
4110 | 3167 |
3168 (setq definition | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3169 `(,@(if (memq type '(macro special-form)) '(macro)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3170 lambda |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3171 ,args |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3172 ,@(if docstring (list docstring)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3173 ,@(if interactive (list interactive)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3174 (let (ad-return-value) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3175 ,@after-forms |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3176 ,(if (eq type 'special-form) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3177 '(list 'quote ad-return-value) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3178 'ad-return-value)))) |
4110 | 3179 |
3180 (ad-insert-argument-access-forms definition args))) | |
3181 | |
3182 ;; This is needed for activation/deactivation hooks: | |
3183 (defun ad-make-hook-form (function hook-name) | |
26217 | 3184 "Make hook-form from FUNCTION's advice bodies in class HOOK-NAME." |
4110 | 3185 (let ((hook-forms |
3186 (mapcar (function (lambda (advice) | |
3187 (ad-body-forms (ad-advice-definition advice)))) | |
3188 (ad-get-enabled-advices function hook-name)))) | |
3189 (if hook-forms | |
3190 (ad-prognify (apply 'append hook-forms))))) | |
3191 | |
3192 | |
3193 ;; @@ Caching: | |
3194 ;; =========== | |
3195 ;; Generating an advised definition of a function is moderately expensive, | |
3196 ;; hence, it makes sense to cache it so we can reuse it in appropriate | |
3197 ;; circumstances. Of course, it only makes sense to reuse a cached | |
3198 ;; definition if the current advice and function definition state is the | |
3199 ;; same as it was at the time when the cached definition was generated. | |
3200 ;; For that purpose we associate every cache with an id so we can verify | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3201 ;; if it is still valid at a certain point in time. This id mechanism |
4110 | 3202 ;; makes it possible to preactivate advised functions, write the compiled |
3203 ;; advised definitions to a file and reuse them during the actual | |
3204 ;; activation without having to risk that the resulting definition will be | |
3205 ;; incorrect, well, almost. | |
3206 ;; | |
3207 ;; A cache id is a list with six elements: | |
3208 ;; 1) the list of names of enabled before advices | |
3209 ;; 2) the list of names of enabled around advices | |
3210 ;; 3) the list of names of enabled after advices | |
3211 ;; 4) the type of the original function (macro, subr, etc.) | |
3212 ;; 5) the arglist of the original definition (or t if it was equal to the | |
3213 ;; arglist of the cached definition) | |
3214 ;; 6) t if the interactive form of the original definition was equal to the | |
3215 ;; interactive form of the cached definition | |
3216 ;; | |
3217 ;; Here's how a cache can get invalidated or be incorrect: | |
3218 ;; A) a piece of advice used in the cache gets redefined | |
3219 ;; B) the current list of enabled advices is different from the ones used | |
3220 ;; for the cache | |
3221 ;; C) the type of the original function changed, e.g., a function became a | |
3222 ;; macro, or a subr became a function | |
3223 ;; D) the arglist of the original function changed | |
3224 ;; E) the interactive form of the original function changed | |
3225 ;; F) a piece of advice used in the cache got redefined before the | |
3226 ;; defadvice with the cached definition got loaded: This is a PROBLEM! | |
3227 ;; | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3228 ;; Cases A and B are the normal ones. A is taken care of by `ad-add-advice' |
4110 | 3229 ;; which clears the cache in such a case, B is easily checked during |
3230 ;; verification at activation time. | |
3231 ;; | |
3232 ;; Cases C, D and E have to be considered if one is slightly paranoid, i.e., | |
3233 ;; if one considers the case that the original function could be different | |
3234 ;; from the one available at caching time (e.g., for forward advice of | |
3235 ;; functions that get redefined by some packages - such as `eval-region' gets | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3236 ;; redefined by edebug). All these cases can be easily checked during |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3237 ;; verification. Element 4 of the id lets one check case C, element 5 takes |
4110 | 3238 ;; care of case D (using t in the equality case saves some space, because the |
3239 ;; arglist can be recovered at validation time from the cached definition), | |
3240 ;; and element 6 takes care of case E which is only a problem if the original | |
3241 ;; was actually a function whose interactive form was not overridden by a | |
3242 ;; piece of advice. | |
3243 ;; | |
3244 ;; Case F is the only one which will lead to an incorrect advised function. | |
3245 ;; There is no way to avoid this without storing the complete advice definition | |
3246 ;; in the cache-id which is not feasible. | |
3247 ;; | |
3248 ;; The cache-id of a typical advised function with one piece of advice and | |
3249 ;; no arglist redefinition takes 7 conses which is a small price to pay for | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3250 ;; the added efficiency. The validation itself is also pretty cheap, certainly |
4110 | 3251 ;; a lot cheaper than reconstructing an advised definition. |
3252 | |
3253 (defmacro ad-get-cache-definition (function) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3254 `(car (ad-get-advice-info-field ,function 'cache))) |
4110 | 3255 |
3256 (defmacro ad-get-cache-id (function) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3257 `(cdr (ad-get-advice-info-field ,function 'cache))) |
4110 | 3258 |
3259 (defmacro ad-set-cache (function definition id) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3260 `(ad-set-advice-info-field |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3261 ,function 'cache (cons ,definition ,id))) |
4110 | 3262 |
3263 (defun ad-clear-cache (function) | |
3264 "Clears a previously cached advised definition of FUNCTION. | |
3265 Clear the cache if you want to force `ad-activate' to construct a new | |
3266 advised definition from scratch." | |
3267 (interactive | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
3268 (list (ad-read-advised-function "Clear cached definition of"))) |
4110 | 3269 (ad-set-advice-info-field function 'cache nil)) |
3270 | |
3271 (defun ad-make-cache-id (function) | |
26217 | 3272 "Generate an identifying image of the current advices of FUNCTION." |
4110 | 3273 (let ((original-definition (ad-real-orig-definition function)) |
3274 (cached-definition (ad-get-cache-definition function))) | |
3275 (list (mapcar (function (lambda (advice) (ad-advice-name advice))) | |
3276 (ad-get-enabled-advices function 'before)) | |
3277 (mapcar (function (lambda (advice) (ad-advice-name advice))) | |
3278 (ad-get-enabled-advices function 'around)) | |
3279 (mapcar (function (lambda (advice) (ad-advice-name advice))) | |
3280 (ad-get-enabled-advices function 'after)) | |
3281 (ad-definition-type original-definition) | |
3282 (if (equal (ad-arglist original-definition function) | |
3283 (ad-arglist cached-definition)) | |
3284 t | |
3285 (ad-arglist original-definition function)) | |
3286 (if (eq (ad-definition-type original-definition) 'function) | |
82146
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3287 (equal (interactive-form original-definition) |
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3288 (interactive-form cached-definition)))))) |
4110 | 3289 |
3290 (defun ad-get-cache-class-id (function class) | |
26217 | 3291 "Return the part of FUNCTION's cache id that identifies CLASS." |
4110 | 3292 (let ((cache-id (ad-get-cache-id function))) |
3293 (if (eq class 'before) | |
3294 (car cache-id) | |
3295 (if (eq class 'around) | |
3296 (nth 1 cache-id) | |
3297 (nth 2 cache-id))))) | |
3298 | |
3299 (defun ad-verify-cache-class-id (cache-class-id advices) | |
3300 (ad-dolist (advice advices (null cache-class-id)) | |
3301 (if (ad-advice-enabled advice) | |
3302 (if (eq (car cache-class-id) (ad-advice-name advice)) | |
3303 (setq cache-class-id (cdr cache-class-id)) | |
3304 (ad-do-return nil))))) | |
3305 | |
3306 ;; There should be a way to monitor if and why a cache verification failed | |
3307 ;; in order to determine whether a certain preactivation could be used or | |
26217 | 3308 ;; not. Right now the only way to find out is to trace |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3309 ;; `ad-cache-id-verification-code'. The code it returns indicates where the |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3310 ;; verification failed. Tracing `ad-verify-cache-class-id' might provide |
4110 | 3311 ;; some additional useful information. |
3312 | |
3313 (defun ad-cache-id-verification-code (function) | |
3314 (let ((cache-id (ad-get-cache-id function)) | |
3315 (code 'before-advice-mismatch)) | |
3316 (and (ad-verify-cache-class-id | |
3317 (car cache-id) (ad-get-advice-info-field function 'before)) | |
3318 (setq code 'around-advice-mismatch) | |
3319 (ad-verify-cache-class-id | |
3320 (nth 1 cache-id) (ad-get-advice-info-field function 'around)) | |
3321 (setq code 'after-advice-mismatch) | |
3322 (ad-verify-cache-class-id | |
3323 (nth 2 cache-id) (ad-get-advice-info-field function 'after)) | |
3324 (setq code 'definition-type-mismatch) | |
3325 (let ((original-definition (ad-real-orig-definition function)) | |
3326 (cached-definition (ad-get-cache-definition function))) | |
3327 (and (eq (nth 3 cache-id) (ad-definition-type original-definition)) | |
3328 (setq code 'arglist-mismatch) | |
3329 (equal (if (eq (nth 4 cache-id) t) | |
3330 (ad-arglist original-definition function) | |
3331 (nth 4 cache-id) ) | |
3332 (ad-arglist cached-definition)) | |
3333 (setq code 'interactive-form-mismatch) | |
3334 (or (null (nth 5 cache-id)) | |
82146
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3335 (equal (interactive-form original-definition) |
5868631b2e87
(ad-interactive-p, ad-interactive-form): Remove.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
82140
diff
changeset
|
3336 (interactive-form cached-definition))) |
4110 | 3337 (setq code 'verified)))) |
3338 code)) | |
3339 | |
3340 (defun ad-verify-cache-id (function) | |
26217 | 3341 "True if FUNCTION's cache-id is compatible with its current advices." |
4110 | 3342 (eq (ad-cache-id-verification-code function) 'verified)) |
3343 | |
3344 | |
3345 ;; @@ Preactivation: | |
3346 ;; ================= | |
3347 ;; Preactivation can be used to generate compiled advised definitions | |
3348 ;; at compile time without having to give up the dynamic runtime flexibility | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3349 ;; of the advice mechanism. Preactivation is a special feature of `defadvice', |
4110 | 3350 ;; it involves the following steps: |
3351 ;; - remembering the function's current state (definition and advice-info) | |
3352 ;; - advising it with the defined piece of advice | |
3353 ;; - clearing its cache | |
3354 ;; - generating an interpreted advised definition by activating it, this will | |
3355 ;; make use of all its current active advice and its current definition | |
3356 ;; - saving the so generated cached definition and id | |
3357 ;; - resetting the function's advice and definition state to what it was | |
3358 ;; before the preactivation | |
3359 ;; - Returning the saved definition and its id to be used in the expansion of | |
3360 ;; `defadvice' to assign it as an initial cache, hence it will be compiled | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3361 ;; at time the `defadvice' gets compiled. |
4110 | 3362 ;; Naturally, for preactivation to be effective it has to be applied/compiled |
3363 ;; at the right time, i.e., when the current state of advices and function | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3364 ;; definition exactly reflects the state at activation time. Should that not |
4110 | 3365 ;; be the case, the precompiled definition will just be discarded and a new |
3366 ;; advised definition will be generated. | |
3367 | |
3368 (defun ad-preactivate-advice (function advice class position) | |
26217 | 3369 "Preactivate FUNCTION and returns the constructed cache." |
4110 | 3370 (let* ((function-defined-p (fboundp function)) |
3371 (old-definition | |
3372 (if function-defined-p | |
3373 (symbol-function function))) | |
3374 (old-advice-info (ad-copy-advice-info function)) | |
3375 (ad-advised-functions ad-advised-functions)) | |
3376 (unwind-protect | |
3377 (progn | |
3378 (ad-add-advice function advice class position) | |
3379 (ad-enable-advice function class (ad-advice-name advice)) | |
3380 (ad-clear-cache function) | |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3381 (ad-activate function -1) |
4110 | 3382 (if (and (ad-is-active function) |
3383 (ad-get-cache-definition function)) | |
3384 (list (ad-get-cache-definition function) | |
3385 (ad-get-cache-id function)))) | |
3386 (ad-set-advice-info function old-advice-info) | |
3387 ;; Don't `fset' function to nil if it was previously unbound: | |
3388 (if function-defined-p | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3389 (ad-safe-fset function old-definition) |
4110 | 3390 (fmakunbound function))))) |
3391 | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3392 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3393 ;; @@ Freezing: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3394 ;; ============ |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3395 ;; Freezing transforms a `defadvice' into a redefining `defun/defmacro' |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3396 ;; for the advised function without keeping any advice information. This |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3397 ;; feature was jwz's idea: It generates a dumpable function definition |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3398 ;; whose documentation can be written to the DOC file, and the generated |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3399 ;; code does not need any Advice runtime support. Of course, frozen advices |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3400 ;; cannot be undone. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3401 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3402 ;; Freezing only considers the advice of the particular `defadvice', other |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3403 ;; already existing advices for the same function will be ignored. To ensure |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3404 ;; proper interaction when an already advised function gets redefined with |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3405 ;; a frozen advice, frozen advices always use the actual original definition |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3406 ;; of the function, i.e., they are always at the core of the onion. E.g., if |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3407 ;; an already advised function gets redefined with a frozen advice and then |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3408 ;; unadvised, the frozen advice remains as the new definition of the function. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3409 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3410 ;; While multiple freeze advices for a single function or freeze-advising |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3411 ;; of an already advised function are possible, they are better avoided, |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3412 ;; because definition/compile/load ordering is relevant, and it becomes |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3413 ;; incomprehensible pretty quickly. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3414 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3415 (defun ad-make-freeze-definition (function advice class position) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3416 (if (not (ad-has-proper-definition function)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3417 (error |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3418 "ad-make-freeze-definition: `%s' is not yet defined" |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3419 function)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3420 (let* ((name (ad-advice-name advice)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3421 ;; With a unique origname we can have multiple freeze advices |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3422 ;; for the same function, each overloading the previous one: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3423 (unique-origname |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3424 (intern (format "%s-%s-%s" (ad-make-origname function) class name))) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3425 (orig-definition |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3426 ;; If FUNCTION is already advised, we'll use its current origdef |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3427 ;; as the original definition of the frozen advice: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3428 (or (ad-get-orig-definition function) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3429 (symbol-function function))) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3430 (old-advice-info |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3431 (if (ad-is-advised function) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3432 (ad-copy-advice-info function))) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3433 (real-docstring-fn |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3434 (symbol-function 'ad-make-advised-definition-docstring)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3435 (real-origname-fn |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3436 (symbol-function 'ad-make-origname)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3437 (frozen-definition |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3438 (unwind-protect |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3439 (progn |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3440 ;; Make sure we construct a proper docstring: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3441 (ad-safe-fset 'ad-make-advised-definition-docstring |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3442 'ad-make-freeze-docstring) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3443 ;; Make sure `unique-origname' is used as the origname: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3444 (ad-safe-fset 'ad-make-origname (lambda (x) unique-origname)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3445 ;; No we reset all current advice information to nil and |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3446 ;; generate an advised definition that's solely determined |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3447 ;; by ADVICE and the current origdef of FUNCTION: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3448 (ad-set-advice-info function nil) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3449 (ad-add-advice function advice class position) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3450 ;; The following will provide proper real docstrings as |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3451 ;; well as a definition that will make the compiler happy: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3452 (ad-set-orig-definition function orig-definition) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3453 (ad-make-advised-definition function)) |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3454 ;; Restore the old advice state: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3455 (ad-set-advice-info function old-advice-info) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3456 ;; Restore functions: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3457 (ad-safe-fset |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3458 'ad-make-advised-definition-docstring real-docstring-fn) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3459 (ad-safe-fset 'ad-make-origname real-origname-fn)))) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3460 (if frozen-definition |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3461 (let* ((macro-p (ad-macro-p frozen-definition)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3462 (body (cdr (if macro-p |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3463 (ad-lambdafy frozen-definition) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3464 frozen-definition)))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3465 `(progn |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3466 (if (not (fboundp ',unique-origname)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3467 (fset ',unique-origname |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3468 ;; avoid infinite recursion in case the function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3469 ;; we want to freeze is already advised: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3470 (or (ad-get-orig-definition ',function) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3471 (symbol-function ',function)))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3472 (,(if macro-p 'defmacro 'defun) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3473 ,function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3474 ,@body)))))) |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3475 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3476 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3477 ;; @@ Activation and definition handling: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3478 ;; ====================================== |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3479 |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3480 (defun ad-should-compile (function compile) |
26217 | 3481 "Return non-nil if the advised FUNCTION should be compiled. |
3482 If COMPILE is non-nil and not a negative number then it returns t. | |
3483 If COMPILE is a negative number then it returns nil. | |
3484 If COMPILE is nil then the result depends on the value of | |
3485 `ad-default-compilation-action' (which see)." | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3486 (if (integerp compile) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3487 (>= compile 0) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3488 (if compile |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3489 compile |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3490 (cond ((eq ad-default-compilation-action 'never) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3491 nil) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3492 ((eq ad-default-compilation-action 'always) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3493 t) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3494 ((eq ad-default-compilation-action 'like-original) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3495 (or (ad-subr-p (ad-get-orig-definition function)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3496 (ad-compiled-p (ad-get-orig-definition function)))) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3497 ;; everything else means `maybe': |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3498 (t (featurep 'byte-compile)))))) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3499 |
4110 | 3500 (defun ad-activate-advised-definition (function compile) |
26217 | 3501 "Redefine FUNCTION with its advised definition from cache or scratch. |
3502 The resulting FUNCTION will be compiled if `ad-should-compile' returns t. | |
3503 The current definition and its cache-id will be put into the cache." | |
4110 | 3504 (let ((verified-cached-definition |
3505 (if (ad-verify-cache-id function) | |
3506 (ad-get-cache-definition function)))) | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3507 (ad-safe-fset function |
4110 | 3508 (or verified-cached-definition |
3509 (ad-make-advised-definition function))) | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3510 (if (ad-should-compile function compile) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3511 (ad-compile-function function)) |
4110 | 3512 (if verified-cached-definition |
3513 (if (not (eq verified-cached-definition (symbol-function function))) | |
3514 ;; we must have compiled, cache the compiled definition: | |
3515 (ad-set-cache | |
3516 function (symbol-function function) (ad-get-cache-id function))) | |
3517 ;; We created a new advised definition, cache it with a proper id: | |
3518 (ad-clear-cache function) | |
3519 ;; ad-make-cache-id needs the new cached definition: | |
3520 (ad-set-cache function (symbol-function function) nil) | |
3521 (ad-set-cache | |
3522 function (symbol-function function) (ad-make-cache-id function))))) | |
3523 | |
3524 (defun ad-handle-definition (function) | |
26622 | 3525 "Handle re/definition of an advised FUNCTION during de/activation. |
4110 | 3526 If FUNCTION does not have an original definition associated with it and |
3527 the current definition is usable, then it will be stored as FUNCTION's | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3528 original definition. If no current definition is available (even in the |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3529 case of undefinition) nothing will be done. In the case of redefinition |
4110 | 3530 the action taken depends on the value of `ad-redefinition-action' (which |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3531 see). Redefinition occurs when FUNCTION already has an original definition |
4110 | 3532 associated with it but got redefined with a new definition and then |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3533 de/activated. If you do not like the current redefinition action change |
4110 | 3534 the value of `ad-redefinition-action' and de/activate again." |
3535 (let ((original-definition (ad-get-orig-definition function)) | |
3536 (current-definition (if (ad-real-definition function) | |
3537 (symbol-function function)))) | |
3538 (if original-definition | |
3539 (if current-definition | |
3540 (if (and (not (eq current-definition original-definition)) | |
3541 ;; Redefinition with an advised definition from a | |
3542 ;; different function won't count as such: | |
3543 (not (ad-advised-definition-p current-definition))) | |
3544 ;; we have a redefinition: | |
3545 (if (not (memq ad-redefinition-action '(accept discard warn))) | |
3546 (error "ad-handle-definition (see its doc): `%s' %s" | |
22061
eed26995bfad
(ad-handle-definition, defadvice): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
21365
diff
changeset
|
3547 function "invalidly redefined") |
4110 | 3548 (if (eq ad-redefinition-action 'discard) |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3549 (ad-safe-fset function original-definition) |
4110 | 3550 (ad-set-orig-definition function current-definition) |
3551 (if (eq ad-redefinition-action 'warn) | |
3552 (message "ad-handle-definition: `%s' got redefined" | |
3553 function)))) | |
3554 ;; either advised def or correct original is in place: | |
3555 nil) | |
3556 ;; we have an undefinition, ignore it: | |
3557 nil) | |
3558 (if current-definition | |
3559 ;; we have a first definition, save it as original: | |
3560 (ad-set-orig-definition function current-definition) | |
3561 ;; we don't have anything noteworthy: | |
3562 nil)))) | |
3563 | |
3564 | |
3565 ;; @@ The top-level advice interface: | |
3566 ;; ================================== | |
3567 | |
70899
b920ab84fba8
(ad-enable-advice, ad-activate, ad-disable-advice): Add autoloads.
Richard M. Stallman <rms@gnu.org>
parents:
68648
diff
changeset
|
3568 ;;;###autoload |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3569 (defun ad-activate (function &optional compile) |
26622 | 3570 "Activate all the advice information of an advised FUNCTION. |
4110 | 3571 If FUNCTION has a proper original definition then an advised |
3572 definition will be generated from FUNCTION's advice info and the | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3573 definition of FUNCTION will be replaced with it. If a previously |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3574 cached advised definition was available, it will be used. |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3575 The optional COMPILE argument determines whether the resulting function |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3576 or a compilable cached definition will be compiled. If it is negative |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3577 no compilation will be performed, if it is positive or otherwise non-nil |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3578 the resulting function will be compiled, if it is nil the behavior depends |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3579 on the value of `ad-default-compilation-action' (which see). |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3580 Activation of an advised function that has an advice info but no actual |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3581 pieces of advice is equivalent to a call to `ad-unadvise'. Activation of |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3582 an advised function that has actual pieces of advice but none of them are |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3583 enabled is equivalent to a call to `ad-deactivate'. The current advised |
4110 | 3584 definition will always be cached for later usage." |
3585 (interactive | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
3586 (list (ad-read-advised-function "Activate advice of") |
4110 | 3587 current-prefix-arg)) |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3588 (if ad-activate-on-top-level |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3589 ;; avoid recursive calls to `ad-activate': |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3590 (ad-with-auto-activation-disabled |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3591 (if (not (ad-is-advised function)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3592 (error "ad-activate: `%s' is not advised" function) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3593 (ad-handle-definition function) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3594 ;; Just return for forward advised and not yet defined functions: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3595 (if (ad-get-orig-definition function) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3596 (if (not (ad-has-any-advice function)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3597 (ad-unadvise function) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3598 ;; Otherwise activate the advice: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3599 (cond ((ad-has-redefining-advice function) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3600 (ad-activate-advised-definition function compile) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3601 (ad-set-advice-info-field function 'active t) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3602 (eval (ad-make-hook-form function 'activation)) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3603 function) |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3604 ;; Here we are if we have all disabled advices: |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3605 (t (ad-deactivate function))))))))) |
4110 | 3606 |
26247
f96b2bc4ef08
(ad-activate-on): Make it an alias for ad-activate.
Gerd Moellmann <gerd@gnu.org>
parents:
26217
diff
changeset
|
3607 (defalias 'ad-activate-on 'ad-activate) |
f96b2bc4ef08
(ad-activate-on): Make it an alias for ad-activate.
Gerd Moellmann <gerd@gnu.org>
parents:
26217
diff
changeset
|
3608 |
4110 | 3609 (defun ad-deactivate (function) |
26622 | 3610 "Deactivate the advice of an actively advised FUNCTION. |
4110 | 3611 If FUNCTION has a proper original definition, then the current |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3612 definition of FUNCTION will be replaced with it. All the advice |
4110 | 3613 information will still be available so it can be activated again with |
3614 a call to `ad-activate'." | |
3615 (interactive | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
3616 (list (ad-read-advised-function "Deactivate advice of" 'ad-is-active))) |
4110 | 3617 (if (not (ad-is-advised function)) |
3618 (error "ad-deactivate: `%s' is not advised" function) | |
3619 (cond ((ad-is-active function) | |
3620 (ad-handle-definition function) | |
3621 (if (not (ad-get-orig-definition function)) | |
3622 (error "ad-deactivate: `%s' has no original definition" | |
3623 function) | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3624 (ad-safe-fset function (ad-get-orig-definition function)) |
4110 | 3625 (ad-set-advice-info-field function 'active nil) |
3626 (eval (ad-make-hook-form function 'deactivation)) | |
3627 function))))) | |
3628 | |
3629 (defun ad-update (function &optional compile) | |
3630 "Update the advised definition of FUNCTION if its advice is active. | |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3631 See `ad-activate' for documentation on the optional COMPILE argument." |
4110 | 3632 (interactive |
3633 (list (ad-read-advised-function | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
3634 "Update advised definition of" 'ad-is-active))) |
4110 | 3635 (if (ad-is-active function) |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3636 (ad-activate function compile))) |
4110 | 3637 |
3638 (defun ad-unadvise (function) | |
26622 | 3639 "Deactivate FUNCTION and then remove all its advice information. |
4110 | 3640 If FUNCTION was not advised this will be a noop." |
3641 (interactive | |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
3642 (list (ad-read-advised-function "Unadvise function"))) |
4110 | 3643 (cond ((ad-is-advised function) |
3644 (if (ad-is-active function) | |
3645 (ad-deactivate function)) | |
3646 (ad-clear-orig-definition function) | |
3647 (ad-set-advice-info function nil) | |
3648 (ad-pop-advised-function function)))) | |
3649 | |
3650 (defun ad-recover (function) | |
26622 | 3651 "Try to recover FUNCTION's original definition, and unadvise it. |
3652 This is more low-level than `ad-unadvise' in that it does not do | |
26627 | 3653 deactivation, which might run hooks and get into other trouble. |
4110 | 3654 Use in emergencies." |
3655 ;; Use more primitive interactive behavior here: Accept any symbol that's | |
3656 ;; currently defined in obarray, not necessarily with a function definition: | |
3657 (interactive | |
3658 (list (intern | |
3659 (completing-read "Recover advised function: " obarray nil t)))) | |
3660 (cond ((ad-is-advised function) | |
3661 (cond ((ad-get-orig-definition function) | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3662 (ad-safe-fset function (ad-get-orig-definition function)) |
4110 | 3663 (ad-clear-orig-definition function))) |
3664 (ad-set-advice-info function nil) | |
3665 (ad-pop-advised-function function)))) | |
3666 | |
3667 (defun ad-activate-regexp (regexp &optional compile) | |
26622 | 3668 "Activate functions with an advice name containing a REGEXP match. |
3669 This activates the advice for each function | |
3670 that has at least one piece of advice whose name includes a match for REGEXP. | |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3671 See `ad-activate' for documentation on the optional COMPILE argument." |
4110 | 3672 (interactive |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
3673 (list (ad-read-regexp "Activate via advice regexp") |
4110 | 3674 current-prefix-arg)) |
3675 (ad-do-advised-functions (function) | |
3676 (if (ad-find-some-advice function 'any regexp) | |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3677 (ad-activate function compile)))) |
4110 | 3678 |
3679 (defun ad-deactivate-regexp (regexp) | |
26622 | 3680 "Deactivate functions with an advice name containing REGEXP match. |
3681 This deactivates the advice for each function | |
3682 that has at least one piece of advice whose name includes a match for REGEXP." | |
4110 | 3683 (interactive |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
3684 (list (ad-read-regexp "Deactivate via advice regexp"))) |
4110 | 3685 (ad-do-advised-functions (function) |
3686 (if (ad-find-some-advice function 'any regexp) | |
3687 (ad-deactivate function)))) | |
3688 | |
3689 (defun ad-update-regexp (regexp &optional compile) | |
26217 | 3690 "Update functions with an advice name containing a REGEXP match. |
26622 | 3691 This reactivates the advice for each function |
3692 that has at least one piece of advice whose name includes a match for REGEXP. | |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3693 See `ad-activate' for documentation on the optional COMPILE argument." |
4110 | 3694 (interactive |
65680
ed770a0a7846
2005-09-24 Emilio C. Lopes <eclig@gmx.net>
Romain Francoise <romain@orebokech.com>
parents:
64751
diff
changeset
|
3695 (list (ad-read-regexp "Update via advice regexp") |
4110 | 3696 current-prefix-arg)) |
3697 (ad-do-advised-functions (function) | |
3698 (if (ad-find-some-advice function 'any regexp) | |
3699 (ad-update function compile)))) | |
3700 | |
3701 (defun ad-activate-all (&optional compile) | |
26622 | 3702 "Activate all currently advised functions. |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3703 See `ad-activate' for documentation on the optional COMPILE argument." |
4110 | 3704 (interactive "P") |
3705 (ad-do-advised-functions (function) | |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3706 (ad-activate function compile))) |
4110 | 3707 |
3708 (defun ad-deactivate-all () | |
26622 | 3709 "Deactivate all currently advised functions." |
4110 | 3710 (interactive) |
3711 (ad-do-advised-functions (function) | |
3712 (ad-deactivate function))) | |
3713 | |
3714 (defun ad-update-all (&optional compile) | |
26217 | 3715 "Update all currently advised functions. |
3716 With prefix argument, COMPILE resulting advised definitions." | |
4110 | 3717 (interactive "P") |
3718 (ad-do-advised-functions (function) | |
3719 (ad-update function compile))) | |
3720 | |
3721 (defun ad-unadvise-all () | |
26622 | 3722 "Unadvise all currently advised functions." |
4110 | 3723 (interactive) |
3724 (ad-do-advised-functions (function) | |
3725 (ad-unadvise function))) | |
3726 | |
3727 (defun ad-recover-all () | |
26622 | 3728 "Recover all currently advised functions. Use in emergencies. |
3729 To recover a function means to try to find its original (pre-advice) | |
3730 definition, and delete all advice. | |
3731 This is more low-level than `ad-unadvise' in that it does not do | |
3732 deactivation, which might run hooks and get into other trouble." | |
4110 | 3733 (interactive) |
3734 (ad-do-advised-functions (function) | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3735 (condition-case nil |
4110 | 3736 (ad-recover function) |
3737 (error nil)))) | |
3738 | |
3739 | |
60923
08f8c7042636
* emacs-lisp/advice.el: Replace `legal' with `valid'.
Werner LEMBERG <wl@gnu.org>
parents:
57879
diff
changeset
|
3740 ;; Completion alist of valid `defadvice' flags |
4110 | 3741 (defvar ad-defadvice-flags |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3742 '(("protect") ("disable") ("activate") |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3743 ("compile") ("preactivate") ("freeze"))) |
4110 | 3744 |
3745 ;;;###autoload | |
3746 (defmacro defadvice (function args &rest body) | |
26217 | 3747 "Define a piece of advice for FUNCTION (a symbol). |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3748 The syntax of `defadvice' is as follows: |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3749 |
26217 | 3750 \(defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3751 [DOCSTRING] [INTERACTIVE-FORM] |
78150
3fcbdd7761c3
(defadvice): Doc fix.
Juanma Barranquero <lekktu@gmail.com>
parents:
75346
diff
changeset
|
3752 BODY...) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3753 |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3754 FUNCTION ::= Name of the function to be advised. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3755 CLASS ::= `before' | `around' | `after' | `activation' | `deactivation'. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3756 NAME ::= Non-nil symbol that names this piece of advice. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3757 POSITION ::= `first' | `last' | NUMBER. Optional, defaults to `first', |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3758 see also `ad-add-advice'. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3759 ARGLIST ::= An optional argument list to be used for the advised function |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3760 instead of the argument list of the original. The first one found in |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3761 before/around/after-advices will be used. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3762 FLAG ::= `protect'|`disable'|`activate'|`compile'|`preactivate'|`freeze'. |
4110 | 3763 All flags can be specified with unambiguous initial substrings. |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3764 DOCSTRING ::= Optional documentation for this piece of advice. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3765 INTERACTIVE-FORM ::= Optional interactive form to be used for the advised |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3766 function. The first one found in before/around/after-advices will be used. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3767 BODY ::= Any s-expression. |
4110 | 3768 |
3769 Semantics of the various flags: | |
3770 `protect': The piece of advice will be protected against non-local exits in | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3771 any code that precedes it. If any around-advice of a function is protected |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3772 then automatically all around-advices will be protected (the complete onion). |
4110 | 3773 |
3774 `activate': All advice of FUNCTION will be activated immediately if | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3775 FUNCTION has been properly defined prior to this application of `defadvice'. |
4110 | 3776 |
3777 `compile': In conjunction with `activate' specifies that the resulting | |
3778 advised function should be compiled. | |
3779 | |
26217 | 3780 `disable': The defined advice will be disabled, hence, it will not be used |
4110 | 3781 during activation until somebody enables it. |
3782 | |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3783 `preactivate': Preactivates the advised FUNCTION at macro-expansion/compile |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3784 time. This generates a compiled advised definition according to the current |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3785 advice state that will be used during activation if appropriate. Only use |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3786 this if the `defadvice' gets actually compiled. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3787 |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3788 `freeze': Expands the `defadvice' into a redefining `defun/defmacro' according |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3789 to this particular single advice. No other advice information will be saved. |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3790 Frozen advices cannot be undone, they behave like a hard redefinition of |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3791 the advised function. `freeze' implies `activate' and `preactivate'. The |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3792 documentation of the advised function can be dumped onto the `DOC' file |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3793 during preloading. |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3794 |
26217 | 3795 See Info node `(elisp)Advising Functions' for comprehensive documentation." |
66398
df04170ba46b
(ad-make-advised-definition): Fix arg-order.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
65680
diff
changeset
|
3796 (declare (doc-string 3)) |
4110 | 3797 (if (not (ad-name-p function)) |
22061
eed26995bfad
(ad-handle-definition, defadvice): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
21365
diff
changeset
|
3798 (error "defadvice: Invalid function name: %s" function)) |
4110 | 3799 (let* ((class (car args)) |
3800 (name (if (not (ad-class-p class)) | |
22061
eed26995bfad
(ad-handle-definition, defadvice): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
21365
diff
changeset
|
3801 (error "defadvice: Invalid advice class: %s" class) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3802 (nth 1 args))) |
4110 | 3803 (position (if (not (ad-name-p name)) |
22061
eed26995bfad
(ad-handle-definition, defadvice): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
21365
diff
changeset
|
3804 (error "defadvice: Invalid advice name: %s" name) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3805 (setq args (nthcdr 2 args)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3806 (if (ad-position-p (car args)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3807 (prog1 (car args) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3808 (setq args (cdr args)))))) |
4110 | 3809 (arglist (if (listp (car args)) |
3810 (prog1 (car args) | |
3811 (setq args (cdr args))))) | |
3812 (flags | |
3813 (mapcar | |
3814 (function | |
3815 (lambda (flag) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3816 (let ((completion |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3817 (try-completion (symbol-name flag) ad-defadvice-flags))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3818 (cond ((eq completion t) flag) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3819 ((assoc completion ad-defadvice-flags) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3820 (intern completion)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3821 (t (error "defadvice: Invalid or ambiguous flag: %s" |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3822 flag)))))) |
4110 | 3823 args)) |
3824 (advice (ad-make-advice | |
3825 name (memq 'protect flags) | |
3826 (not (memq 'disable flags)) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3827 `(advice lambda ,arglist ,@body))) |
4110 | 3828 (preactivation (if (memq 'preactivate flags) |
3829 (ad-preactivate-advice | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3830 function advice class position)))) |
4110 | 3831 ;; Now for the things to be done at evaluation time: |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3832 (if (memq 'freeze flags) |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3833 ;; jwz's idea: Freeze the advised definition into a dumpable |
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3834 ;; defun/defmacro whose docs can be written to the DOC file: |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3835 (ad-make-freeze-definition function advice class position) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3836 ;; the normal case: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3837 `(progn |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3838 (ad-add-advice ',function ',advice ',class ',position) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3839 ,@(if preactivation |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3840 `((ad-set-cache |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3841 ',function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3842 ;; the function will get compiled: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3843 ,(cond ((ad-macro-p (car preactivation)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3844 `(ad-macrofy |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3845 (function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3846 ,(ad-lambdafy |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3847 (car preactivation))))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3848 (t `(function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3849 ,(car preactivation)))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3850 ',(car (cdr preactivation))))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3851 ,@(if (memq 'activate flags) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3852 `((ad-activate ',function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3853 ,(if (memq 'compile flags) t)))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3854 ',function)))) |
4110 | 3855 |
3856 | |
3857 ;; @@ Tools: | |
3858 ;; ========= | |
3859 | |
3860 (defmacro ad-with-originals (functions &rest body) | |
26217 | 3861 "Binds FUNCTIONS to their original definitions and execute BODY. |
4110 | 3862 For any members of FUNCTIONS that are not currently advised the rebinding will |
6038
2f1deaa86ee2
Removed all support for Emacs-18:
Richard M. Stallman <rms@gnu.org>
parents:
5746
diff
changeset
|
3863 be a noop. Any modifications done to the definitions of FUNCTIONS will be |
4110 | 3864 undone on exit of this macro." |
3865 (let* ((index -1) | |
3866 ;; Make let-variables to store current definitions: | |
3867 (current-bindings | |
3868 (mapcar (function | |
3869 (lambda (function) | |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3870 (setq index (1+ index)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3871 (list (intern (format "ad-oRiGdEf-%d" index)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3872 `(symbol-function ',function)))) |
4110 | 3873 functions))) |
41608
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3874 `(let ,current-bindings |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3875 (unwind-protect |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3876 (progn |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3877 ,@(progn |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3878 ;; Make forms to redefine functions to their |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3879 ;; original definitions if they are advised: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3880 (setq index -1) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3881 (mapcar |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3882 (function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3883 (lambda (function) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3884 (setq index (1+ index)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3885 `(ad-safe-fset |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3886 ',function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3887 (or (ad-get-orig-definition ',function) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3888 ,(car (nth index current-bindings)))))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3889 functions)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3890 ,@body) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3891 ,@(progn |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3892 ;; Make forms to back-define functions to the definitions |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3893 ;; they had outside this macro call: |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3894 (setq index -1) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3895 (mapcar |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3896 (function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3897 (lambda (function) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3898 (setq index (1+ index)) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3899 `(ad-safe-fset |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3900 ',function |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3901 ,(car (nth index current-bindings))))) |
45db352a0971
Converted backquote to the new style.
Sam Steingold <sds@gnu.org>
parents:
38336
diff
changeset
|
3902 functions)))))) |
4110 | 3903 |
3904 (if (not (get 'ad-with-originals 'lisp-indent-hook)) | |
3905 (put 'ad-with-originals 'lisp-indent-hook 1)) | |
3906 | |
3907 | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3908 ;; @@ Advising `documentation': |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3909 ;; ============================ |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3910 ;; Use the advice mechanism to advise `documentation' to make it |
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3911 ;; generate proper documentation strings for advised definitions: |
4110 | 3912 |
45019
c726a3eeeb0f
(documentation): Add ad-define-subr-args call.
Richard M. Stallman <rms@gnu.org>
parents:
41936
diff
changeset
|
3913 ;; This makes sure we get the right arglist for `documentation' |
c726a3eeeb0f
(documentation): Add ad-define-subr-args call.
Richard M. Stallman <rms@gnu.org>
parents:
41936
diff
changeset
|
3914 ;; during bootstrapping. |
c726a3eeeb0f
(documentation): Add ad-define-subr-args call.
Richard M. Stallman <rms@gnu.org>
parents:
41936
diff
changeset
|
3915 (ad-define-subr-args 'documentation '(function &optional raw)) |
c726a3eeeb0f
(documentation): Add ad-define-subr-args call.
Richard M. Stallman <rms@gnu.org>
parents:
41936
diff
changeset
|
3916 |
4110 | 3917 ;; @@ Starting, stopping and recovering from the advice package magic: |
3918 ;; =================================================================== | |
3919 | |
3920 (defun ad-start-advice () | |
26217 | 3921 "Start the automatic advice handling magic." |
4110 | 3922 (interactive) |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3923 ;; Advising `ad-activate-internal' means death!! |
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3924 (ad-set-advice-info 'ad-activate-internal nil) |
85302
bc8b741390b0
(documentation): Advice deleted. Doc for advised functions
Richard M. Stallman <rms@gnu.org>
parents:
83896
diff
changeset
|
3925 (ad-safe-fset 'ad-activate-internal 'ad-activate)) |
4110 | 3926 |
3927 (defun ad-stop-advice () | |
26622 | 3928 "Stop the automatic advice handling magic. |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3929 You should only need this in case of Advice-related emergencies." |
4110 | 3930 (interactive) |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3931 ;; Advising `ad-activate-internal' means death!! |
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3932 (ad-set-advice-info 'ad-activate-internal nil) |
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3933 (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off)) |
4110 | 3934 |
3935 (defun ad-recover-normality () | |
26217 | 3936 "Undo all advice related redefinitions and unadvises everything. |
4110 | 3937 Use only in REAL emergencies." |
3938 (interactive) | |
26206
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3939 ;; Advising `ad-activate-internal' means death!! |
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3940 (ad-set-advice-info 'ad-activate-internal nil) |
3d9818475597
(ad-activate-internal): Renamed from
Gerd Moellmann <gerd@gnu.org>
parents:
25260
diff
changeset
|
3941 (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off) |
4110 | 3942 (ad-recover-all) |
3943 (setq ad-advised-functions nil)) | |
3944 | |
8445
81f7b5d9b990
New handling of automatic advice activation that
Richard M. Stallman <rms@gnu.org>
parents:
6082
diff
changeset
|
3945 (ad-start-advice) |
4110 | 3946 |
3947 (provide 'advice) | |
3948 | |
66398
df04170ba46b
(ad-make-advised-definition): Fix arg-order.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
65680
diff
changeset
|
3949 ;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0 |
4110 | 3950 ;;; advice.el ends here |