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