diff options
Diffstat (limited to 'lisp/emacs-lisp')
29 files changed, 2213 insertions, 2059 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index eb95fae2339..3d03e894534 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,4 +1,4 @@ -;;; advice.el --- An overloading mechanism for Emacs Lisp functions +;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*- ;; Copyright (C) 1993-1994, 2000-2013 Free Software Foundation, Inc. @@ -47,14 +47,12 @@ ;; @ Highlights: ;; ============= ;; - Clean definition of multiple, named before/around/after advices -;; for functions, macros, subrs and special forms +;; for functions and macros. ;; - Full control over the arguments an advised function will receive, ;; the binding environment in which it will be executed, as well as the ;; value it will return. -;; - Allows re/definition of interactive behavior for functions and subrs -;; - Every piece of advice can have its documentation string which will be -;; combined with the original documentation of the advised function at -;; call-time of `documentation' for proper command-key substitution. +;; - Allows re/definition of interactive behavior for commands. +;; - Every piece of advice can have its documentation string. ;; - The execution of every piece of advice can be protected against error ;; and non-local exits in preceding code or advices. ;; - Simple argument access either by name, or, more portable but as @@ -63,7 +61,7 @@ ;; version of a function. ;; - Advised functions can be byte-compiled either at file-compile time ;; (see preactivation) or activation time. -;; - Separation of advice definition and activation +;; - Separation of advice definition and activation. ;; - Forward advice is possible, that is ;; as yet undefined or autoload functions can be advised without having to ;; preload the file in which they are defined. @@ -77,7 +75,7 @@ ;; - En/disablement mechanism allows the use of different "views" of advised ;; functions depending on what pieces of advice are currently en/disabled ;; - Provides manipulation mechanisms for sets of advised functions via -;; regular expressions that match advice names +;; regular expressions that match advice names. ;; @ Overview, or how to read this file: ;; ===================================== @@ -113,23 +111,12 @@ ;; others come from the various Lisp advice mechanisms I've come across ;; so far, and a few are simply mine. -;; @ Comments, suggestions, bug reports: -;; ===================================== -;; If you find any bugs, have suggestions for new advice features, find the -;; documentation wrong, confusing, incomplete, or otherwise unsatisfactory, -;; have any questions about Advice, or have otherwise enlightening -;; comments feel free to send me email at <hans@cs.buffalo.edu>. - ;; @ Safety Rules and Emergency Exits: ;; =================================== ;; Before we begin: CAUTION!! ;; Advice provides you with a lot of rope to hang yourself on very ;; easily accessible trees, so, here are a few important things you -;; should know: Once Advice has been started with `ad-start-advice' -;; (which happens automatically when you load this file), it -;; generates an advised definition of the `documentation' function, and -;; it will enable automatic advice activation when functions get defined. -;; All of this can be undone at any time with `M-x ad-stop-advice'. +;; should know: ;; ;; If you experience any strange behavior/errors etc. that you attribute to ;; Advice or to some ill-advised function do one of the following: @@ -137,45 +124,37 @@ ;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what ;; function gives you problems) ;; - M-x ad-deactivate-all (if you don't have a clue what's going wrong) -;; - M-x ad-stop-advice (if you think the problem is related to the -;; advised functions used by Advice itself) ;; - M-x ad-recover-normality (for real emergencies) ;; - If none of the above solves your Advice-related problem go to another ;; terminal, kill your Emacs process and send me some hate mail. -;; The first three measures have restarts, i.e., once you've figured out +;; The first two measures have restarts, i.e., once you've figured out ;; the problem you can reactivate advised functions with either `ad-activate', -;; `ad-activate-all', or `ad-start-advice'. `ad-recover-normality' unadvises +;; or `ad-activate-all'. `ad-recover-normality' unadvises ;; everything so you won't be able to reactivate any advised functions, you'll ;; have to stick with their standard incarnations for the rest of the session. -;; IMPORTANT: With Advice loaded always do `M-x ad-deactivate-all' before -;; you byte-compile a file, because advised special forms and macros can lead -;; to unwanted compilation results. When you are done compiling use -;; `M-x ad-activate-all' to go back to the advised state of all your -;; advised functions. - ;; RELAX: Advice is pretty safe even if you are oblivious to the above. ;; I use it extensively and haven't run into any serious trouble in a long -;; time. Just wanted you to be warned. +;; time. Just wanted you to be warned. ;; @ Customization: ;; ================ ;; Look at the documentation of `ad-redefinition-action' for possible values -;; of this variable. Its default value is `warn' which will print a warning +;; of this variable. Its default value is `warn' which will print a warning ;; message when an already defined advised function gets redefined with a ;; new original definition and de/activated. ;; Look at the documentation of `ad-default-compilation-action' for possible -;; values of this variable. Its default value is `maybe' which will compile +;; values of this variable. Its default value is `maybe' which will compile ;; advised definitions during activation in case the byte-compiler is already -;; loaded. Otherwise, it will leave them uncompiled. +;; loaded. Otherwise, it will leave them uncompiled. ;; @ Motivation: ;; ============= ;; Before I go on explaining how advice works, here are four simple examples -;; how this package can be used. The first three are very useful, the last one +;; how this package can be used. The first three are very useful, the last one ;; is just a joke: ;;(defadvice switch-to-buffer (before existing-buffers-only activate) @@ -206,13 +185,12 @@ ;; @ Advice documentation: ;; ======================= -;; Below is general documentation of the various features of advice. For more +;; Below is general documentation of the various features of advice. For more ;; concrete examples check the corresponding sections in the tutorial part. ;; @@ Terminology: ;; =============== ;; - Emacs: Emacs as released by the GNU Project -;; - jwz: Jamie Zawinski - creator of the byte-compiler used in v19s. ;; - Advice: The name of this package. ;; - advices: Short for "pieces of advice". @@ -236,22 +214,22 @@ ;; <name> is the name of the advice which has to be a non-nil symbol. ;; Names uniquely identify a piece of advice in a certain advice class, ;; hence, advices can be redefined by defining an advice with the same class -;; and name. Advice names are global symbols, hence, the same name space +;; and name. Advice names are global symbols, hence, the same name space ;; conventions used for function names should be applied. ;; An optional <position> specifies where in the current list of advices of -;; the specified <class> this new advice will be placed. <position> has to +;; the specified <class> this new advice will be placed. <position> has to ;; be either `first', `last' or a number that specifies a zero-based -;; position (`first' is equivalent to 0). If no position is specified -;; `first' will be used as a default. If this call to `defadvice' redefines +;; position (`first' is equivalent to 0). If no position is specified +;; `first' will be used as a default. If this call to `defadvice' redefines ;; an already existing advice (see above) then the position argument will ;; be ignored and the position of the already existing advice will be used. ;; An optional <arglist> which has to be a list can be used to define the -;; argument list of the advised function. This argument list should of +;; argument list of the advised function. This argument list should of ;; course be compatible with the argument list of the original function, ;; otherwise functions that call the advised function with the original -;; argument list in mind will break. If more than one advice specify an +;; argument list in mind will break. If more than one advice specify an ;; argument list then the first one (the one with the smallest position) ;; found in the list of before/around/after advices will be used. @@ -267,10 +245,10 @@ ;; `disable': Specifies that the defined advice should be disabled, hence, ;; it will not be used in an activation until somebody enables it. ;; `preactivate': Specifies that the advised function should get preactivated -;; at macro-expansion/compile time of this `defadvice'. This +;; at macro-expansion/compile time of this `defadvice'. This ;; generates a compiled advised definition according to the ;; current advice state which will be used during activation -;; if appropriate. Only use this if the `defadvice' gets +;; if appropriate. Only use this if the `defadvice' gets ;; actually compiled. ;; An optional <documentation-string> can be supplied to document the advice. @@ -278,20 +256,20 @@ ;; documentation strings of the original function and other advices. ;; An optional <interactive-form> form can be supplied to change/add -;; interactive behavior of the original function. If more than one advice +;; interactive behavior of the original function. If more than one advice ;; has an `(interactive ...)' specification then the first one (the one ;; with the smallest position) found in the list of before/around/after ;; advices will be used. ;; A possibly empty list of <body-forms> specifies the body of the advice in -;; an implicit progn. The body of an advice can access/change arguments, +;; an implicit progn. The body of an advice can access/change arguments, ;; the return value, the binding environment, and can have all sorts of ;; other side effects. ;; @@ Assembling advised definitions: ;; ================================== ;; Suppose a function/macro/subr/special-form has N pieces of before advice, -;; M pieces of around advice and K pieces of after advice. Assuming none of +;; M pieces of around advice and K pieces of after advice. Assuming none of ;; the advices is protected, its advised definition will look like this ;; (body-form indices correspond to the position of the respective advice in ;; that advice class): @@ -330,11 +308,11 @@ ;; be expanded into a proper documentation string upon call of `documentation'. ;; (interactive ...) is an optional interactive form either taken from the -;; original function or from a before/around/after advice. For advised +;; original function or from a before/around/after advice. For advised ;; interactive subrs that do not have an interactive form specified in any ;; advice we have to use (interactive) and then call the subr interactively ;; if the advised function was called interactively, because the -;; interactive specification of subrs is not accessible. This is the only +;; interactive specification of subrs is not accessible. This is the only ;; case where changing the values of arguments will not have an affect ;; because they will be reset by the interactive specification of the subr. ;; If this is a problem one can always specify an interactive form in a @@ -343,45 +321,44 @@ ;; ;; Then the body forms of the various advices in the various classes of advice ;; are assembled in order. The forms of around advice L are normally part of -;; one of the forms of around advice L-1. An around advice can specify where +;; one of the forms of around advice L-1. An around advice can specify where ;; the forms of the wrapped or surrounded forms should go with the special -;; keyword `ad-do-it', which will be substituted with a `progn' containing the -;; forms of the surrounded code. +;; keyword `ad-do-it', which will run the forms of the surrounded code. ;; The innermost part of the around advice onion is ;; <apply original definition to <arglist>> -;; whose form depends on the type of the original function. The variable -;; `ad-return-value' will be set to its result. This variable is visible to +;; whose form depends on the type of the original function. The variable +;; `ad-return-value' will be set to its result. This variable is visible to ;; all pieces of advice which can access and modify it before it gets returned. ;; ;; The semantic structure of advised functions that contain protected pieces -;; of advice is the same. The only difference is that `unwind-protect' forms +;; of advice is the same. The only difference is that `unwind-protect' forms ;; make sure that the protected advice gets executed even if some previous -;; piece of advice had an error or a non-local exit. If any around advice is +;; piece of advice had an error or a non-local exit. If any around advice is ;; protected then the whole around advice onion will be protected. ;; @@ Argument access in advised functions: ;; ======================================== ;; As already mentioned, the simplest way to access the arguments of an -;; advised function in the body of an advice is to refer to them by name. To -;; do that, the advice programmer needs to know either the names of the +;; advised function in the body of an advice is to refer to them by name. +;; To do that, the advice programmer needs to know either the names of the ;; argument variables of the original function, or the names used in the -;; argument list redefinition given in a piece of advice. While this simple +;; argument list redefinition given in a piece of advice. While this simple ;; method might be sufficient in many cases, it has the disadvantage that it ;; is not very portable because it hardcodes the argument names into the ;; advice. If the definition of the original function changes the advice -;; might break even though the code might still be correct. Situations like +;; might break even though the code might still be correct. Situations like ;; that arise, for example, if one advises a subr like `eval-region' which ;; gets redefined in a non-advice style into a function by the edebug -;; package. If the advice assumes `eval-region' to be a subr it might break -;; once edebug is loaded. Similar situations arise when one wants to use the +;; package. If the advice assumes `eval-region' to be a subr it might break +;; once edebug is loaded. Similar situations arise when one wants to use the ;; same piece of advice across different versions of Emacs. ;; As a solution to that advice provides argument list access macros that get ;; translated into the proper access forms at activation time, i.e., when the -;; advised definition gets constructed. Access macros access actual arguments +;; advised definition gets constructed. Access macros access actual arguments ;; by position regardless of how these actual argument get distributed onto -;; the argument variables of a function. The rational behind this is that in +;; the argument variables of a function. The rational behind this is that in ;; Emacs Lisp the semantics of an argument is strictly determined by its ;; position (there are no keyword arguments). @@ -393,9 +370,9 @@ ;; ;; (foo 0 1 2 3 4 5 6) -;; which means that X=0, Y=1, Z=2 and R=(3 4 5 6). The assumption is that -;; the semantics of an actual argument is determined by its position. It is -;; this semantics that has to be known by the advice programmer. Then s/he +;; which means that X=0, Y=1, Z=2 and R=(3 4 5 6). The assumption is that +;; the semantics of an actual argument is determined by its position. It is +;; this semantics that has to be known by the advice programmer. Then s/he ;; can access these arguments in a piece of advice with some of the ;; following macros (the arrows indicate what value they will return): @@ -408,17 +385,17 @@ ;; `(ad-get-arg <position>)' will return the actual argument that was supplied ;; at <position>, `(ad-get-args <position>)' will return the list of actual -;; arguments supplied starting at <position>. Note that these macros can be +;; arguments supplied starting at <position>. Note that these macros can be ;; used without any knowledge about the form of the actual argument list of ;; the original function. ;; Similarly, `(ad-set-arg <position> <value-form>)' can be used to set the -;; value of the actual argument at <position> to <value-form>. For example, +;; value of the actual argument at <position> to <value-form>. For example, ;; ;; (ad-set-arg 5 "five") ;; ;; will have the effect that R=(3 4 "five" 6) once the original function is -;; called. `(ad-set-args <position> <value-list-form>)' can be used to set +;; called. `(ad-set-args <position> <value-list-form>)' can be used to set ;; the list of actual arguments starting at <position> to <value-list-form>. ;; For example, ;; @@ -427,7 +404,7 @@ ;; will have the effect that X=5, Y=4, Z=3 and R=(2 1 0) once the original ;; function is called. -;; All these access macros are text macros rather than real Lisp macros. When +;; All these access macros are text macros rather than real Lisp macros. When ;; the advised definition gets constructed they get replaced with actual access ;; forms depending on the argument list of the advised function, i.e., after ;; that argument access is in most cases as efficient as using the argument @@ -437,7 +414,7 @@ ;; ======================================================= ;; Some functions (such as `trace-function' defined in trace.el) need a ;; method of accessing the names and bindings of the arguments of an -;; arbitrary advised function. To do that within an advice one can use the +;; arbitrary advised function. To do that within an advice one can use the ;; special keyword `ad-arg-bindings' which is a text macro that will be ;; substituted with a form that will evaluate to a list of binding ;; specifications, one for every argument variable. These binding @@ -463,7 +440,7 @@ ;; ========================== ;; Because `defadvice' allows the specification of the argument list ;; of the advised function we need a mapping mechanism that maps this -;; argument list onto that of the original function. Hence SYM and +;; argument list onto that of the original function. Hence SYM and ;; NEWDEF have to be properly mapped onto the &rest variable when the ;; original definition is called. Advice automatically takes care of ;; that mapping, hence, the advice programmer can specify an argument @@ -474,11 +451,10 @@ ;; @@ Activation and deactivation: ;; =============================== ;; The definition of an advised function does not change until all its advice -;; gets actually activated. Activation can either happen with the `activate' +;; gets actually activated. Activation can either happen with the `activate' ;; flag specified in the `defadvice', with an explicit call or interactive -;; invocation of `ad-activate', or if forward advice is enabled (i.e., the -;; value of `ad-activate-on-definition' is t) at the time an already advised -;; function gets defined. +;; invocation of `ad-activate', or at the time an already advised function +;; gets defined. ;; When a function gets first activated its original definition gets saved, ;; all defined and enabled pieces of advice will get combined with the @@ -496,7 +472,7 @@ ;; the file that contained the `defadvice' with the `preactivate' flag. ;; `ad-deactivate' can be used to back-define an advised function to its -;; original definition. It can be called interactively or directly. Because +;; original definition. It can be called interactively or directly. Because ;; `ad-activate' caches the advised definition the function can be ;; reactivated via `ad-activate' with only minor overhead (it is checked ;; whether the current advice state is consistent with the cached @@ -504,12 +480,12 @@ ;; `ad-activate-regexp' and `ad-deactivate-regexp' can be used to de/activate ;; all currently advised function that have a piece of advice with a name that -;; contains a match for a regular expression. These functions can be used to +;; contains a match for a regular expression. These functions can be used to ;; de/activate sets of functions depending on certain advice naming ;; conventions. ;; Finally, `ad-activate-all' and `ad-deactivate-all' can be used to -;; de/activate all currently advised functions. These are useful to +;; de/activate all currently advised functions. These are useful to ;; (temporarily) return to an un/advised state. ;; @@@ Reasons for the separation of advice definition and activation: @@ -521,26 +497,26 @@ ;; The advantage of this is that various pieces of advice can be defined ;; before they get combined into an advised definition which avoids -;; unnecessary constructions of intermediate advised definitions. The more +;; unnecessary constructions of intermediate advised definitions. The more ;; important advantage is that it allows the implementation of forward advice. ;; Advice information for a certain function accumulates as the value of the -;; `advice-info' property of the function symbol. This accumulation is +;; `advice-info' property of the function symbol. This accumulation is ;; completely independent of the fact that that function might not yet be -;; defined. The special forms `defun' and `defmacro' have been advised to -;; check whether the function/macro they defined had advice information -;; associated with it. If so and forward advice is enabled, the original +;; defined. The macros `defun' and `defmacro' check whether the +;; function/macro they defined had advice information +;; associated with it. If so and forward advice is enabled, the original ;; definition will be saved, and then the advice will be activated. ;; @@ Enabling/disabling pieces or sets of advice: ;; =============================================== ;; A major motivation for the development of this advice package was to bring ;; a little bit more structure into the function overloading chaos in Emacs -;; Lisp. Many packages achieve some of their functionality by adding a little +;; Lisp. Many packages achieve some of their functionality by adding a little ;; bit (or a lot) to the standard functionality of some Emacs Lisp function. -;; ange-ftp is a very popular package that achieves its magic by overloading -;; most Emacs Lisp functions that deal with files. A popular function that's -;; overloaded by many packages is `expand-file-name'. The situation that one -;; function is multiply overloaded can arise easily. +;; ange-ftp is a very popular package that used to achieve its magic by +;; overloading most Emacs Lisp functions that deal with files. A popular +;; function that's overloaded by many packages is `expand-file-name'. +;; The situation that one function is multiply overloaded can arise easily. ;; Once in a while it would be desirable to be able to disable some/all ;; overloads of a particular package while keeping all the rest. Ideally - @@ -548,7 +524,7 @@ ;; I know I am dreaming right now... In that ideal case the enable/disable ;; mechanism of advice could be used to achieve just that. -;; Every piece of advice is associated with an enablement flag. When the +;; Every piece of advice is associated with an enablement flag. When the ;; advised definition of a particular function gets constructed (e.g., during ;; activation) only the currently enabled pieces of advice will be considered. ;; This mechanism allows one to have different "views" of an advised function @@ -556,17 +532,15 @@ ;; Another motivation for this mechanism is that it allows one to define a ;; piece of advice for some function yet keep it dormant until a certain -;; condition is met. Until then activation of the function will not make use -;; of that piece of advice. Once the condition is met the advice can be +;; condition is met. Until then activation of the function will not make use +;; of that piece of advice. Once the condition is met the advice can be ;; enabled and a reactivation of the function will add its functionality as -;; part of the new advised definition. For example, the advices of `defun' -;; etc. used by advice itself will stay disabled until `ad-start-advice' is -;; called and some variables have the proper values. Hence, if somebody +;; part of the new advised definition. Hence, if somebody ;; else advised these functions too and activates them the advices defined ;; by advice will get used only if they are intended to be used. ;; The main interface to this mechanism are the interactive functions -;; `ad-enable-advice' and `ad-disable-advice'. For example, the following +;; `ad-enable-advice' and `ad-disable-advice'. For example, the following ;; would disable a particular advice of the function `foo': ;; ;; (ad-disable-advice 'foo 'before 'my-advice) @@ -576,28 +550,28 @@ ;; ;; (ad-activate 'foo) ;; -;; or interactively. To disable whole sets of advices one can use a regular -;; expression mechanism. For example, let us assume that ange-ftp actually +;; or interactively. To disable whole sets of advices one can use a regular +;; expression mechanism. For example, let us assume that ange-ftp actually ;; used advice to overload all its functions, and that it used the ;; "ange-ftp-" prefix for all its advice names, then we could temporarily ;; disable all its advices with ;; -;; (ad-disable-regexp "^ange-ftp-") +;; (ad-disable-regexp "\\`ange-ftp-") ;; ;; and the following call would put that actually into effect: ;; -;; (ad-activate-regexp "^ange-ftp-") +;; (ad-activate-regexp "\\`ange-ftp-") ;; ;; A safer way would have been to use ;; -;; (ad-update-regexp "^ange-ftp-") +;; (ad-update-regexp "\\`ange-ftp-") ;; ;; instead which would have only reactivated currently actively advised -;; functions, but not functions that were currently inactive. All these +;; functions, but not functions that were currently inactive. All these ;; functions can also be called interactively. ;; A certain piece of advice is considered a match if its name contains a -;; match for the regular expression. To enable ange-ftp again we would use +;; match for the regular expression. To enable ange-ftp again we would use ;; `ad-enable-regexp' and then activate or update again. ;; @@ Forward advice, automatic advice activation: @@ -615,26 +589,19 @@ ;; Advice implements forward advice mainly via the following: 1) Separation ;; of advice definition and activation that makes it possible to accumulate ;; advice information without having the original function already defined, -;; 2) special versions of the built-in functions `fset/defalias' which check -;; for advice information whenever they define a function. If advice -;; information was found then the advice will immediately get activated when -;; the function gets defined. +;; 2) Use of the `defalias-fset-function' symbol property which lets +;; us advise the function when it gets defined. ;; Automatic advice activation means, that whenever a function gets defined -;; with either `defun', `defmacro', `fset' or by loading a byte-compiled +;; with either `defun', `defmacro', `defalias' or by loading a byte-compiled ;; file, and the function has some advice-info stored with it then that ;; advice will get activated right away. -;; @@@ Enabling automatic advice activation: -;; ========================================= -;; Automatic advice activation is enabled by default. It can be disabled with -;; `M-x ad-stop-advice' and enabled again with `M-x ad-start-advice'. - ;; @@ Caching of advised definitions: ;; ================================== ;; After an advised definition got constructed it gets cached as part of the ;; advised function's advice-info so it can be reused, for example, after an -;; intermediate deactivation. Because the advice-info of a function might +;; intermediate deactivation. Because the advice-info of a function might ;; change between the time of caching and reuse a cached definition gets ;; a cache-id associated with it so it can be verified whether the cached ;; definition is still valid (the main application of this is preactivation @@ -642,19 +609,19 @@ ;; When an advised function gets activated and a verifiable cached definition ;; is available, then that definition will be used instead of creating a new -;; advised definition from scratch. If you want to make sure that a new +;; advised definition from scratch. If you want to make sure that a new ;; definition gets constructed then you should use `ad-clear-cache' before you ;; activate the advised function. ;; @@ Preactivation: ;; ================= -;; Constructing an advised definition is moderately expensive. In a situation +;; Constructing an advised definition is moderately expensive. In a situation ;; where one package defines a lot of advised functions it might be ;; prohibitively expensive to do all the advised definition construction at -;; runtime. Preactivation is a mechanism that allows compile-time construction +;; runtime. Preactivation is a mechanism that allows compile-time construction ;; of compiled advised definitions that can be activated cheaply during -;; runtime. Preactivation uses the caching mechanism to do that. Here's how it -;; works: +;; runtime. Preactivation uses the caching mechanism to do that. Here's how +;; it works: ;; When the byte-compiler compiles a `defadvice' that has the `preactivate' ;; flag specified, it uses the current original definition of the advised @@ -665,27 +632,27 @@ ;; byte-compiler. ;; When the file with the compiled, preactivating `defadvice' gets loaded the ;; precompiled advised definition will be cached on the advised function's -;; advice-info. When it gets activated (can be immediately on execution of the +;; advice-info. When it gets activated (can be immediately on execution of the ;; `defadvice' or any time later) the cache-id gets checked against the ;; current state of advice and if it is verified the precompiled definition -;; will be used directly (the verification is pretty cheap). If it couldn't get -;; verified a new advised definition for that function will be built from -;; scratch, hence, the efficiency added by the preactivation mechanism does -;; not at all impair the flexibility of the advice mechanism. +;; will be used directly (the verification is pretty cheap). If it couldn't +;; get verified a new advised definition for that function will be built from +;; scratch, hence, the efficiency added by the preactivation mechanism does not +;; at all impair the flexibility of the advice mechanism. ;; MORAL: In order get all the efficiency out of preactivation the advice ;; state of an advised function at the time the file with the ;; preactivating `defadvice' gets byte-compiled should be exactly ;; the same as it will be when the advice of that function gets -;; actually activated. If it is not there is a high chance that the +;; actually activated. If it is not there is a high chance that the ;; cache-id will not match and hence a new advised definition will ;; have to be constructed at runtime. -;; Preactivation and forward advice do not contradict each other. It is +;; Preactivation and forward advice do not contradict each other. It is ;; perfectly ok to load a file with a preactivating `defadvice' before the -;; original definition of the advised function is available. The constructed +;; original definition of the advised function is available. The constructed ;; advised definition will be used once the original function gets defined and -;; its advice gets activated. The only constraint is that at the time the +;; its advice gets activated. The only constraint is that at the time the ;; file with the preactivating `defadvice' got compiled the original function ;; definition was available. @@ -697,18 +664,18 @@ ;; - `byte-compile' is part of the `features' variable even though you ;; did not use the byte-compiler ;; Right now advice does not provide an elegant way to find out whether -;; and why a preactivation failed. What you can do is to trace the +;; and why a preactivation failed. What you can do is to trace the ;; function `ad-cache-id-verification-code' (with the function ;; `trace-function-background' defined in my trace.el package) before -;; any of your advised functions get activated. After they got +;; any of your advised functions get activated. After they got ;; activated check whether all calls to `ad-cache-id-verification-code' -;; returned `verified' as a result. Other values indicate why the +;; returned `verified' as a result. Other values indicate why the ;; verification failed which should give you enough information to ;; fix your preactivation/compile/load/activation sequence. ;; IMPORTANT: There is one case (that I am aware of) that can make ;; preactivation fail, i.e., a preconstructed advised definition that does -;; NOT match the current state of advice gets used nevertheless. That case +;; NOT match the current state of advice gets used nevertheless. That case ;; arises if one package defines a certain piece of advice which gets used ;; during preactivation, and another package incompatibly redefines that ;; very advice (i.e., same function/class/name), and it is the second advice @@ -720,30 +687,20 @@ ;; MORAL-II: Redefining somebody else's advice is BAAAAD (to speak with ;; George Walker Bush), and why would you redefine your own advice anyway? ;; Advice is a mechanism to facilitate function redefinition, not advice -;; redefinition (wait until I write Meta-Advice :-). If you really have -;; to undo somebody else's advice try to write a "neutralizing" advice. +;; redefinition (wait until I write Meta-Advice :-). If you really have +;; to undo somebody else's advice, try to write a "neutralizing" advice. -;; @@ Advising macros and special forms and other dangerous things: -;; ================================================================ +;; @@ Advising macros and other dangerous things: +;; ============================================== ;; Look at the corresponding tutorial sections for more information on -;; these topics. Here it suffices to point out that the special treatment -;; of macros and special forms by the byte-compiler can lead to problems -;; when they get advised. Macros can create problems because they get -;; expanded at compile time, hence, they might not have all the necessary -;; runtime support and such advice cannot be de/activated or changed as -;; it is possible for functions. Special forms create problems because they -;; have to be advised "into" macros, i.e., an advised special form is a -;; implemented as a macro, hence, in most cases the byte-compiler will -;; not recognize it as a special form anymore which can lead to very strange -;; results. -;; -;; MORAL: - Only advise macros or special forms when you are absolutely sure -;; what you are doing. -;; - As a safety measure, always do `ad-deactivate-all' before you -;; byte-compile a file to make sure that even if some inconsiderate -;; person advised some special forms you'll get proper compilation -;; results. After compilation do `ad-activate-all' to get back to -;; the previous state. +;; these topics. Here it suffices to point out that the special treatment +;; of macros can lead to problems when they get advised. Macros can create +;; problems because they get expanded at compile or load time, hence, they +;; might not have all the necessary runtime support and such advice cannot be +;; de/activated or changed as it is possible for functions. +;; Special forms cannot be advised. +;; +;; MORAL: - Only advise macros when you are absolutely sure what you are doing. ;; @@ Adding a piece of advice with `ad-add-advice': ;; ================================================= @@ -754,10 +711,10 @@ ;; @@ Activation/deactivation advices, file load hooks: ;; ==================================================== ;; There are two special classes of advice called `activation' and -;; `deactivation'. The body forms of these advices are not included into the +;; `deactivation'. The body forms of these advices are not included into the ;; advised definition of a function, rather they are assembled into a hook ;; form which will be evaluated whenever the advice-info of the advised -;; function gets activated or deactivated. One application of this mechanism +;; function gets activated or deactivated. One application of this mechanism ;; is to define file load hooks for files that do not provide such hooks. ;; For example, suppose you want to print a message whenever `file-x' gets ;; loaded, and suppose the last function defined in `file-x' is @@ -769,7 +726,7 @@ ;; ;; This will constitute a forward advice for function `file-x-last-fn' which ;; will get activated when `file-x' is loaded (only if forward advice is -;; enabled of course). Because there are no "real" pieces of advice +;; enabled of course). Because there are no "real" pieces of advice ;; available for it, its definition will not be changed, but the activation ;; advice will be run during its activation which is equivalent to having a ;; file load hook for `file-x'. @@ -784,14 +741,14 @@ ;; enabled advices are considered during construction of an advised ;; definition. ;; - Activation: -;; Redefine an advised function with its advised definition. Constructs +;; Redefine an advised function with its advised definition. Constructs ;; an advised definition from scratch if no verifiable cached advised ;; definition is available and caches it. ;; - Deactivation: ;; Back-define an advised function to its original definition. ;; - Update: ;; Reactivate an advised function but only if its advice is currently -;; active. This can be used to bring all currently advised function up +;; active. This can be used to bring all currently advised function up ;; to date with the current state of advice without also activating ;; currently inactive functions. ;; - Caching: @@ -800,7 +757,7 @@ ;; - Preactivation: ;; Is the construction of an advised definition according to the current ;; state of advice during byte-compilation of a file with a preactivating -;; `defadvice'. That advised definition can then rather cheaply be used +;; `defadvice'. That advised definition can then rather cheaply be used ;; during activation without having to construct an advised definition ;; from scratch at runtime. @@ -860,12 +817,8 @@ ;; @ Foo games: An advice tutorial ;; =============================== -;; The following tutorial was created in Emacs 18.59. Left-justified +;; The following tutorial was created in Emacs 18.59. Left-justified ;; s-expressions are input forms followed by one or more result forms. -;; First we have to start the advice magic: -;; -;; (ad-start-advice) -;; nil ;; ;; We start by defining an innocent looking function `foo' that simply ;; adds 1 to its argument X: @@ -988,19 +941,6 @@ ;; (call-interactively 'foo) ;; 6 ;; -;; Let's have a look at what the definition of `foo' looks like now -;; (indentation added by hand for legibility): -;; -;; (symbol-function 'foo) -;; (lambda (x) -;; "$ad-doc: foo$" -;; (interactive (list 5)) -;; (let (ad-return-value) -;; (setq x (1- x)) -;; (setq x (1+ x)) -;; (setq ad-return-value (ad-Orig-foo x)) -;; ad-return-value)) -;; ;; @@ Around advices: ;; ================== ;; Now we'll try some `around' advices. An around advice is a wrapper around @@ -1038,20 +978,6 @@ ;; (foo 3) ;; 8 ;; -;; Again, let's see what the definition of `foo' looks like so far: -;; -;; (symbol-function 'foo) -;; (lambda (x) -;; "$ad-doc: foo$" -;; (interactive (list 5)) -;; (let (ad-return-value) -;; (setq x (1- x)) -;; (setq x (1+ x)) -;; (let ((x (* x 2))) -;; (let ((x (1+ x))) -;; (setq ad-return-value (ad-Orig-foo x)))) -;; ad-return-value)) -;; ;; @@ Controlling advice activation: ;; ================================= ;; In every `defadvice' so far we have used the flag `activate' to activate @@ -1071,9 +997,9 @@ ;; 8 ;; ;; Now we define another advice and activate which will also activate the -;; previous advice `fg-times-x'. Note the use of the special variable +;; previous advice `fg-times-x'. Note the use of the special variable ;; `ad-return-value' in the body of the advice which is set to the result of -;; the original function. If we change its value then the value returned by +;; the original function. If we change its value then the value returned by ;; the advised function will be changed accordingly: ;; ;; (defadvice foo (after fg-times-x-again act) @@ -1121,24 +1047,6 @@ ;; "Let's clean up now!" ;; error-in-foo ;; -;; Again, let's see what `foo' looks like: -;; -;; (symbol-function 'foo) -;; (lambda (x) -;; "$ad-doc: foo$" -;; (interactive (list 5)) -;; (let (ad-return-value) -;; (unwind-protect -;; (progn (setq x (1- x)) -;; (setq x (1+ x)) -;; (let ((x (* x 2))) -;; (let ((x (1+ x))) -;; (setq ad-return-value (ad-Orig-foo x)))) -;; (setq ad-return-value (* ad-return-value x)) -;; (setq ad-return-value (* ad-return-value x))) -;; (print "Let's clean up now!")) -;; ad-return-value)) -;; ;; @@ Compilation of advised definitions: ;; ====================================== ;; Finally, we can specify the `compile' keyword in a `defadvice' to say @@ -1150,13 +1058,10 @@ ;; (print "Let's clean up now!")) ;; foo ;; -;; Now `foo' is byte-compiled: +;; Now `foo's advice is byte-compiled: ;; -;; (symbol-function 'foo) -;; (lambda (x) -;; "$ad-doc: foo$" -;; (interactive (byte-code "....." [5] 1)) -;; (byte-code "....." [ad-return-value x nil ((byte-code "....." [print "Let's clean up now!"] 2)) * 2 ad-Orig-foo] 6)) +;; (byte-code-function-p 'ad-Advice-foo) +;; t ;; ;; (foo 3) ;; "Let's clean up now!" @@ -1262,7 +1167,7 @@ ;; deactivate functions that have a piece of advice defined by a certain ;; package (we save the old definition to check out caching): ;; -;; (setq old-definition (symbol-function 'foo)) +;; (setq old-definition (symbol-function 'ad-Advice-foo)) ;; (lambda (x) ....) ;; ;; (ad-deactivate-regexp "^fg-") @@ -1274,7 +1179,7 @@ ;; (ad-activate-regexp "^fg-") ;; nil ;; -;; (eq old-definition (symbol-function 'foo)) +;; (eq old-definition (symbol-function 'ad-Advice-foo)) ;; t ;; ;; (foo 3) @@ -1283,14 +1188,6 @@ ;; ;; @@ Forward advice: ;; ================== -;; To enable automatic activation of forward advice we first have to set -;; `ad-activate-on-definition' to t and restart advice: -;; -;; (setq ad-activate-on-definition t) -;; t -;; -;; (ad-start-advice) -;; (ad-activate-defined-function) ;; ;; Let's define a piece of advice for an undefined function: ;; @@ -1303,9 +1200,7 @@ ;; (fboundp 'bar) ;; nil ;; -;; Now we define it and the forward advice will get activated (only because -;; `ad-activate-on-definition' was t when we started advice above with -;; `ad-start-advice'): +;; Now we define it and the forward advice will get activated: ;; ;; (defun bar (x) ;; "Subtract 1 from X." @@ -1357,7 +1252,7 @@ ;; (ad-activate 'fie) ;; fie ;; -;; (eq cached-definition (symbol-function 'fie)) +;; (eq cached-definition (symbol-function 'ad-Advice-fie)) ;; t ;; ;; (fie 2) @@ -1365,7 +1260,7 @@ ;; ;; If you put a preactivating `defadvice' into a Lisp file that gets byte- ;; compiled then the constructed advised definition will get compiled by -;; the byte-compiler. For that to occur in a v18 Emacs you had to put the +;; the byte-compiler. For that to occur in a v18 Emacs you had to put the ;; `defadvice' inside a `defun' because the v18 compiler did not compile ;; top-level forms other than `defun' or `defmacro', for example, ;; @@ -1407,18 +1302,16 @@ ;; constructed during preactivation was used, even though we did not specify ;; the `compile' flag: ;; -;; (symbol-function 'fum) -;; (lambda (x) -;; "$ad-doc: fum$" -;; (byte-code "....." [ad-return-value x nil * 2 ad-Orig-fum] 4)) +;; (byte-code-function-p 'ad-Advice-fum) +;; t ;; ;; (fum 2) ;; 8 ;; ;; A preactivated definition will only be used if it matches the current -;; function definition and advice information. If it does not match it +;; function definition and advice information. If it does not match it ;; will simply be discarded and a new advised definition will be constructed -;; from scratch. For example, let's first remove all advice-info for `fum': +;; from scratch. For example, let's first remove all advice-info for `fum': ;; ;; (ad-unadvise 'fum) ;; (("fie") ("bar") ("foo") ...) @@ -1431,7 +1324,7 @@ ;; fum ;; ;; When we now try to use a preactivation it will not be used because the -;; current advice state is different from the one at preactivation time. This +;; current advice state is different from the one at preactivation time. This ;; is no tragedy, everything will work as expected just not as efficient, ;; because a new advised definition has to be constructed from scratch: ;; @@ -1440,7 +1333,7 @@ ;; ;; A new uncompiled advised definition got constructed: ;; -;; (ad-compiled-p (symbol-function 'fum)) +;; (byte-code-function-p 'ad-Advice-fum) ;; nil ;; ;; (fum 2) @@ -1448,7 +1341,7 @@ ;; ;; MORAL: To get all the efficiency out of preactivation the function ;; definition and advice state at preactivation time must be the same as the -;; state at activation time. Preactivation does work with forward advice, all +;; state at activation time. Preactivation does work with forward advice, all ;; that's necessary is that the definition of the forward advised function is ;; available when the `defadvice' with the preactivation gets compiled. ;; @@ -1702,15 +1595,9 @@ ;; @@ Compilation idiosyncrasies: ;; ============================== -;; `defadvice' expansion needs quite a few advice functions and variables, -;; hence, I need to preload the file before it can be compiled. To avoid -;; interference of bogus compiled files I always preload the source file: -(provide 'advice-preload) -;; During a normal load this is a noop: -(require 'advice-preload "advice.el") (require 'macroexp) ;; At run-time also, since ad-do-advised-functions returns code that uses it. -(require 'cl-lib) +(eval-when-compile (require 'cl-lib)) ;; @@ Variable definitions: ;; ======================== @@ -1776,36 +1663,6 @@ generates a copy of TREE." (funcall fUnCtIoN tReE)) (t tReE))) -;; @@ Save real definitions of subrs used by Advice: -;; ================================================= -;; Advice depends on the real, unmodified functionality of various subrs, -;; we save them here so advised versions will not interfere (eventually, -;; we will save all subrs used in code generated by Advice): - -(defmacro ad-save-real-definition (function) - (let ((saved-function (intern (format "ad-real-%s" function)))) - ;; Make sure the compiler is loaded during macro expansion: - (require 'byte-compile "bytecomp") - `(if (not (fboundp ',saved-function)) - (progn (fset ',saved-function (symbol-function ',function)) - ;; Copy byte-compiler properties: - ,@(if (get function 'byte-compile) - `((put ',saved-function 'byte-compile - ',(get function 'byte-compile)))) - ,@(if (get function 'byte-opcode) - `((put ',saved-function 'byte-opcode - ',(get function 'byte-opcode)))))))) - -(defun ad-save-real-definitions () - ;; Macro expansion will hardcode the values of the various byte-compiler - ;; properties into the compiled version of this function such that the - ;; proper values will be available at runtime without loading the compiler: - (ad-save-real-definition fset) - (ad-save-real-definition documentation)) - -(ad-save-real-definitions) - - ;; @@ Advice info access fns: ;; ========================== @@ -1819,7 +1676,7 @@ generates a copy of TREE." ;; (after adv1 adv2 ...) ;; (activation adv1 adv2 ...) ;; (deactivation adv1 adv2 ...) -;; (origname . <symbol fbound to origdef>) +;; (advicefunname . <symbol fbound to assembled advice function>) ;; (cache . (<advised-definition> . <id>))) ;; List of currently advised though not necessarily activated functions @@ -1840,15 +1697,13 @@ generates a copy of TREE." ad-advised-functions))) (defmacro ad-do-advised-functions (varform &rest body) - "`dolist'-style iterator that maps over `ad-advised-functions'. -\(ad-do-advised-functions (VAR [RESULT-FORM]) + "`dolist'-style iterator that maps over advised functions. +\(ad-do-advised-functions (VAR) BODY-FORM...) On each iteration VAR will be bound to the name of an advised function \(a symbol)." (declare (indent 1)) - `(cl-dolist (,(car varform) - ad-advised-functions - ,(car (cdr varform))) + `(dolist (,(car varform) ad-advised-functions) (setq ,(car varform) (intern (car ,(car varform)))) ,@body)) @@ -1858,8 +1713,15 @@ On each iteration VAR will be bound to the name of an advised function (defmacro ad-get-advice-info-macro (function) `(get ,function 'ad-advice-info)) -(defmacro ad-set-advice-info (function advice-info) - `(put ,function 'ad-advice-info ,advice-info)) +(defsubst ad-set-advice-info (function advice-info) + (cond + (advice-info + (add-function :around (get function 'defalias-fset-function) + #'ad--defalias-fset)) + ((get function 'defalias-fset-function) + (remove-function (get function 'defalias-fset-function) + #'ad--defalias-fset))) + (put function 'ad-advice-info advice-info)) (defmacro ad-copy-advice-info (function) `(copy-tree (get ,function 'ad-advice-info))) @@ -1867,7 +1729,7 @@ On each iteration VAR will be bound to the name of an advised function (defmacro ad-is-advised (function) "Return non-nil if FUNCTION has any advice info associated with it. This does not mean that the advice is also active." - (list 'ad-get-advice-info-macro function)) + `(ad-get-advice-info-macro ,function)) (defun ad-initialize-advice-info (function) "Initialize the advice info for FUNCTION. @@ -1907,18 +1769,17 @@ either t or nil, and DEFINITION should be a list of the form ;; ad-find-advice uses the alist structure directly -> ;; change if this data structure changes!! -(defmacro ad-advice-name (advice) - (list 'car advice)) -(defmacro ad-advice-protected (advice) - (list 'nth 1 advice)) -(defmacro ad-advice-enabled (advice) - (list 'nth 2 advice)) -(defmacro ad-advice-definition (advice) - (list 'nth 3 advice)) +(defsubst ad-advice-name (advice) (car advice)) +(defsubst ad-advice-protected (advice) (nth 1 advice)) +(defsubst ad-advice-enabled (advice) (nth 2 advice)) +(defsubst ad-advice-definition (advice) (nth 3 advice)) (defun ad-advice-set-enabled (advice flag) (rplaca (cdr (cdr advice)) flag)) +(defvar ad-advice-classes '(before around after activation deactivation) + "List of defined advice classes.") + (defun ad-class-p (thing) (memq thing ad-advice-classes)) (defun ad-name-p (thing) @@ -1931,9 +1792,6 @@ either t or nil, and DEFINITION should be a list of the form ;; @@ Advice access functions: ;; =========================== -;; List of defined advice classes: -(defvar ad-advice-classes '(before around after activation deactivation)) - (defun ad-has-enabled-advice (function class) "True if at least one of FUNCTION's advices in CLASS is enabled." (cl-dolist (advice (ad-get-advice-info-field function class)) @@ -1950,7 +1808,7 @@ Redefining advices affect the construction of an advised definition." (defun ad-has-any-advice (function) "True if the advice info of FUNCTION defines at least one advice." (and (ad-is-advised function) - (cl-dolist (class ad-advice-classes nil) + (cl-dolist (class ad-advice-classes) (if (ad-get-advice-info-field function class) (cl-return t))))) @@ -1966,76 +1824,30 @@ Redefining advices affect the construction of an advised definition." ;; @@ Dealing with automatic advice activation via `fset/defalias': ;; ================================================================ -;; Since Emacs 19.26 the built-in versions of `fset' and `defalias' -;; take care of automatic advice activation, hence, we don't have to -;; hack it anymore by advising `fset/defun/defmacro/byte-code/etc'. +;; Automatic activation happens when a function gets defined via `defalias', +;; which calls the `defalias-fset-function' (which we set to +;; `ad--defalias-fset') instead of `fset', if non-nil. -;; The functionality of the new `fset' is as follows: -;; -;; fset(sym,newdef) -;; assign NEWDEF to SYM -;; if (get SYM 'ad-advice-info) -;; ad-activate-internal(SYM, nil) -;; return (symbol-function SYM) -;; ;; Whether advised definitions created by automatic activations will be ;; compiled depends on the value of `ad-default-compilation-action'. -;; Since calling `ad-activate-internal' in the built-in definition of `fset' can -;; create major disasters we have to be a bit careful. One precaution is -;; to provide a dummy definition for `ad-activate-internal' which can be used to -;; turn off automatic advice activation (e.g., when `ad-stop-advice' or -;; `ad-recover-normality' are called). Another is to avoid recursive calls -;; to `ad-activate' by using `ad-with-auto-activation-disabled' where -;; appropriate, especially in a safe version of `fset'. - -;; For now define `ad-activate-internal' to the dummy definition: -(defun ad-activate-internal (function &optional compile) - "Automatic advice activation is disabled. `ad-start-advice' enables it." - nil) - -;; This is just a copy of the above: -(defun ad-activate-internal-off (function &optional compile) - "Automatic advice activation is disabled. `ad-start-advice' enables it." - nil) - -;; This will be t for top-level calls to `ad-activate-internal-on': -(defvar ad-activate-on-top-level t) - -(defmacro ad-with-auto-activation-disabled (&rest body) - `(let ((ad-activate-on-top-level nil)) - ,@body)) +(defalias 'ad-activate-internal 'ad-activate) -(defun ad-safe-fset (symbol definition) - "A safe `fset' which will never call `ad-activate-internal' recursively." - (ad-with-auto-activation-disabled - (ad-real-fset symbol definition))) +(defun ad-make-advicefunname (function) + "Make name to be used to call the assembled advice function." + (intern (format "ad-Advice-%s" function))) +(defun ad-get-orig-definition (function) ;FIXME: Rename to "-unadvised-". + (if (symbolp function) + (setq function (if (fboundp function) + (advice--strip-macro (symbol-function function))))) + (while (advice--p function) (setq function (advice--cdr function))) + function) -;; @@ Access functions for original definitions: -;; ============================================ -;; The advice-info of an advised function contains its `origname' which is -;; a symbol that is fbound to the original definition available at the first -;; proper activation of the function after a valid re/definition. If the -;; original was defined via fcell indirection then `origname' will be defined -;; just so. Hence, to get hold of the actual original definition of a function -;; we need to use `ad-real-orig-definition'. - -(defun ad-make-origname (function) - "Make name to be used to call the original FUNCTION." - (intern (format "ad-Orig-%s" function))) - -(defmacro ad-get-orig-definition (function) - `(let ((origname (ad-get-advice-info-field ,function 'origname))) - (if (fboundp origname) - (symbol-function origname)))) - -(defmacro ad-set-orig-definition (function definition) - `(ad-safe-fset - (ad-get-advice-info-field ,function 'origname) ,definition)) - -(defmacro ad-clear-orig-definition (function) - `(fmakunbound (ad-get-advice-info-field ,function 'origname))) +(defun ad-clear-advicefunname-definition (function) + (let ((advicefunname (ad-get-advice-info-field function 'advicefunname))) + (advice-remove function advicefunname) + (fmakunbound advicefunname))) ;; @@ Interactive input functions: @@ -2053,7 +1865,7 @@ function at point for which PREDICATE returns non-nil)." (error "ad-read-advised-function: There are no advised functions")) (setq default (or default - ;; Prefer func name at point, if it's in ad-advised-functions etc. + ;; Prefer func name at point, if it's an advised function etc. (let ((function (progn (require 'help) (function-called-at-point)))) @@ -2062,24 +1874,20 @@ function at point for which PREDICATE returns non-nil)." (or (null predicate) (funcall predicate function)) function)) - (ad-do-advised-functions (function) - (if (or (null predicate) - (funcall predicate function)) - (cl-return function))) + (cl-block nil + (ad-do-advised-functions (function) + (if (or (null predicate) + (funcall predicate function)) + (cl-return function)))) (error "ad-read-advised-function: %s" "There are no qualifying advised functions"))) - (let* ((ad-pReDiCaTe predicate) - (function + (let* ((function (completing-read (format "%s (default %s): " (or prompt "Function") default) ad-advised-functions (if predicate - (function - (lambda (function) - ;; Oops, no closures - the joys of dynamic scoping: - ;; `predicate' clashed with the `predicate' argument - ;; of `completing-read'..... - (funcall ad-pReDiCaTe (intern (car function)))))) + (lambda (function) + (funcall predicate (intern (car function))))) t))) (if (equal function "") (if (ad-is-advised default) @@ -2299,7 +2107,7 @@ See Info node `(elisp)Computed Advice' for detailed documentation." (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) (ad-set-advice-info-field - function 'origname (ad-make-origname function)))) + function 'advicefunname (ad-make-advicefunname function)))) (let* ((previous-position (ad-advice-position function class (ad-advice-name advice))) (advices (ad-get-advice-info-field function class)) @@ -2332,12 +2140,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Take a macro function DEFINITION and make a lambda out of it." `(cdr ,definition)) -(defun ad-special-form-p (definition) - "Non-nil if and only if DEFINITION is a special form." - (if (and (symbolp definition) (fboundp definition)) - (setq definition (indirect-function definition))) - (and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled))) - (defmacro ad-subr-p (definition) ;;"non-nil if DEFINITION is a subr." (list 'subrp definition)) @@ -2377,10 +2179,8 @@ See Info node `(elisp)Computed Advice' for detailed documentation." (cdr definition)) (t nil))) -(defun ad-arglist (definition &optional name) - "Return the argument list of DEFINITION. -If DEFINITION could be from a subr then its NAME should be -supplied to make subr arglist lookup more efficient." +(defun ad-arglist (definition) + "Return the argument list of DEFINITION." (require 'help-fns) (help-function-arglist (if (or (ad-macro-p definition) (ad-advice-p definition)) @@ -2392,7 +2192,7 @@ supplied to make subr arglist lookup more efficient." "Return the unexpanded docstring of DEFINITION." (let ((docstring (if (ad-compiled-p definition) - (ad-real-documentation definition t) + (documentation definition t) (car (cdr (cdr (ad-lambda-expression definition))))))) (if (or (stringp docstring) (natnump docstring)) @@ -2415,13 +2215,16 @@ Like `interactive-form', but also works on pieces of advice." (if (ad-interactive-form definition) 1 0)) (cdr (cdr (ad-lambda-expression definition))))))) -(defun ad-make-advised-definition-docstring (function) +(defun ad-make-advised-definition-docstring (_function) "Make an identifying docstring for the advised definition of FUNCTION. Put function name into the documentation string so we can infer the name of the advised function from the docstring. This is needed to generate a proper advised docstring even if we are just given a definition (see the code for `documentation')." - (propertize "Advice doc string" 'ad-advice-info function)) + (eval-when-compile + (propertize "Advice function assembled by advice.el." + 'dynamic-docstring-function + #'ad--make-advised-docstring))) (defun ad-advised-definition-p (definition) "Return non-nil if DEFINITION was generated from advice information." @@ -2430,20 +2233,19 @@ definition (see the code for `documentation')." (ad-compiled-p definition)) (let ((docstring (ad-docstring definition))) (and (stringp docstring) - (get-text-property 0 'ad-advice-info docstring))))) + (get-text-property 0 'dynamic-docstring-function docstring))))) (defun ad-definition-type (definition) "Return symbol that describes the type of DEFINITION." + ;; These symbols are only ever used to check a cache entry's validity. + ;; The suffix `2' reflects the fact that we're using version 2 of advice + ;; representations, so cache entries preactivated with version + ;; 1 can't be used. (cond - ((ad-macro-p definition) 'macro) - ((ad-subr-p definition) - (if (ad-special-form-p definition) - 'special-form - 'subr)) - ((or (ad-lambda-p definition) - (ad-compiled-p definition)) - 'function) - ((ad-advice-p definition) 'advice))) + ((ad-macro-p definition) 'macro2) + ((ad-subr-p definition) 'subr2) + ((or (ad-lambda-p definition) (ad-compiled-p definition)) 'fun2) + ((ad-advice-p definition) 'advice2))) ;; FIXME: Can this ever happen? (defun ad-has-proper-definition (function) "True if FUNCTION is a symbol with a proper definition. @@ -2463,9 +2265,9 @@ For that it has to be fbound with a non-autoload definition." definition)))) (defun ad-real-orig-definition (function) - "Find FUNCTION's real original definition starting from its `origname'." - (if (ad-is-advised function) - (ad-real-definition (ad-get-advice-info-field function 'origname)))) + (let* ((fun1 (ad-get-orig-definition function)) + (fun2 (indirect-function fun1))) + (unless (autoloadp fun2) fun2))) (defun ad-is-compilable (function) "True if FUNCTION has an interpreted definition that can be compiled." @@ -2474,25 +2276,17 @@ For that it has to be fbound with a non-autoload definition." (ad-macro-p (symbol-function function))) (not (ad-compiled-p (symbol-function function))))) +(defvar warning-suppress-types) ;From warnings.el. (defun ad-compile-function (function) - "Byte-compiles FUNCTION (or macro) if it is not yet compiled." - (interactive "aByte-compile function: ") - (if (ad-is-compilable function) - ;; Need to turn off auto-activation - ;; because `byte-compile' uses `fset': - (ad-with-auto-activation-disabled - (require 'bytecomp) - (require 'warnings) ;To define warning-suppress-types - ;before we let-bind it. - (let ((symbol (make-symbol "advice-compilation")) - (byte-compile-warnings byte-compile-warnings) - ;; Don't pop up windows showing byte-compiler warnings. - (warning-suppress-types '((bytecomp)))) - (if (featurep 'cl) - (byte-compile-disable-warning 'cl-functions)) - (fset symbol (symbol-function function)) - (byte-compile symbol) - (fset function (symbol-function symbol)))))) + "Byte-compile the assembled advice function." + (require 'bytecomp) + (require 'warnings) ;To define warning-suppress-types before we let-bind it. + (let ((byte-compile-warnings byte-compile-warnings) + ;; Don't pop up windows showing byte-compiler warnings. + (warning-suppress-types '((bytecomp)))) + (if (featurep 'cl) + (byte-compile-disable-warning 'cl-functions)) + (byte-compile (ad-get-advice-info-field function 'advicefunname)))) ;; @@@ Accessing argument lists: ;; ============================= @@ -2604,24 +2398,20 @@ The assignment starts at position INDEX." (let ((values-index 0) argument-access set-forms) (while (setq argument-access (ad-access-argument arglist index)) - (if (symbolp argument-access) - (setq set-forms - (cons (ad-set-argument - arglist index - (ad-element-access values-index 'ad-vAlUeS)) - set-forms)) - (setq set-forms - (cons (if (= (car argument-access) 0) - (list 'setq - (car (cdr argument-access)) - (ad-list-access values-index 'ad-vAlUeS)) - (list 'setcdr - (ad-list-access (1- (car argument-access)) - (car (cdr argument-access))) - (ad-list-access values-index 'ad-vAlUeS))) - set-forms)) - ;; terminate loop - (setq arglist nil)) + (push (if (symbolp argument-access) + (ad-set-argument + arglist index + (ad-element-access values-index 'ad-vAlUeS)) + (setq arglist nil) ;; Terminate loop. + (if (= (car argument-access) 0) + `(setq + ,(car (cdr argument-access)) + ,(ad-list-access values-index 'ad-vAlUeS)) + `(setcdr + ,(ad-list-access (1- (car argument-access)) + (car (cdr argument-access))) + ,(ad-list-access values-index 'ad-vAlUeS)))) + set-forms) (setq index (1+ index)) (setq values-index (1+ values-index))) (if (null set-forms) @@ -2630,8 +2420,8 @@ The assignment starts at position INDEX." (if (= (length set-forms) 1) ;; For exactly one set-form we can use values-form directly,... (ad-substitute-tree - (function (lambda (form) (eq form 'ad-vAlUeS))) - (function (lambda (form) values-form)) + (lambda (form) (eq form 'ad-vAlUeS)) + (lambda (_form) values-form) (car set-forms)) ;; ...if we have more we have to bind it to a variable: `(let ((ad-vAlUeS ,values-form)) @@ -2683,7 +2473,7 @@ Excess source arguments will be neglected, missing source arguments will be supplied as nil. Returns a `funcall' or `apply' form with the second element being `function' which has to be replaced by an actual function argument. Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return - `(funcall function a (car args) (car (cdr args)) (nth 2 args))'." + `(funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))'." (let* ((parsed-source-arglist (ad-parse-arglist source-arglist)) (source-reqopt-args (append (nth 0 parsed-source-arglist) (nth 1 parsed-source-arglist))) @@ -2697,15 +2487,14 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return ;; This produces ``error-proof'' target function calls with the exception ;; of a case like (&rest a) mapped onto (x &rest y) where the actual args ;; supplied to A might not be enough to supply the required target arg X - (append (list (if need-apply 'apply 'funcall) 'function) + (append (list (if need-apply 'apply 'funcall) 'ad--addoit-function) (cond (need-apply ;; `apply' can take care of that directly: (append source-reqopt-args (list source-rest-arg))) - (t (mapcar (function - (lambda (arg) - (setq target-arg-index (1+ target-arg-index)) - (ad-get-argument - source-arglist target-arg-index))) + (t (mapcar (lambda (_arg) + (setq target-arg-index (1+ target-arg-index)) + (ad-get-argument + source-arglist target-arg-index)) (append target-reqopt-args (and target-rest-arg ;; If we have a rest arg gobble up @@ -2713,13 +2502,6 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (nthcdr (length target-reqopt-args) source-reqopt-args))))))))) -(defun ad-make-mapped-call (source-arglist target-arglist target-function) - "Make form to call TARGET-FUNCTION with args from SOURCE-ARGLIST." - (let ((mapped-form (ad-map-arglists source-arglist target-arglist))) - (if (eq (car mapped-form) 'funcall) - (cons target-function (cdr (cdr mapped-form))) - (prog1 mapped-form - (setcar (cdr mapped-form) (list 'quote target-function)))))) ;; @@@ Making an advised documentation string: ;; =========================================== @@ -2736,11 +2518,6 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (let ((advice-docstring (ad-docstring (ad-advice-definition advice)))) (cond ((eq style 'plain) advice-docstring) - ((eq style 'freeze) - (format "Permanent %s-advice `%s':%s%s" - class (ad-advice-name advice) - (if advice-docstring "\n" "") - (or advice-docstring ""))) (t (if advice-docstring (format "%s-advice `%s':\n%s" (capitalize (symbol-name class)) @@ -2752,25 +2529,22 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (require 'help-fns) ;For help-split-fundoc and help-add-fundoc-usage. -(defun ad-make-advised-docstring (function &optional style) +(defun ad--make-advised-docstring (origdoc function &optional style) "Construct a documentation string for the advised FUNCTION. It concatenates the original documentation with the documentation strings of the individual pieces of advice which will be formatted -according to STYLE. STYLE can be `plain' or `freeze', everything else +according to STYLE. STYLE can be `plain', everything else will be interpreted as `default'. The order of the advice documentation strings corresponds to before/around/after and the individual ordering in any of these classes." - (let* ((origdef (ad-real-orig-definition function)) - (origtype (symbol-name (ad-definition-type origdef))) - (origdoc - ;; Retrieve raw doc, key substitution will be taken care of later: - (ad-real-documentation origdef t)) - (usage (help-split-fundoc origdoc function)) - paragraphs advice-docstring ad-usage) + (if (and (symbolp function) + (string-match "\\`ad-+Advice-" (symbol-name function))) + (setq function + (intern (substring (symbol-name function) (match-end 0))))) + (let* ((usage (help-split-fundoc origdoc function)) + paragraphs advice-docstring) (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) (if origdoc (setq paragraphs (list origdoc))) - (unless (eq style 'plain) - (push (concat "This " origtype " is advised.") paragraphs)) (dolist (class ad-advice-classes) (dolist (advice (ad-get-enabled-advices function class)) (setq advice-docstring @@ -2781,13 +2555,11 @@ in any of these classes." (propertize ;; separate paragraphs with blank lines: (mapconcat 'identity (nreverse paragraphs) "\n\n") - 'ad-advice-info function))) + ;; FIXME: what is this for? + 'dynamic-docstring-function + #'ad--make-advised-docstring))) (help-add-fundoc-usage origdoc usage))) -(defun ad-make-plain-docstring (function) - (ad-make-advised-docstring function 'plain)) -(defun ad-make-freeze-docstring (function) - (ad-make-advised-docstring function 'freeze)) ;; @@@ Accessing overriding arglists and interactive forms: ;; ======================================================== @@ -2821,64 +2593,18 @@ in any of these classes." (if (and (ad-is-advised function) (ad-has-redefining-advice function)) (let* ((origdef (ad-real-orig-definition function)) - (origname (ad-get-advice-info-field function 'origname)) - (orig-interactive-p (commandp origdef)) - (orig-subr-p (ad-subr-p origdef)) - (orig-special-form-p (ad-special-form-p origdef)) - (orig-macro-p (ad-macro-p origdef)) ;; Construct the individual pieces that we need for assembly: - (orig-arglist (ad-arglist origdef function)) + (orig-arglist (let ((args (ad-arglist origdef))) + ;; The arglist may still be unknown. + (if (listp args) args '(&rest args)))) (advised-arglist (or (ad-advised-arglist function) orig-arglist)) - (advised-interactive-form (ad-advised-interactive-form function)) - (interactive-form - (cond (orig-macro-p nil) - (advised-interactive-form) - ((interactive-form origdef) - (interactive-form - (if (and (symbolp function) (get function 'elp-info)) - (aref (get function 'elp-info) 2) - origdef))))) + (interactive-form (ad-advised-interactive-form function)) (orig-form - (cond ((or orig-special-form-p orig-macro-p) - ;; Special forms and macros will be advised into macros. - ;; The trick is to construct an expansion for the advised - ;; macro that does the correct thing when it gets eval'ed. - ;; For macros we'll just use the expansion of the original - ;; macro and return that. This way compiled advised macros - ;; will be expanded into something useful. Note that after - ;; advices have full control over whether they want to - ;; evaluate the expansion (the value of `ad-return-value') - ;; at macro expansion time or not. For special forms there - ;; is no solution that interacts reasonably with the - ;; compiler, hence we just evaluate the original at macro - ;; expansion time and return the result. The moral of that - ;; is that one should always deactivate advised special - ;; forms before one byte-compiles a file. - `(,(if orig-macro-p 'macroexpand 'eval) - (cons ',origname - ,(ad-get-arguments advised-arglist 0)))) - ((and orig-subr-p - orig-interactive-p - (not interactive-form) - (not advised-interactive-form)) - ;; Check whether we were called interactively - ;; in order to do proper prompting: - `(if (called-interactively-p 'any) - (call-interactively ',origname) - ,(ad-make-mapped-call advised-arglist - orig-arglist - origname))) - ;; And now for normal functions and non-interactive subrs - ;; (or subrs whose interactive behavior was advised): - (t (ad-make-mapped-call - advised-arglist orig-arglist origname))))) + (ad-map-arglists advised-arglist orig-arglist))) ;; Finally, build the sucker: (ad-assemble-advised-definition - (cond (orig-macro-p 'macro) - (orig-special-form-p 'special-form) - (t 'function)) advised-arglist (ad-make-advised-definition-docstring function) interactive-form @@ -2888,13 +2614,11 @@ in any of these classes." (ad-get-enabled-advices function 'after))))) (defun ad-assemble-advised-definition - (type args docstring interactive orig &optional befores arounds afters) - - "Assembles an original and its advices into an advised function. -It constructs a function or macro definition according to TYPE which has to -be either `macro', `function' or `special-form'. ARGS is the argument list -that has to be used, DOCSTRING if non-nil defines the documentation of the -definition, INTERACTIVE if non-nil is the interactive form to be used, + (args docstring interactive orig &optional befores arounds afters) + "Assemble the advices into an overall advice function. +ARGS is the argument list that has to be used, +DOCSTRING if non-nil defines the documentation of the definition, +INTERACTIVE if non-nil is the interactive form to be used, ORIG is a form that calls the body of the original unadvised function, and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG should be modified. The assembled function will be returned." @@ -2922,8 +2646,8 @@ should be modified. The assembled function will be returned." (setq around-form-protected t)) (setq around-form (ad-substitute-tree - (function (lambda (form) (eq form 'ad-do-it))) - (function (lambda (form) around-form)) + (lambda (form) (eq form 'ad-do-it)) + (lambda (_form) around-form) (macroexp-progn (ad-body-forms (ad-advice-definition advice)))))) (setq after-forms @@ -2945,16 +2669,12 @@ should be modified. The assembled function will be returned." (ad-body-forms (ad-advice-definition advice))))))) (setq definition - `(,@(if (memq type '(macro special-form)) '(macro)) - lambda - ,args + `(lambda (ad--addoit-function ,@args) ,@(if docstring (list docstring)) ,@(if interactive (list interactive)) (let (ad-return-value) ,@after-forms - ,(if (eq type 'special-form) - '(list 'quote ad-return-value) - 'ad-return-value)))) + ad-return-value))) (ad-insert-argument-access-forms definition args))) @@ -3051,17 +2771,17 @@ advised definition from scratch." "Generate an identifying image of the current advices of FUNCTION." (let ((original-definition (ad-real-orig-definition function)) (cached-definition (ad-get-cache-definition function))) - (list (mapcar (function (lambda (advice) (ad-advice-name advice))) + (list (mapcar #'ad-advice-name (ad-get-enabled-advices function 'before)) - (mapcar (function (lambda (advice) (ad-advice-name advice))) + (mapcar #'ad-advice-name (ad-get-enabled-advices function 'around)) - (mapcar (function (lambda (advice) (ad-advice-name advice))) + (mapcar #'ad-advice-name (ad-get-enabled-advices function 'after)) (ad-definition-type original-definition) - (if (equal (ad-arglist original-definition function) + (if (equal (ad-arglist original-definition) (ad-arglist cached-definition)) t - (ad-arglist original-definition function)) + (ad-arglist original-definition)) (if (eq (ad-definition-type original-definition) 'function) (equal (interactive-form original-definition) (interactive-form cached-definition)))))) @@ -3106,7 +2826,7 @@ advised definition from scratch." (and (eq (nth 3 cache-id) (ad-definition-type original-definition)) (setq code 'arglist-mismatch) (equal (if (eq (nth 4 cache-id) t) - (ad-arglist original-definition function) + (ad-arglist original-definition) (nth 4 cache-id) ) (ad-arglist cached-definition)) (setq code 'interactive-form-mismatch) @@ -3146,10 +2866,8 @@ advised definition from scratch." (defun ad-preactivate-advice (function advice class position) "Preactivate FUNCTION and returns the constructed cache." - (let* ((function-defined-p (fboundp function)) - (old-definition - (if function-defined-p - (symbol-function function))) + (let* ((advicefunname (ad-get-advice-info-field function 'advicefunname)) + (old-advice (symbol-function advicefunname)) (old-advice-info (ad-copy-advice-info function)) (ad-advised-functions ad-advised-functions)) (unwind-protect @@ -3163,94 +2881,9 @@ advised definition from scratch." (list (ad-get-cache-definition function) (ad-get-cache-id function)))) (ad-set-advice-info function old-advice-info) - ;; Don't `fset' function to nil if it was previously unbound: - (if function-defined-p - (ad-safe-fset function old-definition) - (fmakunbound function))))) - - -;; @@ Freezing: -;; ============ -;; Freezing transforms a `defadvice' into a redefining `defun/defmacro' -;; for the advised function without keeping any advice information. This -;; feature was jwz's idea: It generates a dumpable function definition -;; whose documentation can be written to the DOC file, and the generated -;; code does not need any Advice runtime support. Of course, frozen advices -;; cannot be undone. - -;; Freezing only considers the advice of the particular `defadvice', other -;; already existing advices for the same function will be ignored. To ensure -;; proper interaction when an already advised function gets redefined with -;; a frozen advice, frozen advices always use the actual original definition -;; of the function, i.e., they are always at the core of the onion. E.g., if -;; an already advised function gets redefined with a frozen advice and then -;; unadvised, the frozen advice remains as the new definition of the function. - -;; While multiple freeze advices for a single function or freeze-advising -;; of an already advised function are possible, they are better avoided, -;; because definition/compile/load ordering is relevant, and it becomes -;; incomprehensible pretty quickly. - -(defun ad-make-freeze-definition (function advice class position) - (if (not (ad-has-proper-definition function)) - (error - "ad-make-freeze-definition: `%s' is not yet defined" - function)) - (let* ((name (ad-advice-name advice)) - ;; With a unique origname we can have multiple freeze advices - ;; for the same function, each overloading the previous one: - (unique-origname - (intern (format "%s-%s-%s" (ad-make-origname function) class name))) - (orig-definition - ;; If FUNCTION is already advised, we'll use its current origdef - ;; as the original definition of the frozen advice: - (or (ad-get-orig-definition function) - (symbol-function function))) - (old-advice-info - (if (ad-is-advised function) - (ad-copy-advice-info function))) - (real-docstring-fn - (symbol-function 'ad-make-advised-definition-docstring)) - (real-origname-fn - (symbol-function 'ad-make-origname)) - (frozen-definition - (unwind-protect - (progn - ;; Make sure we construct a proper docstring: - (ad-safe-fset 'ad-make-advised-definition-docstring - 'ad-make-freeze-docstring) - ;; Make sure `unique-origname' is used as the origname: - (ad-safe-fset 'ad-make-origname (lambda (x) unique-origname)) - ;; No we reset all current advice information to nil and - ;; generate an advised definition that's solely determined - ;; by ADVICE and the current origdef of FUNCTION: - (ad-set-advice-info function nil) - (ad-add-advice function advice class position) - ;; The following will provide proper real docstrings as - ;; well as a definition that will make the compiler happy: - (ad-set-orig-definition function orig-definition) - (ad-make-advised-definition function)) - ;; Restore the old advice state: - (ad-set-advice-info function old-advice-info) - ;; Restore functions: - (ad-safe-fset - 'ad-make-advised-definition-docstring real-docstring-fn) - (ad-safe-fset 'ad-make-origname real-origname-fn)))) - (if frozen-definition - (let* ((macro-p (ad-macro-p frozen-definition)) - (body (cdr (if macro-p - (ad-lambdafy frozen-definition) - frozen-definition)))) - `(progn - (if (not (fboundp ',unique-origname)) - (fset ',unique-origname - ;; avoid infinite recursion in case the function - ;; we want to freeze is already advised: - (or (ad-get-orig-definition ',function) - (symbol-function ',function)))) - (,(if macro-p 'defmacro 'defun) - ,function - ,@body)))))) + (advice-remove function advicefunname) + (fset advicefunname old-advice) + (if old-advice (advice-add function :around advicefunname))))) ;; @@ Activation and definition handling: @@ -3262,45 +2895,56 @@ If COMPILE is non-nil and not a negative number then it returns t. If COMPILE is a negative number then it returns nil. If COMPILE is nil then the result depends on the value of `ad-default-compilation-action' (which see)." - (if (integerp compile) - (>= compile 0) - (if compile - compile - (cond ((eq ad-default-compilation-action 'never) - nil) - ((eq ad-default-compilation-action 'always) - t) - ((eq ad-default-compilation-action 'like-original) - (or (ad-subr-p (ad-get-orig-definition function)) - (ad-compiled-p (ad-get-orig-definition function)))) - ;; everything else means `maybe': - (t (featurep 'byte-compile)))))) + (cond + ;; Don't compile until the real function definition is known (bug#12965). + ((not (ad-real-orig-definition function)) nil) + ((integerp compile) (>= compile 0)) + (compile) + ((eq ad-default-compilation-action 'never) nil) + ((eq ad-default-compilation-action 'always) t) + ((eq ad-default-compilation-action 'like-original) + (or (ad-subr-p (ad-get-orig-definition function)) + (ad-compiled-p (ad-get-orig-definition function)))) + ;; everything else means `maybe': + (t (featurep 'byte-compile)))) (defun ad-activate-advised-definition (function compile) "Redefine FUNCTION with its advised definition from cache or scratch. The resulting FUNCTION will be compiled if `ad-should-compile' returns t. The current definition and its cache-id will be put into the cache." - (let ((verified-cached-definition - (if (ad-verify-cache-id function) - (ad-get-cache-definition function)))) - (ad-safe-fset function - (or verified-cached-definition - (ad-make-advised-definition function))) + (let* ((verified-cached-definition + (if (ad-verify-cache-id function) + (ad-get-cache-definition function))) + (advicefunname (ad-get-advice-info-field function 'advicefunname)) + (old-ispec (interactive-form advicefunname))) + (fset advicefunname + (or verified-cached-definition + (ad-make-advised-definition function))) + (unless (equal (interactive-form advicefunname) old-ispec) + ;; If the interactive-spec of advicefunname has changed, force nadvice to + ;; refresh its copy. + (advice-remove function advicefunname)) + (advice-add function :around advicefunname) (if (ad-should-compile function compile) (ad-compile-function function)) (if verified-cached-definition - (if (not (eq verified-cached-definition (symbol-function function))) + (if (not (eq verified-cached-definition + (symbol-function advicefunname))) ;; we must have compiled, cache the compiled definition: - (ad-set-cache - function (symbol-function function) (ad-get-cache-id function))) + (ad-set-cache function (symbol-function advicefunname) + (ad-get-cache-id function))) ;; We created a new advised definition, cache it with a proper id: (ad-clear-cache function) ;; ad-make-cache-id needs the new cached definition: - (ad-set-cache function (symbol-function function) nil) + (ad-set-cache function (symbol-function advicefunname) nil) (ad-set-cache - function (symbol-function function) (ad-make-cache-id function))))) + function (symbol-function advicefunname) (ad-make-cache-id function))))) -(defun ad-handle-definition (function) +(defun ad--defalias-fset (fsetfun function newdef) + ;; Besides ad-redefinition-action we use this defalias-fset-function hook + ;; for two other reasons: + ;; - for `activation/deactivation' advices. + ;; - to rebuild the ad-Advice-* function with the right argument names. "Handle re/definition of an advised FUNCTION during de/activation. If FUNCTION does not have an original definition associated with it and the current definition is usable, then it will be stored as FUNCTION's @@ -3312,33 +2956,27 @@ associated with it but got redefined with a new definition and then de/activated. If you do not like the current redefinition action change the value of `ad-redefinition-action' and de/activate again." (let ((original-definition (ad-get-orig-definition function)) - (current-definition (if (ad-real-definition function) - (symbol-function function)))) + (current-definition (ad-get-orig-definition newdef))) (if original-definition (if current-definition - (if (and (not (eq current-definition original-definition)) - ;; Redefinition with an advised definition from a - ;; different function won't count as such: - (not (ad-advised-definition-p current-definition))) - ;; we have a redefinition: + (if (not (eq current-definition original-definition)) + ;; We have a redefinition: (if (not (memq ad-redefinition-action '(accept discard warn))) - (error "ad-handle-definition (see its doc): `%s' %s" + (error "ad-redefinition-action: `%s' %s" function "invalidly redefined") (if (eq ad-redefinition-action 'discard) - (ad-safe-fset function original-definition) - (ad-set-orig-definition function current-definition) + nil ;; Just drop it! + (funcall (or fsetfun #'fset) function newdef) + (ad-activate-internal function) (if (eq ad-redefinition-action 'warn) (message "ad-handle-definition: `%s' got redefined" function)))) ;; either advised def or correct original is in place: nil) - ;; we have an undefinition, ignore it: - nil) - (if current-definition - ;; we have a first definition, save it as original: - (ad-set-orig-definition function current-definition) - ;; we don't have anything noteworthy: - nil)))) + ;; We have an undefinition, ignore it: + (funcall (or fsetfun #'fset) function newdef)) + (funcall (or fsetfun #'fset) function newdef) + (when current-definition (ad-activate-internal function))))) ;; @@ The top-level advice interface: @@ -3364,24 +3002,20 @@ definition will always be cached for later usage." (interactive (list (ad-read-advised-function "Activate advice of") current-prefix-arg)) - (if ad-activate-on-top-level - ;; avoid recursive calls to `ad-activate': - (ad-with-auto-activation-disabled - (if (not (ad-is-advised function)) - (error "ad-activate: `%s' is not advised" function) - (ad-handle-definition function) - ;; Just return for forward advised and not yet defined functions: - (if (ad-get-orig-definition function) - (if (not (ad-has-any-advice function)) - (ad-unadvise function) - ;; Otherwise activate the advice: - (cond ((ad-has-redefining-advice function) - (ad-activate-advised-definition function compile) - (ad-set-advice-info-field function 'active t) - (eval (ad-make-hook-form function 'activation)) - function) - ;; Here we are if we have all disabled advices: - (t (ad-deactivate function))))))))) + (cond + ((not (ad-is-advised function)) + (error "ad-activate: `%s' is not advised" function)) + ;; Just return for forward advised and not yet defined functions: + ((not (ad-get-orig-definition function)) nil) + ((not (ad-has-any-advice function)) (ad-unadvise function)) + ;; Otherwise activate the advice: + ((ad-has-redefining-advice function) + (ad-activate-advised-definition function compile) + (ad-set-advice-info-field function 'active t) + (eval (ad-make-hook-form function 'activation)) + function) + ;; Here we are if we have all disabled advices: + (t (ad-deactivate function)))) (defalias 'ad-activate-on 'ad-activate) @@ -3396,11 +3030,10 @@ a call to `ad-activate'." (if (not (ad-is-advised function)) (error "ad-deactivate: `%s' is not advised" function) (cond ((ad-is-active function) - (ad-handle-definition function) (if (not (ad-get-orig-definition function)) (error "ad-deactivate: `%s' has no original definition" function) - (ad-safe-fset function (ad-get-orig-definition function)) + (ad-clear-advicefunname-definition function) (ad-set-advice-info-field function 'active nil) (eval (ad-make-hook-form function 'deactivation)) function))))) @@ -3422,7 +3055,7 @@ If FUNCTION was not advised this will be a noop." (cond ((ad-is-advised function) (if (ad-is-active function) (ad-deactivate function)) - (ad-clear-orig-definition function) + (ad-clear-advicefunname-definition function) (ad-set-advice-info function nil) (ad-pop-advised-function function)))) @@ -3437,9 +3070,7 @@ Use in emergencies." (list (intern (completing-read "Recover advised function: " obarray nil t)))) (cond ((ad-is-advised function) - (cond ((ad-get-orig-definition function) - (ad-safe-fset function (ad-get-orig-definition function)) - (ad-clear-orig-definition function))) + (ad-clear-advicefunname-definition function) (ad-set-advice-info function nil) (ad-pop-advised-function function)))) @@ -3519,7 +3150,7 @@ deactivation, which might run hooks and get into other trouble." ;; Completion alist of valid `defadvice' flags (defvar ad-defadvice-flags '(("protect") ("disable") ("activate") - ("compile") ("preactivate") ("freeze"))) + ("compile") ("preactivate"))) ;;;###autoload (defmacro defadvice (function args &rest body) @@ -3538,7 +3169,7 @@ POSITION ::= `first' | `last' | NUMBER. Optional, defaults to `first', ARGLIST ::= An optional argument list to be used for the advised function instead of the argument list of the original. The first one found in before/around/after-advices will be used. -FLAG ::= `protect'|`disable'|`activate'|`compile'|`preactivate'|`freeze'. +FLAG ::= `protect'|`disable'|`activate'|`compile'|`preactivate'. All flags can be specified with unambiguous initial substrings. DOCSTRING ::= Optional documentation for this piece of advice. INTERACTIVE-FORM ::= Optional interactive form to be used for the advised @@ -3564,13 +3195,6 @@ time. This generates a compiled advised definition according to the current advice state that will be used during activation if appropriate. Only use this if the `defadvice' gets actually compiled. -`freeze': Expands the `defadvice' into a redefining `defun/defmacro' according -to this particular single advice. No other advice information will be saved. -Frozen advices cannot be undone, they behave like a hard redefinition of -the advised function. `freeze' implies `activate' and `preactivate'. The -documentation of the advised function can be dumped onto the `DOC' file -during preloading. - See Info node `(elisp)Advising Functions' for comprehensive documentation. usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) [DOCSTRING] [INTERACTIVE-FORM] @@ -3620,29 +3244,24 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) (ad-preactivate-advice function advice class position)))) ;; Now for the things to be done at evaluation time: - (if (memq 'freeze flags) - ;; jwz's idea: Freeze the advised definition into a dumpable - ;; defun/defmacro whose docs can be written to the DOC file: - (ad-make-freeze-definition function advice class position) - ;; the normal case: - `(progn - (ad-add-advice ',function ',advice ',class ',position) - ,@(if preactivation - `((ad-set-cache - ',function - ;; the function will get compiled: - ,(cond ((ad-macro-p (car preactivation)) - `(ad-macrofy - (function - ,(ad-lambdafy - (car preactivation))))) - (t `(function - ,(car preactivation)))) - ',(car (cdr preactivation))))) - ,@(if (memq 'activate flags) - `((ad-activate ',function - ,(if (memq 'compile flags) t)))) - ',function)))) + `(progn + (ad-add-advice ',function ',advice ',class ',position) + ,@(if preactivation + `((ad-set-cache + ',function + ;; the function will get compiled: + ,(cond ((ad-macro-p (car preactivation)) + `(ad-macrofy + (function + ,(ad-lambdafy + (car preactivation))))) + (t `(function + ,(car preactivation)))) + ',(car (cdr preactivation))))) + ,@(if (memq 'activate flags) + `((ad-activate ',function + ,(if (memq 'compile flags) t)))) + ',function))) ;; @@ Tools: @@ -3670,59 +3289,35 @@ undone on exit of this macro." ;; Make forms to redefine functions to their ;; original definitions if they are advised: (setq index -1) - (mapcar - (function - (lambda (function) - (setq index (1+ index)) - `(ad-safe-fset - ',function - (or (ad-get-orig-definition ',function) - ,(car (nth index current-bindings)))))) - functions)) + (mapcar (lambda (function) + (setq index (1+ index)) + `(fset ',function + (or (ad-get-orig-definition ',function) + ,(car (nth index current-bindings))))) + functions)) ,@body) ,@(progn ;; Make forms to back-define functions to the definitions ;; they had outside this macro call: (setq index -1) - (mapcar - (function - (lambda (function) - (setq index (1+ index)) - `(ad-safe-fset - ',function - ,(car (nth index current-bindings))))) - functions)))))) + (mapcar (lambda (function) + (setq index (1+ index)) + `(fset ',function + ,(car (nth index current-bindings)))) + functions)))))) ;; @@ Starting, stopping and recovering from the advice package magic: ;; =================================================================== -(defun ad-start-advice () - "Start the automatic advice handling magic." - (interactive) - ;; Advising `ad-activate-internal' means death!! - (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate)) - -(defun ad-stop-advice () - "Stop the automatic advice handling magic. -You should only need this in case of Advice-related emergencies." - (interactive) - ;; Advising `ad-activate-internal' means death!! - (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off)) - (defun ad-recover-normality () "Undo all advice related redefinitions and unadvises everything. Use only in REAL emergencies." (interactive) - ;; Advising `ad-activate-internal' means death!! - (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off) (ad-recover-all) - (setq ad-advised-functions nil)) - -(ad-start-advice) + (ad-do-advised-functions (function) + (message "Oops! Left over advised function %S" function) + (ad-pop-advised-function function))) (provide 'advice) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0ddc78242ac..7375c2176ba 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1187,8 +1187,8 @@ boundp buffer-file-name buffer-local-variables buffer-modified-p buffer-substring byte-code-function-p capitalize car-less-than-car car cdr ceiling char-after char-before - char-equal char-to-string char-width - compare-strings concat coordinates-in-window-p + char-equal char-to-string char-width compare-strings + compare-window-configurations concat coordinates-in-window-p copy-alist copy-sequence copy-marker cos count-lines decode-char decode-time default-boundp default-value documentation downcase @@ -1196,17 +1196,18 @@ fboundp fceiling featurep ffloor file-directory-p file-exists-p file-locked-p file-name-absolute-p file-newer-than-file-p file-readable-p file-symlink-p file-writable-p - float float-time floor format format-time-string frame-visible-p - fround ftruncate + float float-time floor format format-time-string frame-first-window + frame-root-window frame-selected-window + frame-visible-p fround ftruncate get gethash get-buffer get-buffer-window getenv get-file-buffer hash-table-count int-to-string intern-soft keymap-parent length local-variable-if-set-p local-variable-p log log10 logand logb logior lognot logxor lsh langinfo - make-list make-string make-symbol - marker-buffer max member memq min mod multibyte-char-to-unibyte - next-window nth nthcdr number-to-string + make-list make-string make-symbol marker-buffer max member memq min + minibuffer-selected-window minibuffer-window + mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string parse-colon-path plist-get plist-member prefix-numeric-value previous-window prin1-to-string propertize degrees-to-radians @@ -1221,9 +1222,19 @@ unibyte-char-to-multibyte upcase user-full-name user-login-name user-original-login-name custom-variable-p vconcat - window-buffer window-dedicated-p window-edges window-height - window-hscroll window-minibuffer-p window-width - zerop)) + window-absolute-pixel-edges window-at window-body-height + window-body-width window-buffer window-dedicated-p window-display-table + window-combination-limit window-edges window-frame window-fringes + window-height window-hscroll window-inside-edges + window-inside-absolute-pixel-edges window-inside-pixel-edges + window-left-child window-left-column window-margins window-minibuffer-p + window-next-buffers window-next-sibling window-new-normal + window-new-total window-normal-size window-parameter window-parameters + window-parent window-pixel-edges window-point window-prev-buffers + window-prev-sibling window-redisplay-end-trigger window-scroll-bars + window-start window-text-height window-top-child window-top-line + window-total-height window-total-width window-use-time window-vscroll + window-width zerop)) (side-effect-and-error-free-fns '(arrayp atom bobp bolp bool-vector-p @@ -1256,7 +1267,8 @@ this-single-command-raw-keys user-real-login-name user-real-uid user-uid vector vectorp visible-frame-list - wholenump window-configuration-p window-live-p windowp))) + wholenump window-configuration-p window-live-p + window-valid-p windowp))) (while side-effect-free-fns (put (car side-effect-free-fns) 'side-effect-free t) (setq side-effect-free-fns (cdr side-effect-free-fns))) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 7322c0fbe6f..48bcefaee1a 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -81,10 +81,14 @@ The return value of this function is not used." #'(lambda (f _args new-name when) `(make-obsolete ',f ',new-name ,when))) (list 'compiler-macro - #'(lambda (f _args compiler-function) - (if (not (symbolp compiler-function)) - (error "Only symbols are supported in `compiler-macro'") - `(put ',f 'compiler-macro #',compiler-function)))) + #'(lambda (f args compiler-function) + ;; FIXME: Make it possible to just reuse `args'. + `(eval-and-compile + (put ',f 'compiler-macro + ,(if (eq (car-safe compiler-function) 'lambda) + `(lambda ,(append (cadr compiler-function) args) + ,@(cddr compiler-function)) + `#',compiler-function))))) (list 'doc-string #'(lambda (f _args pos) (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos)))) @@ -388,15 +392,15 @@ If you think you need this, you're probably making a mistake somewhere." Thus, the result of the body appears to the compiler as a quoted constant. In interpreted code, this is entirely equivalent to `progn'." (declare (debug t) (indent 0)) - ;; Not necessary because we have it in b-c-initial-macro-environment - ;; (list 'quote (eval (cons 'progn body))) - (cons 'progn body)) + (list 'quote (eval (cons 'progn body) lexical-binding))) (defmacro eval-and-compile (&rest body) "Like `progn', but evaluates the body at compile time and at load time." (declare (debug t) (indent 0)) - ;; Remember, it's magic. - (cons 'progn body)) + ;; When the byte-compiler expands code, this macro is not used, so we're + ;; either about to run `body' (plain interpretation) or we're doing eager + ;; macroexpansion. + (list 'quote (eval (cons 'progn body) lexical-binding))) (put 'with-no-warnings 'lisp-indent-function 0) (defun with-no-warnings (&rest body) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ce3a3324e18..280a1bbc2dd 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -419,8 +419,8 @@ This list lives partly on the stack.") (defconst byte-compile-initial-macro-environment '( -;; (byte-compiler-options . (lambda (&rest forms) -;; (apply 'byte-compiler-options-handler forms))) + ;; (byte-compiler-options . (lambda (&rest forms) + ;; (apply 'byte-compiler-options-handler forms))) (declare-function . byte-compile-macroexpand-declare-function) (eval-when-compile . (lambda (&rest body) (list @@ -429,8 +429,19 @@ This list lives partly on the stack.") (byte-compile-top-level (byte-compile-preprocess (cons 'progn body))))))) (eval-and-compile . (lambda (&rest body) - (byte-compile-eval-before-compile (cons 'progn body)) - (cons 'progn body)))) + ;; Byte compile before running it. Do it piece by + ;; piece, in case further expressions need earlier + ;; ones to be evaluated already, as is the case in + ;; eieio.el. + `(progn + ,@(mapcar (lambda (exp) + (let ((cexp + (byte-compile-top-level + (byte-compile-preprocess + exp)))) + (eval cexp) + cexp)) + body))))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when expanded by the compiler as when expanded by the interpreter.") @@ -731,9 +742,11 @@ otherwise pop it") ;; Also, this lets us notice references to free variables. (defmacro byte-compile-push-bytecodes (&rest args) - "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. -ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. -BYTES and PC are updated after evaluating all the arguments." + "Push bytes onto BVAR, and increment CVAR by the number of bytes pushed. +BVAR and CVAR are variables which are updated after evaluating +all the arguments. + +\(fn BYTE1 BYTE2 ... BYTEn BVAR CVAR)" (let ((byte-exprs (butlast args 2)) (bytes-var (car (last args 2))) (pc-var (car (last args)))) @@ -863,16 +876,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (let ((xs (pop hist-new)) old-autoloads) ;; Make sure the file was not already loaded before. - (unless (or (assoc (car xs) hist-orig) - ;; Don't give both the "noruntime" and - ;; "cl-functions" warning for the same function. - ;; FIXME This seems incorrect - these are two - ;; independent warnings. For example, you may be - ;; choosing to see the cl warnings but ignore them. - ;; You probably don't want to ignore noruntime in the - ;; same way. - (and (byte-compile-warning-enabled-p 'cl-functions) - (byte-compile-cl-file-p (car xs)))) + (unless (assoc (car xs) hist-orig) (dolist (s xs) (cond ((and (consp s) (eq t (car s))) @@ -1106,8 +1110,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defun byte-compile-log-warning (string &optional fill level) (let ((warning-prefix-function 'byte-compile-warning-prefix) (warning-type-format "") - (warning-fill-prefix (if fill " ")) - (inhibit-read-only t)) + (warning-fill-prefix (if fill " "))) (display-warning 'bytecomp string level byte-compile-log-buffer))) (defun byte-compile-warn (format &rest args) @@ -1792,8 +1795,6 @@ The value is non-nil if there were no errors, nil if errors." (kill-emacs-hook (cons (lambda () (ignore-errors (delete-file tempfile))) kill-emacs-hook))) - (if (memq system-type '(ms-dos 'windows-nt)) - (setq buffer-file-type t)) (write-region (point-min) (point-max) tempfile nil 1) ;; This has the intentional side effect that any ;; hard-links to target-file continue to @@ -2201,7 +2202,10 @@ list that represents a doc string reference. (when (and (consp (nth 1 form)) (eq (car (nth 1 form)) 'quote) (consp (cdr (nth 1 form))) - (symbolp (nth 1 (nth 1 form)))) + (symbolp (nth 1 (nth 1 form))) + ;; Don't add it if it's already defined. Otherwise, it might + ;; hide the actual definition. + (not (fboundp (nth 1 (nth 1 form))))) (push (cons (nth 1 (nth 1 form)) (cons 'autoload (cdr (cdr form)))) byte-compile-function-environment) @@ -2506,8 +2510,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (symbolp form) (unless (memq (car-safe fun) '(closure lambda)) (error "Don't know how to compile %S" fun)) - (setq fun (byte-compile--reify-function fun)) - (setq lexical-binding (eq (car fun) 'closure))) + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun))) (unless (eq (car-safe fun) 'lambda) (error "Don't know how to compile %S" fun)) ;; Expand macros. @@ -2820,7 +2824,8 @@ for symbols generated by the byte compiler itself." (setq body (nreverse body)) (setq body (list (if (and (eq tmp 'funcall) - (eq (car-safe (car body)) 'quote)) + (eq (car-safe (car body)) 'quote) + (symbolp (nth 1 (car body)))) (cons (nth 1 (car body)) (cdr body)) (cons tmp body)))) (or (eq output-type 'file) @@ -3701,10 +3706,10 @@ If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs), that suppresses all warnings during execution of BODY." (declare (indent 1) (debug t)) `(let* ((fbound-list (byte-compile-find-bound-condition - ,condition (list 'fboundp) + ,condition '(fboundp functionp) byte-compile-unresolved-functions)) (bound-list (byte-compile-find-bound-condition - ,condition (list 'boundp 'default-boundp))) + ,condition '(boundp default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables (append bound-list byte-compile-bound-variables))) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index b90df7092ea..34892bf2fef 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -51,7 +51,8 @@ TYPE is a Common Lisp type specifier. ((eq type 'string) (if (stringp x) x (concat x))) ((eq type 'array) (if (arrayp x) x (vconcat x))) ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) - ((and (eq type 'character) (symbolp x)) (cl-coerce (symbol-name x) type)) + ((and (eq type 'character) (symbolp x)) + (cl-coerce (symbol-name x) type)) ((eq type 'float) (float x)) ((cl-typep x type) x) (t (error "Can't coerce %s to type %s" x type)))) @@ -69,7 +70,7 @@ strings case-insensitively." ((stringp x) (and (stringp y) (= (length x) (length y)) (or (string-equal x y) - (string-equal (downcase x) (downcase y))))) ; lazy but simple! + (string-equal (downcase x) (downcase y))))) ;Lazy but simple! ((numberp x) (and (numberp y) (= x y))) ((consp x) @@ -439,14 +440,14 @@ Optional second arg STATE is a random-state object." If STATE is t, return a new state object seeded from the time of day." (cond ((null state) (cl-make-random-state cl--random-state)) ((vectorp state) (copy-tree state t)) - ((integerp state) (vector 'cl-random-state-tag -1 30 state)) - (t (cl-make-random-state (cl-random-time))))) + ((integerp state) (vector 'cl--random-state-tag -1 30 state)) + (t (cl-make-random-state (cl--random-time))))) ;;;###autoload (defun cl-random-state-p (object) "Return t if OBJECT is a random-state object." (and (vectorp object) (= (length object) 4) - (eq (aref object 0) 'cl-random-state-tag))) + (eq (aref object 0) 'cl--random-state-tag))) ;; Implementation limits. diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 226e9607b40..2de8260c941 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -93,8 +93,8 @@ (require 'macroexp) -(defvar cl-optimize-speed 1) -(defvar cl-optimize-safety 1) +(defvar cl--optimize-speed 1) +(defvar cl--optimize-safety 1) ;;;###autoload (define-obsolete-variable-alias @@ -242,33 +242,31 @@ one value. (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) " *Compiler Output*")))) -(defvar cl-proclaims-deferred nil) +(defvar cl--proclaims-deferred nil) (defun cl-proclaim (spec) "Record a global declaration specified by SPEC." - (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) - (push spec cl-proclaims-deferred)) + (if (fboundp 'cl--do-proclaim) (cl--do-proclaim spec t) + (push spec cl--proclaims-deferred)) nil) (defmacro cl-declaim (&rest specs) "Like `cl-proclaim', but takes any number of unevaluated, unquoted arguments. Puts `(cl-eval-when (compile load eval) ...)' around the declarations so that they are registered at compile-time as well as run-time." - (let ((body (mapcar (function (lambda (x) - (list 'cl-proclaim (list 'quote x)))) - specs))) - (if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body) - (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when + (let ((body (mapcar (lambda (x) `(cl-proclaim ',x)) specs))) + (if (cl--compiling-file) `(cl-eval-when (compile load eval) ,@body) + `(progn ,@body)))) ; Avoid loading cl-macs.el for cl-eval-when. ;;; Symbols. -(defun cl-random-time () +(defun cl--random-time () (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) v)) -(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100)) +(defvar cl--gensym-counter (* (logand (cl--random-time) 1023) 100)) ;;; Numbers. @@ -295,7 +293,8 @@ always returns nil." "Return t if INTEGER is even." (eq (logand integer 1) 0)) -(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time))) +(defvar cl--random-state + (vector 'cl--random-state-tag -1 30 (cl--random-time))) (defconst cl-most-positive-float nil "The largest value that a Lisp float can hold. diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 4198c0e0063..734975f7f11 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -11,7 +11,7 @@ ;;;;;; cl--map-overlays cl--map-intervals cl--map-keymap-recursively ;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan ;;;;;; cl-mapl cl-mapc cl-maplist cl-map cl--mapcar-many cl-equalp -;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "6c7926a10c377679687a2ab6a4d1c186") +;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "c5730f2a706cb1efc5fec0a790d3ca72") ;;; Generated autoloads from cl-extra.el (autoload 'cl-coerce "cl-extra" "\ @@ -224,7 +224,7 @@ Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \(fn SYMBOL PROPNAME &optional DEFAULT)" nil nil) -(put 'cl-get 'compiler-macro #'cl--compiler-macro-get) +(eval-and-compile (put 'cl-get 'compiler-macro #'cl--compiler-macro-get)) (autoload 'cl-getf "cl-extra" "\ Search PROPLIST for property PROPNAME; return its value or DEFAULT. @@ -262,12 +262,12 @@ including `cl-block' and `cl-eval-when'. ;;;;;; cl-rotatef cl-shiftf cl-remf cl-psetf cl-declare cl-the cl-locally ;;;;;; cl-multiple-value-setq cl-multiple-value-bind cl-symbol-macrolet ;;;;;; cl-macrolet cl-labels cl-flet* cl-flet cl-progv cl-psetq -;;;;;; cl-do-all-symbols cl-do-symbols cl-dotimes cl-dolist cl-do* -;;;;;; cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase +;;;;;; cl-do-all-symbols cl-do-symbols cl-tagbody cl-dotimes cl-dolist +;;;;;; cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase ;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when ;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp ;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) -;;;;;; "cl-macs" "cl-macs.el" "ad8afd35d8d75f5f22e7547b02bac556") +;;;;;; "cl-macs" "cl-macs.el" "3b4d4e869f81f0b07ab3aa08f5478c2e") ;;; Generated autoloads from cl-macs.el (autoload 'cl--compiler-macro-list* "cl-macs" "\ @@ -465,6 +465,19 @@ nil. (put 'cl-dotimes 'lisp-indent-function '1) +(autoload 'cl-tagbody "cl-macs" "\ +Execute statements while providing for control transfers to labels. +Each element of LABELS-OR-STMTS can be either a label (integer or symbol) +or a `cons' cell, in which case it's taken to be a statement. +This distinction is made before performing macroexpansion. +Statements are executed in sequence left to right, discarding any return value, +stopping only when reaching the end of LABELS-OR-STMTS. +Any statement can transfer control at any time to the statements that follow +one of the labels with the special form (go LABEL). +Labels have lexical scope and dynamic extent. + +\(fn &rest LABELS-OR-STMTS)" nil t) + (autoload 'cl-do-symbols "cl-macs" "\ Loop over all symbols. Evaluate BODY with VAR bound to each interned symbol, or to each symbol @@ -759,7 +772,7 @@ surrounded by (cl-block NAME ...). ;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if ;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not ;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove -;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "5ce2761d9a21845a7f6a2da0e4543844") +;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "51a70dea9cbc225165a50135956609aa") ;;; Generated autoloads from cl-seq.el (autoload 'cl-reduce "cl-seq" "\ @@ -1020,7 +1033,7 @@ Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(put 'cl-member 'compiler-macro #'cl--compiler-macro-member) +(eval-and-compile (put 'cl-member 'compiler-macro #'cl--compiler-macro-member)) (autoload 'cl-member-if "cl-seq" "\ Find the first item satisfying PREDICATE in LIST. @@ -1050,7 +1063,7 @@ Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(put 'cl-assoc 'compiler-macro #'cl--compiler-macro-assoc) +(eval-and-compile (put 'cl-assoc 'compiler-macro #'cl--compiler-macro-assoc)) (autoload 'cl-assoc-if "cl-seq" "\ Find the first item whose car satisfies PREDICATE in LIST. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index ab474ebb0db..b63086d7a5f 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -48,13 +48,13 @@ ;; `gv' is required here because cl-macs can be loaded before loaddefs.el. (require 'gv) -(defmacro cl-pop2 (place) +(defmacro cl--pop2 (place) (declare (debug edebug-sexps)) `(prog1 (car (cdr ,place)) (setq ,place (cdr (cdr ,place))))) -(defvar cl-optimize-safety) -(defvar cl-optimize-speed) +(defvar cl--optimize-safety) +(defvar cl--optimize-speed) ;;; Initialization. @@ -265,9 +265,11 @@ FORM is of the form (ARGS . BODY)." (require 'help-fns) (cons (help-add-fundoc-usage (if (stringp (car hdr)) (pop hdr)) - (format "%S" - (cons 'fn - (cl--make-usage-args orig-args)))) + ;; Be careful with make-symbol and (back)quote, + ;; see bug#12884. + (let ((print-gensym nil) (print-quoted t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args))))) hdr))) (list `(let* ,cl--bind-lets ,@(nreverse cl--bind-forms) @@ -429,7 +431,7 @@ its argument list allows full Common Lisp conventions." (if (memq '&environment args) (error "&environment used incorrectly")) (let ((save-args args) (restarg (memq '&rest args)) - (safety (if (cl--compiling-file) cl-optimize-safety 3)) + (safety (if (cl--compiling-file) cl--optimize-safety 3)) (keys nil) (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) @@ -438,7 +440,7 @@ its argument list allows full Common Lisp conventions." (setq restarg (cadr restarg))) (push (list restarg expr) cl--bind-lets) (if (eq (car args) '&whole) - (push (list (cl-pop2 args) restarg) cl--bind-lets)) + (push (list (cl--pop2 args) restarg) cl--bind-lets)) (let ((p args)) (setq minarg restarg) (while (and p (not (memq (car p) cl--lambda-list-keywords))) @@ -474,7 +476,7 @@ its argument list allows full Common Lisp conventions." (if def `(if ,restarg ,poparg ,def) poparg)) (setq num (1+ num)))))) (if (eq (car args) '&rest) - (let ((arg (cl-pop2 args))) + (let ((arg (cl--pop2 args))) (if (consp arg) (cl--do-arglist arg restarg))) (or (eq (car args) '&key) (= safety 0) exactarg (push `(if ,restarg @@ -572,7 +574,7 @@ its argument list allows full Common Lisp conventions." ;;; The `cl-eval-when' form. -(defvar cl-not-toplevel nil) +(defvar cl--not-toplevel nil) ;;;###autoload (defmacro cl-eval-when (when &rest body) @@ -584,9 +586,9 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body))) (if (and (fboundp 'cl--compiling-file) (cl--compiling-file) - (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge + (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge. (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) - (cl-not-toplevel t)) + (cl--not-toplevel t)) (if (or (memq 'load when) (memq :load-toplevel when)) (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) `(if nil nil ,@body)) @@ -757,7 +759,8 @@ This is compatible with Common Lisp, but note that `defun' and (defvar cl--loop-first-flag) (defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name) (defvar cl--loop-result) (defvar cl--loop-result-explicit) -(defvar cl--loop-result-var) (defvar cl--loop-steps) (defvar cl--loop-symbol-macs) +(defvar cl--loop-result-var) (defvar cl--loop-steps) +(defvar cl--loop-symbol-macs) ;;;###autoload (defmacro cl-loop (&rest loop-args) @@ -790,7 +793,8 @@ Valid clauses are: "return"] form] ;; Simple default, which covers 99% of the cases. symbolp form))) - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list loop-args)))))) + (if (not (memq t (mapcar #'symbolp + (delq nil (delq t (cl-copy-list loop-args)))))) `(cl-block nil (while t ,@loop-args)) (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil) (cl--loop-body nil) (cl--loop-steps nil) @@ -801,14 +805,16 @@ Valid clauses are: (cl--loop-map-form nil) (cl--loop-first-flag nil) (cl--loop-destr-temps nil) (cl--loop-symbol-macs nil)) (setq cl--loop-args (append cl--loop-args '(cl-end-loop))) - (while (not (eq (car cl--loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) + (while (not (eq (car cl--loop-args) 'cl-end-loop)) + (cl--parse-loop-clause)) (if cl--loop-finish-flag (push `((,cl--loop-finish-flag t)) cl--loop-bindings)) (if cl--loop-first-flag (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings) (push `(setq ,cl--loop-first-flag nil) cl--loop-steps))) (let* ((epilogue (nconc (nreverse cl--loop-finally) - (list (or cl--loop-result-explicit cl--loop-result)))) + (list (or cl--loop-result-explicit + cl--loop-result)))) (ands (cl--loop-build-ands (nreverse cl--loop-body))) (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) (body (append @@ -828,7 +834,8 @@ Valid clauses are: `((if ,cl--loop-finish-flag (progn ,@epilogue) ,cl--loop-result-var))) epilogue)))) - (if cl--loop-result-var (push (list cl--loop-result-var) cl--loop-bindings)) + (if cl--loop-result-var + (push (list cl--loop-result-var) cl--loop-bindings)) (while cl--loop-bindings (if (cdar cl--loop-bindings) (setq body (list (cl--loop-let (pop cl--loop-bindings) body t))) @@ -838,7 +845,8 @@ Valid clauses are: (push (car (pop cl--loop-bindings)) lets)) (setq body (list (cl--loop-let lets body nil)))))) (if cl--loop-symbol-macs - (setq body (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) + (setq body + (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) `(cl-block ,cl--loop-name ,@body))))) ;; Below is a complete spec for cl-loop, in several parts that correspond @@ -993,7 +1001,7 @@ Valid clauses are: -(defun cl-parse-loop-clause () ; uses loop-* +(defun cl--parse-loop-clause () ; uses loop-* (let ((word (pop cl--loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs @@ -1008,17 +1016,21 @@ Valid clauses are: ((eq word 'initially) (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) - (or (consp (car cl--loop-args)) (error "Syntax error on `initially' clause")) + (or (consp (car cl--loop-args)) + (error "Syntax error on `initially' clause")) (while (consp (car cl--loop-args)) (push (pop cl--loop-args) cl--loop-initially))) ((eq word 'finally) (if (eq (car cl--loop-args) 'return) - (setq cl--loop-result-explicit (or (cl-pop2 cl--loop-args) '(quote nil))) + (setq cl--loop-result-explicit + (or (cl--pop2 cl--loop-args) '(quote nil))) (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) - (or (consp (car cl--loop-args)) (error "Syntax error on `finally' clause")) + (or (consp (car cl--loop-args)) + (error "Syntax error on `finally' clause")) (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) - (setq cl--loop-result-explicit (or (nth 1 (pop cl--loop-args)) '(quote nil))) + (setq cl--loop-result-explicit + (or (nth 1 (pop cl--loop-args)) '(quote nil))) (while (consp (car cl--loop-args)) (push (pop cl--loop-args) cl--loop-finally))))) @@ -1034,7 +1046,8 @@ Valid clauses are: (if (eq word 'being) (setq word (pop cl--loop-args))) (if (memq word '(the each)) (setq word (pop cl--loop-args))) (if (memq word '(buffer buffers)) - (setq word 'in cl--loop-args (cons '(buffer-list) cl--loop-args))) + (setq word 'in + cl--loop-args (cons '(buffer-list) cl--loop-args))) (cond ((memq word '(from downfrom upfrom to downto upto @@ -1043,15 +1056,19 @@ Valid clauses are: (if (memq (car cl--loop-args) '(downto above)) (error "Must specify `from' value for downward cl-loop")) (let* ((down (or (eq (car cl--loop-args) 'downfrom) - (memq (cl-caddr cl--loop-args) '(downto above)))) + (memq (cl-caddr cl--loop-args) + '(downto above)))) (excl (or (memq (car cl--loop-args) '(above below)) - (memq (cl-caddr cl--loop-args) '(above below)))) - (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) - (cl-pop2 cl--loop-args))) + (memq (cl-caddr cl--loop-args) + '(above below)))) + (start (and (memq (car cl--loop-args) + '(from upfrom downfrom)) + (cl--pop2 cl--loop-args))) (end (and (memq (car cl--loop-args) '(to upto downto above below)) - (cl-pop2 cl--loop-args))) - (step (and (eq (car cl--loop-args) 'by) (cl-pop2 cl--loop-args))) + (cl--pop2 cl--loop-args))) + (step (and (eq (car cl--loop-args) 'by) + (cl--pop2 cl--loop-args))) (end-var (and (not (macroexp-const-p end)) (make-symbol "--cl-var--"))) (step-var (and (not (macroexp-const-p step)) @@ -1085,7 +1102,7 @@ Valid clauses are: loop-for-sets)))) (push (list temp (if (eq (car cl--loop-args) 'by) - (let ((step (cl-pop2 cl--loop-args))) + (let ((step (cl--pop2 cl--loop-args))) (if (and (memq (car-safe step) '(quote function cl-function)) @@ -1097,7 +1114,8 @@ Valid clauses are: ((eq word '=) (let* ((start (pop cl--loop-args)) - (then (if (eq (car cl--loop-args) 'then) (cl-pop2 cl--loop-args) start))) + (then (if (eq (car cl--loop-args) 'then) + (cl--pop2 cl--loop-args) start))) (push (list var nil) loop-for-bindings) (if (or ands (eq (car cl--loop-args) 'and)) (progn @@ -1134,14 +1152,15 @@ Valid clauses are: (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) (and (not (memq (car cl--loop-args) '(in of))) (error "Expected `of'")))) - (seq (cl-pop2 cl--loop-args)) + (seq (cl--pop2 cl--loop-args)) (temp-seq (make-symbol "--cl-seq--")) - (temp-idx (if (eq (car cl--loop-args) 'using) - (if (and (= (length (cadr cl--loop-args)) 2) - (eq (cl-caadr cl--loop-args) 'index)) - (cadr (cl-pop2 cl--loop-args)) - (error "Bad `using' clause")) - (make-symbol "--cl-idx--")))) + (temp-idx + (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (eq (cl-caadr cl--loop-args) 'index)) + (cadr (cl--pop2 cl--loop-args)) + (error "Bad `using' clause")) + (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) (push (list temp-idx 0) loop-for-bindings) (if ref @@ -1164,15 +1183,17 @@ Valid clauses are: loop-for-steps))) ((memq word hash-types) - (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 cl--loop-args)) - (other (if (eq (car cl--loop-args) 'using) - (if (and (= (length (cadr cl--loop-args)) 2) - (memq (cl-caadr cl--loop-args) hash-types) - (not (eq (cl-caadr cl--loop-args) word))) - (cadr (cl-pop2 cl--loop-args)) - (error "Bad `using' clause")) - (make-symbol "--cl-var--")))) + (or (memq (car cl--loop-args) '(in of)) + (error "Expected `of'")) + (let* ((table (cl--pop2 cl--loop-args)) + (other + (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) hash-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl--pop2 cl--loop-args)) + (error "Bad `using' clause")) + (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) (setq var (prog1 other (setq other var)))) (setq cl--loop-map-form @@ -1180,16 +1201,19 @@ Valid clauses are: ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) - (let ((ob (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args)))) + (let ((ob (and (memq (car cl--loop-args) '(in of)) + (cl--pop2 cl--loop-args)))) (setq cl--loop-map-form `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) (while (memq (car cl--loop-args) '(in of from to)) - (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) - (t (setq buf (cl-pop2 cl--loop-args))))) + (cond ((eq (car cl--loop-args) 'from) + (setq from (cl--pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) + (setq to (cl--pop2 cl--loop-args))) + (t (setq buf (cl--pop2 cl--loop-args))))) (setq cl--loop-map-form `(cl--map-overlays (lambda (,var ,(make-symbol "--cl-var--")) @@ -1201,11 +1225,13 @@ Valid clauses are: (var1 (make-symbol "--cl-var1--")) (var2 (make-symbol "--cl-var2--"))) (while (memq (car cl--loop-args) '(in of property from to)) - (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) + (cond ((eq (car cl--loop-args) 'from) + (setq from (cl--pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) + (setq to (cl--pop2 cl--loop-args))) ((eq (car cl--loop-args) 'property) - (setq prop (cl-pop2 cl--loop-args))) - (t (setq buf (cl-pop2 cl--loop-args))))) + (setq prop (cl--pop2 cl--loop-args))) + (t (setq buf (cl--pop2 cl--loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) (push (list var `(cons ,var1 ,var2)) loop-for-sets)) @@ -1215,15 +1241,17 @@ Valid clauses are: ,buf ,prop ,from ,to)))) ((memq word key-types) - (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) - (let ((cl-map (cl-pop2 cl--loop-args)) - (other (if (eq (car cl--loop-args) 'using) - (if (and (= (length (cadr cl--loop-args)) 2) - (memq (cl-caadr cl--loop-args) key-types) - (not (eq (cl-caadr cl--loop-args) word))) - (cadr (cl-pop2 cl--loop-args)) - (error "Bad `using' clause")) - (make-symbol "--cl-var--")))) + (or (memq (car cl--loop-args) '(in of)) + (error "Expected `of'")) + (let ((cl-map (cl--pop2 cl--loop-args)) + (other + (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) key-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl--pop2 cl--loop-args)) + (error "Bad `using' clause")) + (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) (setq var (prog1 other (setq other var)))) (setq cl--loop-map-form @@ -1243,7 +1271,8 @@ Valid clauses are: loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args))) + (let ((scr (and (memq (car cl--loop-args) '(in of)) + (cl--pop2 cl--loop-args))) (temp (make-symbol "--cl-var--")) (minip (make-symbol "--cl-minip--"))) (push (list var (if scr @@ -1338,7 +1367,8 @@ Valid clauses are: ((memq word '(minimize minimizing maximize maximizing)) (let* ((what (pop cl--loop-args)) - (temp (if (cl--simple-expr-p what) what (make-symbol "--cl-var--"))) + (temp (if (cl--simple-expr-p what) what + (make-symbol "--cl-var--"))) (var (cl--loop-handle-accum nil)) (func (intern (substring (symbol-name word) 0 3))) (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) @@ -1349,7 +1379,8 @@ Valid clauses are: ((eq word 'with) (let ((bindings nil)) (while (progn (push (list (pop cl--loop-args) - (and (eq (car cl--loop-args) '=) (cl-pop2 cl--loop-args))) + (and (eq (car cl--loop-args) '=) + (cl--pop2 cl--loop-args))) bindings) (eq (car cl--loop-args) 'and)) (pop cl--loop-args)) @@ -1362,19 +1393,23 @@ Valid clauses are: (push `(not ,(pop cl--loop-args)) cl--loop-body)) ((eq word 'always) - (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body) (setq cl--loop-result t)) ((eq word 'never) - (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) cl--loop-body) (setq cl--loop-result t)) ((eq word 'thereis) - (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) - (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl--loop-result-var + (setq cl--loop-result-var (make-symbol "--cl-var--"))) (push `(setq ,cl--loop-finish-flag (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) cl--loop-body)) @@ -1382,11 +1417,11 @@ Valid clauses are: ((memq word '(if when unless)) (let* ((cond (pop cl--loop-args)) (then (let ((cl--loop-body nil)) - (cl-parse-loop-clause) + (cl--parse-loop-clause) (cl--loop-build-ands (nreverse cl--loop-body)))) (else (let ((cl--loop-body nil)) (if (eq (car cl--loop-args) 'else) - (progn (pop cl--loop-args) (cl-parse-loop-clause))) + (progn (pop cl--loop-args) (cl--parse-loop-clause))) (cl--loop-build-ands (nreverse cl--loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) (if (eq (car cl--loop-args) 'end) (pop cl--loop-args)) @@ -1408,8 +1443,10 @@ Valid clauses are: (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) ((eq word 'return) - (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) - (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (or cl--loop-finish-flag + (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) + (or cl--loop-result-var + (setq cl--loop-result-var (make-symbol "--cl-var--"))) (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) ,cl--loop-finish-flag nil) cl--loop-body)) @@ -1419,7 +1456,7 @@ Valid clauses are: (or handler (error "Expected a cl-loop keyword, found %s" word)) (funcall handler)))) (if (eq (car cl--loop-args) 'and) - (progn (pop cl--loop-args) (cl-parse-loop-clause))))) + (progn (pop cl--loop-args) (cl--parse-loop-clause))))) (defun cl--loop-let (specs body par) ; uses loop-* (let ((p specs) (temps nil) (new nil)) @@ -1438,10 +1475,12 @@ Valid clauses are: (if (and (consp (car specs)) (listp (caar specs))) (let* ((spec (caar specs)) (nspecs nil) (expr (cadr (pop specs))) - (temp (cdr (or (assq spec cl--loop-destr-temps) - (car (push (cons spec (or (last spec 0) - (make-symbol "--cl-var--"))) - cl--loop-destr-temps)))))) + (temp + (cdr (or (assq spec cl--loop-destr-temps) + (car (push (cons spec + (or (last spec 0) + (make-symbol "--cl-var--"))) + cl--loop-destr-temps)))))) (push (list temp expr) new) (while (consp spec) (push (list (pop spec) @@ -1450,24 +1489,27 @@ Valid clauses are: (setq specs (nconc (nreverse nspecs) specs))) (push (pop specs) new))) (if (eq body 'setq) - (let ((set (cons (if par 'cl-psetq 'setq) (apply 'nconc (nreverse new))))) + (let ((set (cons (if par 'cl-psetq 'setq) + (apply 'nconc (nreverse new))))) (if temps `(let* ,(nreverse temps) ,set) set)) `(,(if par 'let 'let*) ,(nconc (nreverse temps) (nreverse new)) ,@body)))) -(defun cl--loop-handle-accum (def &optional func) ; uses loop-* +(defun cl--loop-handle-accum (def &optional func) ; uses loop-* (if (eq (car cl--loop-args) 'into) - (let ((var (cl-pop2 cl--loop-args))) + (let ((var (cl--pop2 cl--loop-args))) (or (memq var cl--loop-accum-vars) (progn (push (list (list var def)) cl--loop-bindings) (push var cl--loop-accum-vars))) var) (or cl--loop-accum-var (progn - (push (list (list (setq cl--loop-accum-var (make-symbol "--cl-var--")) def)) - cl--loop-bindings) + (push (list (list + (setq cl--loop-accum-var (make-symbol "--cl-var--")) + def)) + cl--loop-bindings) (setq cl--loop-result (if func (list func cl--loop-accum-var) - cl--loop-accum-var)) + cl--loop-accum-var)) cl--loop-accum-var)))) (defun cl--loop-build-ands (clauses) @@ -1514,7 +1556,7 @@ such that COMBO is equivalent to (and . CLAUSES)." ((&rest &or symbolp (symbolp &optional form form)) (form body) cl-declarations body))) - (cl-expand-do-loop steps endtest body nil)) + (cl--expand-do-loop steps endtest body nil)) ;;;###autoload (defmacro cl-do* (steps endtest &rest body) @@ -1522,9 +1564,9 @@ such that COMBO is equivalent to (and . CLAUSES)." \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" (declare (indent 2) (debug cl-do)) - (cl-expand-do-loop steps endtest body t)) + (cl--expand-do-loop steps endtest body t)) -(defun cl-expand-do-loop (steps endtest body star) +(defun cl--expand-do-loop (steps endtest body star) `(cl-block nil (,(if star 'let* 'let) ,(mapcar (lambda (c) (if (consp c) (list (car c) (nth 1 c)) c)) @@ -1552,9 +1594,9 @@ An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" (declare (debug ((symbolp form &optional form) cl-declarations body)) (indent 1)) - `(cl-block nil - (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist) - ,spec ,@body))) + (let ((loop `(dolist ,spec ,@body))) + (if (advice-member-p #'cl--wrap-in-nil-block 'dolist) + loop `(cl-block nil ,loop)))) ;;;###autoload (defmacro cl-dotimes (spec &rest body) @@ -1565,9 +1607,55 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (debug cl-dolist) (indent 1)) - `(cl-block nil - (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes) - ,spec ,@body))) + (let ((loop `(dotimes ,spec ,@body))) + (if (advice-member-p #'cl--wrap-in-nil-block 'dotimes) + loop `(cl-block nil ,loop)))) + +(defvar cl--tagbody-alist nil) + +;;;###autoload +(defmacro cl-tagbody (&rest labels-or-stmts) + "Execute statements while providing for control transfers to labels. +Each element of LABELS-OR-STMTS can be either a label (integer or symbol) +or a `cons' cell, in which case it's taken to be a statement. +This distinction is made before performing macroexpansion. +Statements are executed in sequence left to right, discarding any return value, +stopping only when reaching the end of LABELS-OR-STMTS. +Any statement can transfer control at any time to the statements that follow +one of the labels with the special form (go LABEL). +Labels have lexical scope and dynamic extent." + (let ((blocks '()) + (first-label (if (consp (car labels-or-stmts)) + 'cl--preamble (pop labels-or-stmts)))) + (let ((block (list first-label))) + (dolist (label-or-stmt labels-or-stmts) + (if (consp label-or-stmt) (push label-or-stmt block) + ;; Add a "go to next block" to implement the fallthrough. + (unless (eq 'go (car-safe (car-safe block))) + (push `(go ,label-or-stmt) block)) + (push (nreverse block) blocks) + (setq block (list label-or-stmt)))) + (unless (eq 'go (car-safe (car-safe block))) + (push `(go cl--exit) block)) + (push (nreverse block) blocks)) + (let ((catch-tag (make-symbol "cl--tagbody-tag"))) + (push (cons 'cl--exit catch-tag) cl--tagbody-alist) + (dolist (block blocks) + (push (cons (car block) catch-tag) cl--tagbody-alist)) + (macroexpand-all + `(let ((next-label ',first-label)) + (while + (not (eq (setq next-label + (catch ',catch-tag + (cl-case next-label + ,@blocks))) + 'cl--exit)))) + `((go . ,(lambda (label) + (let ((catch-tag (cdr (assq label cl--tagbody-alist)))) + (unless catch-tag + (error "Unknown cl-tagbody go label `%S'" label)) + `(throw ',catch-tag ',label)))) + ,@macroexpand-all-environment))))) ;;;###autoload (defmacro cl-do-symbols (spec &rest body) @@ -1618,19 +1706,18 @@ second list (or to nil if VALUES is shorter than SYMBOLS); then the BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time." (declare (indent 2) (debug (form form body))) - (let ((bodyfun (make-symbol "cl--progv-body")) + (let ((bodyfun (make-symbol "body")) (binds (make-symbol "binds")) (syms (make-symbol "syms")) (vals (make-symbol "vals"))) `(progn - (defvar ,bodyfun) (let* ((,syms ,symbols) (,vals ,values) (,bodyfun (lambda () ,@body)) (,binds ())) (while ,syms (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) - (eval (list 'let ,binds '(funcall ,bodyfun))))))) + (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun)))))))) (defvar cl--labels-convert-cache nil) @@ -1901,11 +1988,11 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (declare (indent 1) (debug (cl-type-spec form))) form) -(defvar cl-proclaim-history t) ; for future compilers -(defvar cl-declare-stack t) ; for future compilers +(defvar cl--proclaim-history t) ; for future compilers +(defvar cl--declare-stack t) ; for future compilers -(defun cl-do-proclaim (spec hist) - (and hist (listp cl-proclaim-history) (push spec cl-proclaim-history)) +(defun cl--do-proclaim (spec hist) + (and hist (listp cl--proclaim-history) (push spec cl--proclaim-history)) (cond ((eq (car-safe spec) 'special) (if (boundp 'byte-compile-bound-variables) (setq byte-compile-bound-variables @@ -1930,9 +2017,9 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). '((0 nil) (1 t) (2 t) (3 t)))) (safety (assq (nth 1 (assq 'safety (cdr spec))) '((0 t) (1 t) (2 t) (3 nil))))) - (if speed (setq cl-optimize-speed (car speed) + (if speed (setq cl--optimize-speed (car speed) byte-optimize (nth 1 speed))) - (if safety (setq cl-optimize-safety (car safety) + (if safety (setq cl--optimize-safety (car safety) byte-compile-delete-errors (nth 1 safety))))) ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) @@ -1944,10 +2031,10 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). nil) ;;; Process any proclamations made before cl-macs was loaded. -(defvar cl-proclaims-deferred) -(let ((p (reverse cl-proclaims-deferred))) - (while p (cl-do-proclaim (pop p) t)) - (setq cl-proclaims-deferred nil)) +(defvar cl--proclaims-deferred) +(let ((p (reverse cl--proclaims-deferred))) + (while p (cl--do-proclaim (pop p) t)) + (setq cl--proclaims-deferred nil)) ;;;###autoload (defmacro cl-declare (&rest specs) @@ -1960,8 +2047,8 @@ will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." (if (cl--compiling-file) (while specs - (if (listp cl-declare-stack) (push (car specs) cl-declare-stack)) - (cl-do-proclaim (pop specs) nil))) + (if (listp cl--declare-stack) (push (car specs) cl--declare-stack)) + (cl--do-proclaim (pop specs) nil))) nil) ;;; The standard modify macros. @@ -2207,7 +2294,7 @@ value, that slot cannot be set via `setf'. (copier (intern (format "copy-%s" name))) (predicate (intern (format "%s-p" name))) (print-func nil) (print-auto nil) - (safety (if (cl--compiling-file) cl-optimize-safety 3)) + (safety (if (cl--compiling-file) cl--optimize-safety 3)) (include nil) (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) @@ -2452,7 +2539,8 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (if (consp (cadr type)) `(> ,val ,(cl-caadr type)) `(>= ,val ,(cadr type)))) ,(if (memq (cl-caddr type) '(* nil)) t - (if (consp (cl-caddr type)) `(< ,val ,(cl-caaddr type)) + (if (consp (cl-caddr type)) + `(< ,val ,(cl-caaddr type)) `(<= ,val ,(cl-caddr type))))))) ((memq (car type) '(and or not)) (cons (car type) @@ -2477,7 +2565,7 @@ TYPE is a Common Lisp-style type specifier." STRING is an optional description of the desired type." (declare (debug (place cl-type-spec &optional stringp))) (and (or (not (cl--compiling-file)) - (< cl-optimize-speed 3) (= cl-optimize-safety 3)) + (< cl--optimize-speed 3) (= cl--optimize-safety 3)) (let* ((temp (if (cl--simple-expr-p form 3) form (make-symbol "--cl-var--"))) (body `(or ,(cl--make-type-test temp type) @@ -2497,7 +2585,7 @@ They are not evaluated unless the assertion fails. If STRING is omitted, a default message listing FORM itself is used." (declare (debug (form &rest form))) (and (or (not (cl--compiling-file)) - (< cl-optimize-speed 3) (= cl-optimize-safety 3)) + (< cl--optimize-speed 3) (= cl--optimize-safety 3)) (let ((sargs (and show-args (delq nil (mapcar (lambda (x) (unless (macroexp-const-p x) @@ -2693,14 +2781,14 @@ surrounded by (cl-block NAME ...). ;;; Things that are side-effect-free. (mapc (lambda (x) (put x 'side-effect-free t)) - '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd cl-lcm - cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq - cl-list-length cl-get cl-getf)) + '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd + cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem + cl-subseq cl-list-length cl-get cl-getf)) ;;; Things that are side-effect-and-error-free. (mapc (lambda (x) (put x 'side-effect-free 'error-free)) - '(eql cl-floatp-safe cl-list* cl-subst cl-acons cl-equalp cl-random-state-p - copy-tree cl-sublis)) + '(eql cl-floatp-safe cl-list* cl-subst cl-acons cl-equalp + cl-random-state-p copy-tree cl-sublis)) (run-hooks 'cl-macs-load-hook) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index c0c2db0d9ae..fbf68f62b4a 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -105,6 +105,9 @@ (eq (not (funcall cl-test ,x ,y)) cl-test-not) (eql ,x ,y))) +;; Yuck! These vars are set/bound by cl--parsing-keywords to match :if :test +;; and :key keyword args, and they are also accessed (sometimes) via dynamic +;; scoping (and some of those accesses are from macro-expanded code). (defvar cl-test) (defvar cl-test-not) (defvar cl-if) (defvar cl-if-not) (defvar cl-key) @@ -333,7 +336,8 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (defun cl--delete-duplicates (cl-seq cl-keys cl-copy) (if (listp cl-seq) - (cl--parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) + (cl--parsing-keywords + (:test :test-not :key (:start 0) :end :from-end :if) () (if cl-from-end (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) @@ -776,7 +780,8 @@ to avoid corrupting the original LIST1 and LIST2. (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) (while cl-list2 (if (or cl-keys (numberp (car cl-list2))) - (setq cl-list1 (apply 'cl-adjoin (car cl-list2) cl-list1 cl-keys)) + (setq cl-list1 + (apply 'cl-adjoin (car cl-list2) cl-list1 cl-keys)) (or (memq (car cl-list2) cl-list1) (push (car cl-list2) cl-list1))) (pop cl-list2)) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 0ad7d4b1592..ea4d9511f9d 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -113,14 +113,6 @@ )) (defvaralias var (intern (format "cl-%s" var)))) -;; Before overwriting subr.el's `dotimes' and `dolist', let's remember -;; them under a different name, so we can use them in our implementation -;; of `dotimes' and `dolist'. -(unless (fboundp 'cl--dotimes) - (defalias 'cl--dotimes (symbol-function 'dotimes) "The non-CL `dotimes'.")) -(unless (fboundp 'cl--dolist) - (defalias 'cl--dolist (symbol-function 'dolist) "The non-CL `dolist'.")) - (dolist (fun '( (get* . cl-get) (random* . cl-random) @@ -228,13 +220,12 @@ callf2 callf letf* - ;; letf + letf rotatef shiftf remf psetf (define-setf-method . define-setf-expander) - declare the locally multiple-value-setq @@ -245,8 +236,6 @@ psetq do-all-symbols do-symbols - dotimes - dolist do* do loop @@ -328,6 +317,15 @@ (intern (format "cl-%s" fun))))) (defalias fun new))) +(defun cl--wrap-in-nil-block (fun &rest args) + `(cl-block nil ,(apply fun args))) +(advice-add 'dolist :around #'cl--wrap-in-nil-block) +(advice-add 'dotimes :around #'cl--wrap-in-nil-block) + +(defun cl--pass-args-to-cl-declare (&rest specs) + (macroexpand `(cl-declare ,@specs))) +(advice-add 'declare :after #'cl--pass-args-to-cl-declare) + ;;; Features provided a bit differently in Elisp. ;; First, the old lexical-let is now better served by `lexical-binding', tho @@ -506,28 +504,6 @@ rather than relying on `lexical-binding'." ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we ;; still need to support old users of cl.el. -(defmacro cl--symbol-function (symbol) - "Like `symbol-function' but return `cl--unbound' if not bound." - ;; (declare (gv-setter (lambda (store) - ;; `(if (eq ,store 'cl--unbound) - ;; (fmakunbound ,symbol) (fset ,symbol ,store))))) - `(if (fboundp ,symbol) (symbol-function ,symbol) 'cl--unbound)) -(gv-define-setter cl--symbol-function (store symbol) - `(if (eq ,store 'cl--unbound) (fmakunbound ,symbol) (fset ,symbol ,store))) - -(defmacro letf (bindings &rest body) - "Dynamically scoped let-style bindings for places. -For more details, see `cl-letf'. This macro behaves like that one -in almost every respect (apart from details that relate to some -deprecated usage of `symbol-function' in place forms)." ; bug#12760 - (declare (indent 1) (debug cl-letf)) - ;; Like cl-letf, but with special handling of symbol-function. - `(cl-letf ,(mapcar (lambda (x) (if (eq (car-safe (car x)) 'symbol-function) - `((cl--symbol-function ,@(cdar x)) ,@(cdr x)) - x)) - bindings) - ,@body)) - (defun cl--gv-adapt (cl-gv do) ;; This function is used by all .elc files that use define-setf-expander and ;; were compiled with Emacs>=24.3. diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 5607c9b0698..f88cb0ef9bb 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -30,12 +30,12 @@ ;; a single prompt, optionally using completion. ;; Multiple strings are specified by separating each of the strings -;; with a prespecified separator character. For example, if the -;; separator character is a comma, the strings 'alice', 'bob', and +;; with a prespecified separator regexp. For example, if the +;; separator regexp is ",", the strings 'alice', 'bob', and ;; 'eve' would be specified as 'alice,bob,eve'. -;; The default value for the separator character is the value of -;; `crm-default-separator' (comma). The separator character may be +;; The default value for the separator regexp is the value of +;; `crm-default-separator' (comma). The separator regexp may be ;; changed by modifying the value of `crm-separator'. ;; Contiguous strings of non-separator-characters are referred to as @@ -96,14 +96,14 @@ ;; first revamped version ;;; Code: -(defconst crm-default-separator "," - "Default separator for `completing-read-multiple'.") +(defconst crm-default-separator "[ \t]*,[ \t]*" + "Default separator regexp for `completing-read-multiple'.") (defvar crm-separator crm-default-separator - "Separator used for separating strings in `completing-read-multiple'. -It should be a single character string that doesn't appear in the list of -completion candidates. Modify this value to make `completing-read-multiple' -use a separator other than `crm-default-separator'.") + "Separator regexp used for separating strings in `completing-read-multiple'. +It should be a regexp that does not match the list of completion candidates. +Modify this value to make `completing-read-multiple' use a separator other +than `crm-default-separator'.") (defvar crm-local-completion-map (let ((map (make-sparse-keymap))) @@ -173,13 +173,17 @@ Place an overlay on the element, with a `field' property, and return it." (overlay-put ol 'field (make-symbol "crm")) ol)) +(defmacro crm--completion-command (command) + "Make COMMAND a completion command for `completing-read-multiple'." + `(let ((ol (crm--select-current-element))) + (unwind-protect + ,command + (delete-overlay ol)))) + (defun crm-completion-help () "Display a list of possible completions of the current minibuffer element." (interactive) - (let ((ol (crm--select-current-element))) - (unwind-protect - (minibuffer-completion-help) - (delete-overlay ol))) + (crm--completion-command (minibuffer-completion-help)) nil) (defun crm-complete () @@ -188,19 +192,13 @@ If no characters can be completed, display a list of possible completions. Return t if the current element is now a valid match; otherwise return nil." (interactive) - (let ((ol (crm--select-current-element))) - (unwind-protect - (minibuffer-complete) - (delete-overlay ol)))) + (crm--completion-command (minibuffer-complete))) (defun crm-complete-word () "Complete the current element at most a single word. Like `minibuffer-complete-word' but for `completing-read-multiple'." (interactive) - (let ((ol (crm--select-current-element))) - (unwind-protect - (minibuffer-complete-word) - (delete-overlay ol)))) + (crm--completion-command (minibuffer-complete-word))) (defun crm-complete-and-exit () "If all of the minibuffer elements are valid completions then exit. @@ -222,9 +220,10 @@ This function is modeled after `minibuffer-complete-and-exit'." (setq doexit nil)) (goto-char (overlay-end ol)) (delete-overlay ol)) - (not (eobp)))) + (not (eobp))) + (looking-at crm-separator)) ;; Skip to the next element. - (forward-char 1)) + (goto-char (match-end 0))) (if doexit (exit-minibuffer)))) (defun crm--choose-completion-string (choice buffer base-position @@ -248,12 +247,12 @@ By using this functionality, a user may specify multiple strings at a single prompt, optionally using completion. Multiple strings are specified by separating each of the strings with -a prespecified separator character. For example, if the separator -character is a comma, the strings 'alice', 'bob', and 'eve' would be +a prespecified separator regexp. For example, if the separator +regexp is \",\", the strings 'alice', 'bob', and 'eve' would be specified as 'alice,bob,eve'. -The default value for the separator character is the value of -`crm-default-separator' (comma). The separator character may be +The default value for the separator regexp is the value of +`crm-default-separator' (comma). The separator regexp may be changed by modifying the value of `crm-separator'. Contiguous strings of non-separator-characters are referred to as @@ -282,8 +281,8 @@ INHERIT-INPUT-METHOD." (map (if require-match crm-local-must-match-map crm-local-completion-map)) - ;; If the user enters empty input, read-from-minibuffer returns - ;; the empty string, not DEF. + ;; If the user enters empty input, `read-from-minibuffer' + ;; returns the empty string, not DEF. (input (read-from-minibuffer prompt initial-input map nil hist def inherit-input-method))) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 472706d886b..0728e86d072 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -1,4 +1,4 @@ -;;; debug.el --- debuggers and related commands for Emacs +;;; debug.el --- debuggers and related commands for Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1985-1986, 1994, 2001-2013 Free Software Foundation, ;; Inc. @@ -82,9 +82,6 @@ The value used here is passed to `quit-restore-window'." :group 'debugger :version "24.3") -(defvar debug-function-list nil - "List of functions currently set for debug on entry.") - (defvar debugger-step-after-exit nil "Non-nil means \"single-step\" after the debugger exits.") @@ -147,7 +144,7 @@ where CAUSE can be: ;;;###autoload (setq debugger 'debug) ;;;###autoload -(defun debug (&rest debugger-args) +(defun debug (&rest args) "Enter debugger. \\<debugger-mode-map>`\\[debugger-continue]' returns from the debugger. Arguments are mainly for use when this is called from the internals of the evaluator. @@ -166,6 +163,7 @@ first will be printed into the backtrace buffer." (if (get-buffer "*Backtrace*") (with-current-buffer (get-buffer "*Backtrace*") (list major-mode (buffer-string))))) + (debugger-args args) (debugger-buffer (get-buffer-create "*Backtrace*")) (debugger-old-buffer (current-buffer)) (debugger-window nil) @@ -220,11 +218,11 @@ first will be printed into the backtrace buffer." (save-excursion (when (eq (car debugger-args) 'debug) ;; Skip the frames for backtrace-debug, byte-code, - ;; and implement-debug-on-entry. - (backtrace-debug 3 t) + ;; debug--implement-debug-on-entry and the advice's `apply'. + (backtrace-debug 4 t) ;; Place an extra debug-on-exit for macro's. - (when (eq 'lambda (car-safe (cadr (backtrace-frame 3)))) - (backtrace-debug 4 t))) + (when (eq 'lambda (car-safe (cadr (backtrace-frame 4)))) + (backtrace-debug 5 t))) (pop-to-buffer debugger-buffer `((display-buffer-reuse-window @@ -319,7 +317,7 @@ first will be printed into the backtrace buffer." (setq debug-on-next-call debugger-step-after-exit) debugger-value))) -(defun debugger-setup-buffer (debugger-args) +(defun debugger-setup-buffer (args) "Initialize the `*Backtrace*' buffer for entry to the debugger. That buffer should be current already." (setq buffer-read-only nil) @@ -335,20 +333,22 @@ That buffer should be current already." (delete-region (point) (progn (search-forward "\n debug(") - (forward-line (if (eq (car debugger-args) 'debug) - 2 ; Remove implement-debug-on-entry frame. + (forward-line (if (eq (car args) 'debug) + ;; Remove debug--implement-debug-on-entry + ;; and the advice's `apply' frame. + 3 1)) (point))) (insert "Debugger entered") ;; lambda is for debug-on-call when a function call is next. ;; debug is for debug-on-entry function called. - (pcase (car debugger-args) + (pcase (car args) ((or `lambda `debug) (insert "--entering a function:\n")) ;; Exiting a function. (`exit (insert "--returning value: ") - (setq debugger-value (nth 1 debugger-args)) + (setq debugger-value (nth 1 args)) (prin1 debugger-value (current-buffer)) (insert ?\n) (delete-char 1) @@ -357,7 +357,7 @@ That buffer should be current already." ;; Debugger entered for an error. (`error (insert "--Lisp error: ") - (prin1 (nth 1 debugger-args) (current-buffer)) + (prin1 (nth 1 args) (current-buffer)) (insert ?\n)) ;; debug-on-call, when the next thing is an eval. (`t @@ -365,8 +365,8 @@ That buffer should be current already." ;; User calls debug directly. (_ (insert ": ") - (prin1 (if (eq (car debugger-args) 'nil) - (cdr debugger-args) debugger-args) + (prin1 (if (eq (car args) 'nil) + (cdr args) args) (current-buffer)) (insert ?\n))) ;; After any frame that uses eval-buffer, @@ -526,9 +526,10 @@ removes itself from that hook." (count 0)) (while (not (eq (cadr (backtrace-frame count)) 'debug)) (setq count (1+ count))) - ;; Skip implement-debug-on-entry frame. - (when (eq 'implement-debug-on-entry (cadr (backtrace-frame (1+ count)))) - (setq count (1+ count))) + ;; Skip debug--implement-debug-on-entry frame. + (when (eq 'debug--implement-debug-on-entry + (cadr (backtrace-frame (1+ count)))) + (setq count (+ 2 count))) (goto-char (point-min)) (when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):") (goto-char (match-end 0)) @@ -695,10 +696,10 @@ Applies to the frame whose line point is on in the backtrace." :help "Continue to exit from this frame, with all debug-on-entry suspended")) (define-key menu-map [deb-cont] '(menu-item "Continue" debugger-continue - :help "Continue, evaluating this expression without stopping")) + :help "Continue, evaluating this expression without stopping")) (define-key menu-map [deb-step] '(menu-item "Step through" debugger-step-through - :help "Proceed, stepping through subexpressions of this expression")) + :help "Proceed, stepping through subexpressions of this expression")) map)) (put 'debugger-mode 'mode-class 'special) @@ -778,7 +779,7 @@ For the cross-reference format, see `help-make-xrefs'." ;; When you change this, you may also need to change the number of ;; frames that the debugger skips. -(defun implement-debug-on-entry () +(defun debug--implement-debug-on-entry (&rest _ignore) "Conditionally call the debugger. A call to this function is inserted by `debug-on-entry' to cause functions to break on entry." @@ -786,12 +787,6 @@ functions to break on entry." nil (funcall debugger 'debug))) -(defun debugger-special-form-p (symbol) - "Return whether SYMBOL is a special form." - (and (fboundp symbol) - (subrp (symbol-function symbol)) - (eq (cdr (subr-arity (symbol-function symbol))) 'unevalled))) - ;;;###autoload (defun debug-on-entry (function) "Request FUNCTION to invoke debugger each time it is called. @@ -809,7 +804,7 @@ Use \\[cancel-debug-on-entry] to cancel the effect of this command. Redefining FUNCTION also cancels it." (interactive (let ((fn (function-called-at-point)) val) - (when (debugger-special-form-p fn) + (when (special-form-p fn) (setq fn nil)) (setq val (completing-read (if fn @@ -818,36 +813,21 @@ Redefining FUNCTION also cancels it." obarray #'(lambda (symbol) (and (fboundp symbol) - (not (debugger-special-form-p symbol)))) + (not (special-form-p symbol)))) t nil nil (symbol-name fn))) (list (if (equal val "") fn (intern val))))) - ;; FIXME: Use advice.el. - (when (debugger-special-form-p function) - (error "Function %s is a special form" function)) - (if (or (symbolp (symbol-function function)) - (subrp (symbol-function function))) - ;; The function is built-in or aliased to another function. - ;; Create a wrapper in which we can add the debug call. - (fset function `(lambda (&rest debug-on-entry-args) - ,(interactive-form (symbol-function function)) - (apply ',(symbol-function function) - debug-on-entry-args))) - (when (autoloadp (symbol-function function)) - ;; The function is autoloaded. Load its real definition. - (autoload-do-load (symbol-function function) function)) - (when (or (not (consp (symbol-function function))) - (and (eq (car (symbol-function function)) 'macro) - (not (consp (cdr (symbol-function function)))))) - ;; The function is byte-compiled. Create a wrapper in which - ;; we can add the debug call. - (debug-convert-byte-code function))) - (unless (consp (symbol-function function)) - (error "Definition of %s is not a list" function)) - (fset function (debug-on-entry-1 function t)) - (unless (memq function debug-function-list) - (push function debug-function-list)) + (advice-add function :before #'debug--implement-debug-on-entry) function) +(defun debug--function-list () + "List of functions currently set for debug on entry." + (let ((funs '())) + (mapatoms + (lambda (s) + (when (advice-member-p #'debug--implement-debug-on-entry s) + (push s funs)))) + funs)) + ;;;###autoload (defun cancel-debug-on-entry (&optional function) "Undo effect of \\[debug-on-entry] on FUNCTION. @@ -858,80 +838,16 @@ To specify a nil argument interactively, exit with an empty minibuffer." (list (let ((name (completing-read "Cancel debug on entry to function (default all functions): " - (mapcar 'symbol-name debug-function-list) nil t))) + (mapcar #'symbol-name (debug--function-list)) nil t))) (when name (unless (string= name "") (intern name)))))) - (if (and function - (not (string= function ""))) ; Pre 22.1 compatibility test. + (if function (progn - (let ((defn (debug-on-entry-1 function nil))) - (condition-case nil - (when (and (equal (nth 1 defn) '(&rest debug-on-entry-args)) - (eq (car (nth 3 defn)) 'apply)) - ;; `defn' is a wrapper introduced in debug-on-entry. - ;; Get rid of it since we don't need it any more. - (setq defn (nth 1 (nth 1 (nth 3 defn))))) - (error nil)) - (fset function defn)) - (setq debug-function-list (delq function debug-function-list)) + (advice-remove function #'debug--implement-debug-on-entry) function) (message "Cancelling debug-on-entry for all functions") - (mapcar 'cancel-debug-on-entry debug-function-list))) - -(defun debug-arglist (definition) - ;; FIXME: copied from ad-arglist. - "Return the argument list of DEFINITION." - (require 'help-fns) - (help-function-arglist definition 'preserve-names)) - -(defun debug-convert-byte-code (function) - (let* ((defn (symbol-function function)) - (macro (eq (car-safe defn) 'macro))) - (when macro (setq defn (cdr defn))) - (when (byte-code-function-p defn) - (let* ((args (debug-arglist defn)) - (body - `((,(if (memq '&rest args) #'apply #'funcall) - ,defn - ,@(remq '&rest (remq '&optional args)))))) - (if (> (length defn) 5) - ;; The mere presence of field 5 is sufficient to make - ;; it interactive. - (push `(interactive ,(aref defn 5)) body)) - (if (and (> (length defn) 4) (aref defn 4)) - ;; Use `documentation' here, to get the actual string, - ;; in case the compiled function has a reference - ;; to the .elc file. - (setq body (cons (documentation function) body))) - (setq defn `(closure (t) ,args ,@body))) - (when macro (setq defn (cons 'macro defn))) - (fset function defn)))) - -(defun debug-on-entry-1 (function flag) - (let* ((defn (symbol-function function)) - (tail defn)) - (when (eq (car-safe tail) 'macro) - (setq tail (cdr tail))) - (if (not (memq (car-safe tail) '(closure lambda))) - ;; Only signal an error when we try to set debug-on-entry. - ;; When we try to clear debug-on-entry, we are now done. - (when flag - (error "%s is not a user-defined Lisp function" function)) - (if (eq (car tail) 'closure) (setq tail (cdr tail))) - (setq tail (cdr tail)) - ;; Skip the docstring. - (when (and (stringp (cadr tail)) (cddr tail)) - (setq tail (cdr tail))) - ;; Skip the interactive form. - (when (eq 'interactive (car-safe (cadr tail))) - (setq tail (cdr tail))) - (unless (eq flag (equal (cadr tail) '(implement-debug-on-entry))) - ;; Add/remove debug statement as needed. - (setcdr tail (if flag - (cons '(implement-debug-on-entry) (cdr tail)) - (cddr tail))))) - defn)) + (mapcar #'cancel-debug-on-entry (debug--function-list)))) (defun debugger-list-functions () "Display a list of all the functions now set to debug on entry." @@ -941,17 +857,18 @@ To specify a nil argument interactively, exit with an empty minibuffer." (called-interactively-p 'interactive)) (with-output-to-temp-buffer (help-buffer) (with-current-buffer standard-output - (if (null debug-function-list) - (princ "No debug-on-entry functions now\n") - (princ "Functions set to debug on entry:\n\n") - (dolist (fun debug-function-list) - (make-text-button (point) (progn (prin1 fun) (point)) - 'type 'help-function - 'help-args (list fun)) - (terpri)) - (terpri) - (princ "Note: if you have redefined a function, then it may no longer\n") - (princ "be set to debug on entry, even if it is in the list."))))) + (let ((funs (debug--function-list))) + (if (null funs) + (princ "No debug-on-entry functions now\n") + (princ "Functions set to debug on entry:\n\n") + (dolist (fun funs) + (make-text-button (point) (progn (prin1 fun) (point)) + 'type 'help-function + 'help-args (list fun)) + (terpri)) + (terpri) + (princ "Note: if you have redefined a function, then it may no longer\n") + (princ "be set to debug on entry, even if it is in the list.")))))) (provide 'debug) diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index a5876ee0bda..684f9d90878 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -296,16 +296,32 @@ is not very useful." ;; Use a default docstring. (setq docstring (if (null parent) - (format "Major-mode. -Uses keymap `%s', abbrev table `%s' and syntax-table `%s'." map abbrev syntax) + ;; FIXME filling. + (format "Major-mode.\nUses keymap `%s'%s%s." map + (if abbrev (format "%s abbrev table `%s'" + (if syntax "," " and") abbrev) "") + (if syntax (format " and syntax-table `%s'" syntax) "")) (format "Major mode derived from `%s' by `define-derived-mode'. -It inherits all of the parent's attributes, but has its own keymap, -abbrev table and syntax table: - - `%s', `%s' and `%s' - -which more-or-less shadow %s's corresponding tables." - parent map abbrev syntax parent)))) +It inherits all of the parent's attributes, but has its own keymap%s: + + `%s'%s + +which more-or-less shadow%s %s's corresponding table%s." + parent + (cond ((and abbrev syntax) + ",\nabbrev table and syntax table") + (abbrev "\nand abbrev table") + (syntax "\nand syntax table") + (t "")) + map + (cond ((and abbrev syntax) + (format ", `%s' and `%s'" abbrev syntax)) + ((or abbrev syntax) + (format " and `%s'" (or abbrev syntax))) + (t "")) + (if (or abbrev syntax) "" "s") + parent + (if (or abbrev syntax) "s" ""))))) (unless (string-match (regexp-quote (symbol-name hook)) docstring) ;; Make sure the docstring mentions the mode's hook. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 166c093f37b..2088e690228 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -341,9 +341,14 @@ If MODE's set-up depends on the major mode in effect when it was enabled, then disabling and reenabling MODE should make MODE work correctly with the current major mode. This is important to prevent problems with derived modes, that is, major modes that -call another major mode in their body." +call another major mode in their body. + +When a major mode is initialized, MODE is actually turned on just +after running the major mode's hook. However, MODE is not turned +on if the hook has explicitly disabled it." (declare (doc-string 2)) (let* ((global-mode-name (symbol-name global-mode)) + (mode-name (symbol-name mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) (group nil) @@ -354,6 +359,10 @@ call another major mode in their body." (MODE-check-buffers (intern (concat global-mode-name "-check-buffers"))) (MODE-cmhh (intern (concat global-mode-name "-cmhh"))) + (MODE-disable-in-buffer + (intern (concat global-mode-name "-disable-in-buffer"))) + (minor-MODE-hook (intern (concat mode-name "-hook"))) + (disable-MODE (intern (concat "disable-" mode-name))) (MODE-major-mode (intern (concat (symbol-name mode) "-major-mode"))) keyw) @@ -397,8 +406,6 @@ See `%s' for more information on %s." (progn (add-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) - (add-hook 'change-major-mode-after-body-hook - ',MODE-enable-in-buffers) (add-hook 'find-file-hook ',MODE-check-buffers) (add-hook 'change-major-mode-hook ',MODE-cmhh)) (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) @@ -416,6 +423,10 @@ See `%s' for more information on %s." ;; up-to-here. :autoload-end + ;; A function which checks whether MODE has been disabled in the major + ;; mode hook which has just been run. + (add-hook ',minor-MODE-hook ',MODE-disable-in-buffer) + ;; List of buffers left to process. (defvar ,MODE-buffers nil) @@ -424,14 +435,15 @@ See `%s' for more information on %s." (dolist (buf ,MODE-buffers) (when (buffer-live-p buf) (with-current-buffer buf - (unless (eq ,MODE-major-mode major-mode) - (if ,mode - (progn - (,mode -1) - (,turn-on) - (setq ,MODE-major-mode major-mode)) - (,turn-on) - (setq ,MODE-major-mode major-mode))))))) + (if ,disable-MODE + (if ,mode (,mode -1)) + (unless (eq ,MODE-major-mode major-mode) + (if ,mode + (progn + (,mode -1) + (,turn-on)) + (,turn-on)))) + (setq ,MODE-major-mode major-mode))))) (put ',MODE-enable-in-buffers 'definition-name ',global-mode) (defun ,MODE-check-buffers () @@ -444,7 +456,14 @@ See `%s' for more information on %s." (defun ,MODE-cmhh () (add-to-list ',MODE-buffers (current-buffer)) (add-hook 'post-command-hook ',MODE-check-buffers)) - (put ',MODE-cmhh 'definition-name ',global-mode)))) + (put ',MODE-cmhh 'definition-name ',global-mode) + ;; disable-MODE is set in MODE-disable-in-buffer and cleared by + ;; kill-all-local-variables. + (defvar-local ,disable-MODE nil) + (defun ,MODE-disable-in-buffer () + (unless ,mode + (setq ,disable-MODE t))) + (put ',MODE-disable-in-buffer 'definition-name ',global-mode)))) ;;; ;;; easy-mmode-defmap diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index e3888db2a57..52e12013fd3 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -461,8 +461,8 @@ STREAM or the value of `standard-input' may be: This version, from Edebug, maybe instruments the expression. But the STREAM must be the current buffer to do so. Whether it instruments is -also dependent on the values of `edebug-all-defs' and -`edebug-all-forms'." +also dependent on the values of the option `edebug-all-defs' and +the option `edebug-all-forms'." (or stream (setq stream standard-input)) (if (eq stream (current-buffer)) (edebug-read-and-maybe-wrap-form) @@ -484,8 +484,8 @@ similarly. Reinitialize the face according to `defface' specification. With a prefix argument, instrument the code for Edebug. -Setting `edebug-all-defs' to a non-nil value reverses the meaning of -the prefix argument. Code is then instrumented when this function is +Setting option `edebug-all-defs' to a non-nil value reverses the meaning +of the prefix argument. Code is then instrumented when this function is invoked without a prefix argument If acting on a `defun' for FUNCTION, and the function was instrumented, @@ -4259,22 +4259,53 @@ With prefix argument, make it a temporary breakpoint." ;;; Autoloading of Edebug accessories ;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu +(defun edebug--require-cl-read () + (require 'edebug-cl-read)) + (if (featurep 'cl-read) - (add-hook 'edebug-setup-hook - (function (lambda () (require 'edebug-cl-read)))) + (add-hook 'edebug-setup-hook #'edebug--require-cl-read) ;; The following causes edebug-cl-read to be loaded when you load cl-read.el. - (add-hook 'cl-read-load-hooks - (function (lambda () (require 'edebug-cl-read))))) + (add-hook 'cl-read-load-hooks #'edebug--require-cl-read)) ;;; Finalize Loading +;; When edebugging a function, some of the sub-expressions are +;; wrapped in (edebug-enter (lambda () ..)), so we need to teach +;; called-interactively-p that calls within the inner lambda should refer to +;; the outside function. +(add-hook 'called-interactively-p-functions + #'edebug--called-interactively-skip) +(defun edebug--called-interactively-skip (i frame1 frame2) + (when (and (eq (car-safe (nth 1 frame1)) 'lambda) + (eq (nth 1 (nth 1 frame1)) '()) + (eq (nth 1 frame2) 'edebug-enter)) + ;; `edebug-enter' calls itself on its first invocation. + (if (eq (nth 1 (internal--called-interactively-p--get-frame i)) + 'edebug-enter) + 2 1))) + ;; Finally, hook edebug into the rest of Emacs. ;; There are probably some other things that could go here. ;; Install edebug read and eval functions. (edebug-install-read-eval-functions) +(defun edebug-unload-function () + "Unload the Edebug source level debugger." + (when edebug-active + (setq edebug-active nil) + (unwind-protect + (abort-recursive-edit) + ;; We still want to run unload-feature to completion + (run-with-idle-timer 0 nil #'(lambda () (unload-feature 'edebug))))) + (remove-hook 'called-interactively-p-functions + 'edebug--called-interactively-skip) + (remove-hook 'cl-read-load-hooks 'edebug--require-cl-read) + (edebug-uninstall-read-eval-functions) + ;; continue standard unloading + nil) + (provide 'edebug) ;;; edebug.el ends here diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index f112de13253..626bc0f6dc6 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -2850,28 +2850,36 @@ this object." (v (eieio-oref this (car publa))) ) (unless (or (not i) (equal v (car publd))) + (unless (bolp) + (princ "\n")) (princ (make-string (* eieio-print-depth 2) ? )) (princ (symbol-name i)) - (princ " ") (if (car publp) ;; Use our public printer - (funcall (car publp) v) + (progn + (princ " ") + (funcall (car publp) v)) ;; Use our generic override prin1 function. - (eieio-override-prin1 v)) - (princ "\n")))) + (princ (if (or (eieio-object-p v) + (eieio-object-p (car-safe v))) + "\n" " ")) + (eieio-override-prin1 v))))) (setq publa (cdr publa) publd (cdr publd) - publp (cdr publp))) - (princ (make-string (* eieio-print-depth 2) ? ))) - (princ ")\n"))) + publp (cdr publp)))) + (princ ")") + (when (= eieio-print-depth 0) + (princ "\n")))) (defun eieio-override-prin1 (thing) "Perform a `prin1' on THING taking advantage of object knowledge." (cond ((eieio-object-p thing) (object-write thing)) - ((listp thing) + ((consp thing) (eieio-list-prin1 thing)) ((class-p thing) (princ (class-name thing))) + ((or (keywordp thing) (booleanp thing)) + (prin1 thing)) ((symbolp thing) (princ (concat "'" (symbol-name thing)))) (t (prin1 thing)))) @@ -2882,16 +2890,16 @@ this object." (progn (princ "'") (prin1 list)) - (princ "(list ") - (if (eieio-object-p (car list)) (princ "\n ")) - (while list - (if (eieio-object-p (car list)) - (object-write (car list)) - (princ "'") - (prin1 (car list))) - (princ " ") - (setq list (cdr list))) (princ (make-string (* eieio-print-depth 2) ? )) + (princ "(list") + (let ((eieio-print-depth (1+ eieio-print-depth))) + (while list + (princ "\n") + (if (eieio-object-p (car list)) + (object-write (car list)) + (princ (make-string (* eieio-print-depth 2) ? )) + (eieio-override-prin1 (car list))) + (setq list (cdr list)))) (princ ")"))) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index bc02d9a7551..f1321eb4e6d 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -1,4 +1,4 @@ -;;; elp.el --- Emacs Lisp Profiler +;;; elp.el --- Emacs Lisp Profiler -*- lexical-binding: t -*- ;; Copyright (C) 1994-1995, 1997-1998, 2001-2013 Free Software ;; Foundation, Inc. @@ -124,6 +124,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) ;; start of user configuration variables ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv @@ -148,9 +149,9 @@ Results are displayed with the `elp-results' command." "Non-nil specifies ELP results sorting function. These functions are currently available: - elp-sort-by-call-count -- sort by the highest call count - elp-sort-by-total-time -- sort by the highest total time - elp-sort-by-average-time -- sort by the highest average times + `elp-sort-by-call-count' -- sort by the highest call count + `elp-sort-by-total-time' -- sort by the highest total time + `elp-sort-by-average-time' -- sort by the highest average times You can write your own sort function. It should adhere to the interface specified by the PREDICATE argument for `sort'. @@ -167,7 +168,7 @@ If a number, no function that has been called fewer than that number of times will be displayed in the output buffer. If nil, all functions will be displayed." :type '(choice integer - (const :tag "Show All" nil)) + (const :tag "Show All" nil)) :group 'elp) (defcustom elp-use-standard-output nil @@ -193,9 +194,6 @@ In other words, a new unique buffer is create every time you run (defconst elp-timer-info-property 'elp-info "ELP information property name.") -(defvar elp-all-instrumented-list nil - "List of all functions currently being instrumented.") - (defvar elp-record-p t "Controls whether functions should record times or not. This variable is set by the master function.") @@ -205,7 +203,7 @@ This variable is set by the master function.") (defvar elp-not-profilable ;; First, the functions used inside each instrumented function: - '(elp-wrapper called-interactively-p + '(called-interactively-p ;; Then the functions used by the above functions. I used ;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x)) ;; (aref (symbol-function 'elp-wrapper) 2))) @@ -223,60 +221,21 @@ them would thus lead to infinite recursion.") (fboundp fun) (not (or (memq fun elp-not-profilable) (keymapp fun) - (memq (car-safe (symbol-function fun)) '(autoload macro)) - (condition-case nil - (when (subrp (indirect-function fun)) - (eq 'unevalled - (cdr (subr-arity (indirect-function fun))))) - (error nil)))))) + (autoloadp (symbol-function fun)) ;FIXME: Why not just load it? + (special-form-p fun))))) +(defconst elp--advice-name 'ELP-instrumentation\ ) ;;;###autoload (defun elp-instrument-function (funsym) "Instrument FUNSYM for profiling. FUNSYM must be a symbol of a defined function." (interactive "aFunction to instrument: ") - ;; restore the function. this is necessary to avoid infinite - ;; recursion of already instrumented functions (i.e. elp-wrapper - ;; calling elp-wrapper ad infinitum). it is better to simply - ;; restore the function than to throw an error. this will work - ;; properly in the face of eval-defun because if the function was - ;; redefined, only the timer info will be nil'd out since - ;; elp-restore-function is smart enough not to trash the new - ;; definition. - (elp-restore-function funsym) - (let* ((funguts (symbol-function funsym)) - (infovec (vector 0 0 funguts)) - (newguts '(lambda (&rest args)))) - ;; we cannot profile macros - (and (eq (car-safe funguts) 'macro) - (error "ELP cannot profile macro: %s" funsym)) - ;; TBD: at some point it might be better to load the autoloaded - ;; function instead of throwing an error. if we do this, then we - ;; probably want elp-instrument-package to be updated with the - ;; newly loaded list of functions. i'm not sure it's smart to do - ;; the autoload here, since that could have side effects, and - ;; elp-instrument-function is similar (in my mind) to defun-ish - ;; type functionality (i.e. it shouldn't execute the function). - (and (autoloadp funguts) - (error "ELP cannot profile autoloaded function: %s" funsym)) + (let* ((infovec (vector 0 0))) ;; We cannot profile functions used internally during profiling. (unless (elp-profilable-p funsym) (error "ELP cannot profile the function: %s" funsym)) - ;; put rest of newguts together - (if (commandp funsym) - (setq newguts (append newguts '((interactive))))) - (setq newguts (append newguts `((elp-wrapper - (quote ,funsym) - ,(when (commandp funsym) - '(called-interactively-p 'any)) - args)))) - ;; to record profiling times, we set the symbol's function - ;; definition so that it runs the elp-wrapper function with the - ;; function symbol as an argument. We place the old function - ;; definition on the info vector. - ;; - ;; The info vector data structure is a 3 element vector. The 0th + ;; The info vector data structure is a 2 element vector. The 0th ;; element is the call-count, i.e. the total number of times this ;; function has been entered. This value is bumped up on entry to ;; the function so that non-local exists are still recorded. TBD: @@ -285,72 +244,45 @@ FUNSYM must be a symbol of a defined function." ;; The 1st element is the total amount of time in seconds that has ;; been spent inside this function. This number is added to on ;; function exit. - ;; - ;; The 2nd element is the old function definition list. This gets - ;; funcall'd in between start/end time retrievals. I believe that - ;; this lets us profile even byte-compiled functions. - ;; put the info vector on the property list + ;; Put the info vector on the property list. (put funsym elp-timer-info-property infovec) ;; Set the symbol's new profiling function definition to run - ;; elp-wrapper. - (let ((advice-info (get funsym 'ad-advice-info))) - (if advice-info - (progn - ;; If function is advised, don't let Advice change - ;; its definition from under us during the `fset'. - (put funsym 'ad-advice-info nil) - (fset funsym newguts) - (put funsym 'ad-advice-info advice-info)) - (fset funsym newguts))) - - ;; add this function to the instrumentation list - (unless (memq funsym elp-all-instrumented-list) - (push funsym elp-all-instrumented-list)))) + ;; ELP wrapper. + (advice-add funsym :around (elp--make-wrapper funsym) + `((name . ,elp--advice-name))))) + +(defun elp--instrumented-p (sym) + (advice-member-p elp--advice-name sym)) (defun elp-restore-function (funsym) "Restore an instrumented function to its original definition. Argument FUNSYM is the symbol of a defined function." - (interactive "aFunction to restore: ") - (let ((info (get funsym elp-timer-info-property))) - ;; delete the function from the all instrumented list - (setq elp-all-instrumented-list - (delq funsym elp-all-instrumented-list)) - - ;; if the function was the master, reset the master - (if (eq funsym elp-master) - (setq elp-master nil - elp-record-p t)) - - ;; zap the properties - (put funsym elp-timer-info-property nil) - - ;; restore the original function definition, but if the function - ;; wasn't instrumented do nothing. we do this after the above - ;; because its possible the function got un-instrumented due to - ;; circumstances beyond our control. Also, check to make sure - ;; that the current function symbol points to elp-wrapper. If - ;; not, then the user probably did an eval-defun, or loaded a - ;; byte-compiled version, while the function was instrumented and - ;; we don't want to destroy the new definition. can it ever be - ;; the case that a lisp function can be compiled instrumented? - (and info - (functionp funsym) - (not (byte-code-function-p (symbol-function funsym))) - (assq 'elp-wrapper (symbol-function funsym)) - (fset funsym (aref info 2))))) + (interactive + (list + (intern + (completing-read "Function to restore: " obarray + #'elp--instrumented-p t)))) + ;; If the function was the master, reset the master. + (if (eq funsym elp-master) + (setq elp-master nil + elp-record-p t)) + + ;; Zap the properties. + (put funsym elp-timer-info-property nil) + + (advice-remove funsym elp--advice-name)) ;;;###autoload (defun elp-instrument-list (&optional list) "Instrument, for profiling, all functions in `elp-function-list'. Use optional LIST if provided instead. If called interactively, read LIST using the minibuffer." - (interactive "PList of functions to instrument: ") + (interactive "PList of functions to instrument: ") ;FIXME: Doesn't work?! (unless (listp list) (signal 'wrong-type-argument (list 'listp list))) - (let ((list (or list elp-function-list))) - (mapcar 'elp-instrument-function list))) + (mapcar #'elp-instrument-function (or list elp-function-list))) ;;;###autoload (defun elp-instrument-package (prefix) @@ -371,15 +303,13 @@ For example, to instrument all ELP functions, do the following: (defun elp-restore-list (&optional list) "Restore the original definitions for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to restore: ") - (let ((list (or list elp-function-list))) - (mapcar 'elp-restore-function list))) + (interactive "PList of functions to restore: ") ;FIXME: Doesn't work!? + (mapcar #'elp-restore-function (or list elp-function-list))) (defun elp-restore-all () "Restore the original definitions of all functions being profiled." (interactive) - (elp-restore-list elp-all-instrumented-list)) - + (mapatoms #'elp-restore-function)) (defun elp-reset-function (funsym) "Reset the profiling information for FUNSYM." @@ -395,30 +325,36 @@ Use optional LIST if provided instead." (defun elp-reset-list (&optional list) "Reset the profiling information for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to reset: ") + (interactive "PList of functions to reset: ") ;FIXME: Doesn't work!? (let ((list (or list elp-function-list))) (mapcar 'elp-reset-function list))) (defun elp-reset-all () "Reset the profiling information for all functions being profiled." (interactive) - (elp-reset-list elp-all-instrumented-list)) + (mapatoms (lambda (sym) + (if (get sym elp-timer-info-property) + (elp-reset-function sym))))) (defun elp-set-master (funsym) "Set the master function for profiling." - (interactive "aMaster function: ") - ;; when there's a master function, recording is turned off by - ;; default + (interactive + (list + (intern + (completing-read "Master function: " obarray + #'elp--instrumented-p + t nil nil (if elp-master (symbol-name elp-master)))))) + ;; When there's a master function, recording is turned off by default. (setq elp-master funsym elp-record-p nil) - ;; make sure master function is instrumented - (or (memq funsym elp-all-instrumented-list) + ;; Make sure master function is instrumented. + (or (elp--instrumented-p funsym) (elp-instrument-function funsym))) (defun elp-unset-master () "Unset the master function." (interactive) - ;; when there's no master function, recording is turned on by default. + ;; When there's no master function, recording is turned on by default. (setq elp-master nil elp-record-p t)) @@ -426,49 +362,40 @@ Use optional LIST if provided instead." (defsubst elp-elapsed-time (start end) (float-time (time-subtract end start))) -(defun elp-wrapper (funsym interactive-p args) - "This function has been instrumented for profiling by the ELP. +(defun elp--make-wrapper (funsym) + "Make the piece of advice that instruments FUNSYM." + (lambda (func &rest args) + "This function has been instrumented for profiling by the ELP. ELP is the Emacs Lisp Profiler. To restore the function to its original definition, use \\[elp-restore-function] or \\[elp-restore-all]." - ;; turn on recording if this is the master function - (if (and elp-master - (eq funsym elp-master)) - (setq elp-record-p t)) - ;; get info vector and original function symbol - (let* ((info (get funsym elp-timer-info-property)) - (func (aref info 2)) - result) - (or func - (error "%s is not instrumented for profiling" funsym)) - (if (not elp-record-p) - ;; when not recording, just call the original function symbol - ;; and return the results. - (setq result - (if interactive-p - (call-interactively func) - (apply func args))) - ;; we are recording times - (let (enter-time exit-time) - ;; increment the call-counter - (aset info 0 (1+ (aref info 0))) - ;; now call the old symbol function, checking to see if it - ;; should be called interactively. make sure we return the - ;; correct value - (if interactive-p - (setq enter-time (current-time) - result (call-interactively func) - exit-time (current-time)) + ;; turn on recording if this is the master function + (if (and elp-master + (eq funsym elp-master)) + (setq elp-record-p t)) + ;; get info vector and original function symbol + (let* ((info (get funsym elp-timer-info-property)) + result) + (or func + (error "%s is not instrumented for profiling" funsym)) + (if (not elp-record-p) + ;; when not recording, just call the original function symbol + ;; and return the results. + (setq result (apply func args)) + ;; we are recording times + (let (enter-time exit-time) + ;; increment the call-counter + (cl-incf (aref info 0)) (setq enter-time (current-time) result (apply func args) - exit-time (current-time))) - ;; calculate total time in function - (aset info 1 (+ (aref info 1) (elp-elapsed-time enter-time exit-time))) - )) - ;; turn off recording if this is the master function - (if (and elp-master - (eq funsym elp-master)) - (setq elp-record-p nil)) - result)) + exit-time (current-time)) + ;; calculate total time in function + (cl-incf (aref info 1) (elp-elapsed-time enter-time exit-time)) + )) + ;; turn off recording if this is the master function + (if (and elp-master + (eq funsym elp-master)) + (setq elp-record-p nil)) + result))) ;; shut the byte-compiler up @@ -582,57 +509,58 @@ displayed." (elp-et-len (length et-header)) (at-header "Average Time") (elp-at-len (length at-header)) - (resvec - (mapcar - (function - (lambda (funsym) - (let* ((info (get funsym elp-timer-info-property)) - (symname (format "%s" funsym)) - (cc (aref info 0)) - (tt (aref info 1))) - (if (not info) - (insert "No profiling information found for: " - symname) - (setq longest (max longest (length symname))) - (vector cc tt (if (zerop cc) - 0.0 ;avoid arithmetic div-by-zero errors - (/ (float tt) (float cc))) - symname))))) - elp-all-instrumented-list)) + (resvec '()) ) ; end let* + (mapatoms + (lambda (funsym) + (when (elp--instrumented-p funsym) + (let* ((info (get funsym elp-timer-info-property)) + (symname (format "%s" funsym)) + (cc (aref info 0)) + (tt (aref info 1))) + (if (not info) + (insert "No profiling information found for: " + symname) + (setq longest (max longest (length symname))) + (push + (vector cc tt (if (zerop cc) + 0.0 ;avoid arithmetic div-by-zero errors + (/ (float tt) (float cc))) + symname) + resvec)))))) ;; If printing to stdout, insert the header so it will print. ;; Otherwise use header-line-format. (setq elp-field-len (max titlelen longest)) (if (or elp-use-standard-output noninteractive) - (progn - (insert title) - (if (> longest titlelen) - (progn - (insert-char 32 (- longest titlelen)))) - (insert " " cc-header " " et-header " " at-header "\n") - (insert-char ?= elp-field-len) - (insert " ") - (insert-char ?= elp-cc-len) - (insert " ") - (insert-char ?= elp-et-len) - (insert " ") - (insert-char ?= elp-at-len) - (insert "\n")) - (let ((column 0)) - (setq header-line-format - (mapconcat - (lambda (title) - (prog1 - (concat - (propertize " " - 'display (list 'space :align-to column) - 'face 'fixed-pitch) - title) - (setq column (+ column 2 - (if (= column 0) - elp-field-len - (length title)))))) - (list title cc-header et-header at-header) "")))) + (progn + (insert title) + (if (> longest titlelen) + (progn + (insert-char 32 (- longest titlelen)))) + (insert " " cc-header " " et-header " " at-header "\n") + (insert-char ?= elp-field-len) + (insert " ") + (insert-char ?= elp-cc-len) + (insert " ") + (insert-char ?= elp-et-len) + (insert " ") + (insert-char ?= elp-at-len) + (insert "\n")) + (let ((column 0)) + (setq header-line-format + (mapconcat + (lambda (title) + (prog1 + (concat + (propertize " " + 'display (list 'space :align-to column) + 'face 'fixed-pitch) + title) + (setq column (+ column 2 + (if (= column 0) + elp-field-len + (length title)))))) + (list title cc-header et-header at-header) "")))) ;; if sorting is enabled, then sort the results list. in either ;; case, call elp-output-result to output the result in the ;; buffer @@ -644,7 +572,7 @@ displayed." (pop-to-buffer resultsbuf) ;; copy results to standard-output? (if (or elp-use-standard-output noninteractive) - (princ (buffer-substring (point-min) (point-max))) + (princ (buffer-substring (point-min) (point-max))) (goto-char (point-min))) ;; reset profiling info if desired (and elp-reset-after-results diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 00100c0f6fb..531e83c1e6a 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -1,4 +1,4 @@ -;;; ert-x.el --- Staging area for experimental extensions to ERT +;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*- ;; Copyright (C) 2008, 2010-2013 Free Software Foundation, Inc. @@ -28,8 +28,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'ert) @@ -90,8 +89,8 @@ ERT--THUNK with that buffer as current." (kill-buffer ert--buffer) (remhash ert--buffer ert--test-buffers)))) -(defmacro* ert-with-test-buffer ((&key ((:name name-form))) - &body body) +(cl-defmacro ert-with-test-buffer ((&key ((:name name-form))) + &body body) "Create a test buffer and run BODY in that buffer. To be used in ERT tests. If BODY finishes successfully, the test @@ -116,10 +115,10 @@ the name of the test and the result of NAME-FORM." "Kill all test buffers that are still live." (interactive) (let ((count 0)) - (maphash (lambda (buffer dummy) + (maphash (lambda (buffer _dummy) (when (or (not (buffer-live-p buffer)) (kill-buffer buffer)) - (incf count))) + (cl-incf count))) ert--test-buffers) (message "%s out of %s test buffers killed" count (hash-table-count ert--test-buffers))) @@ -149,9 +148,9 @@ the rest are arguments to the command. NOTE: Since the command is not called by `call-interactively' test for `called-interactively' in the command will fail." - (assert (listp command) t) - (assert (commandp (car command)) t) - (assert (not unread-command-events) t) + (cl-assert (listp command) t) + (cl-assert (commandp (car command)) t) + (cl-assert (not unread-command-events) t) (let (return-value) ;; For the order of things here see command_loop_1 in keyboard.c. ;; @@ -175,7 +174,7 @@ test for `called-interactively' in the command will fail." (when (boundp 'last-repeatable-command) (setq last-repeatable-command real-last-command)) (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) - (assert (not unread-command-events) t) + (cl-assert (not unread-command-events) t) return-value)) (defun ert-run-idle-timers () @@ -198,7 +197,7 @@ rather than the entire match." (with-temp-buffer (insert s) (dolist (x regexps) - (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) + (cl-destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) (goto-char (point-min)) (while (re-search-forward regexp nil t) (replace-match "" t t nil subexp)))) @@ -224,15 +223,15 @@ would return the string \"foo bar baz quux\" where the substring None of the ARGS are modified, but the return value may share structure with the plists in ARGS." (with-temp-buffer - (loop with current-plist = nil - for x in args do - (etypecase x - (string (let ((begin (point))) - (insert x) - (set-text-properties begin (point) current-plist))) - (list (unless (zerop (mod (length x) 2)) - (error "Odd number of args in plist: %S" x)) - (setq current-plist x)))) + (cl-loop with current-plist = nil + for x in args do + (cl-etypecase x + (string (let ((begin (point))) + (insert x) + (set-text-properties begin (point) current-plist))) + (list (unless (zerop (mod (length x) 2)) + (error "Odd number of args in plist: %S" x)) + (setq current-plist x)))) (buffer-string))) @@ -245,8 +244,8 @@ buffer, and renames the original buffer back to BUFFER-NAME. This is useful if THUNK has undesirable side-effects on an Emacs buffer with a fixed name such as *Messages*." - (lexical-let ((new-buffer-name (generate-new-buffer-name - (format "%s orig buffer" buffer-name)))) + (let ((new-buffer-name (generate-new-buffer-name + (format "%s orig buffer" buffer-name)))) (with-current-buffer (get-buffer-create buffer-name) (rename-buffer new-buffer-name)) (unwind-protect @@ -258,7 +257,7 @@ buffer with a fixed name such as *Messages*." (with-current-buffer new-buffer-name (rename-buffer buffer-name))))) -(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body) +(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) "Protect the buffer named BUFFER-NAME from side-effects and run BODY. See `ert-call-with-buffer-renamed' for details." diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 134dbc1b6a6..7df3acccbc9 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1,4 +1,4 @@ -;;; ert.el --- Emacs Lisp Regression Testing +;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- ;; Copyright (C) 2007-2008, 2010-2013 Free Software Foundation, Inc. @@ -54,8 +54,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'button) (require 'debug) (require 'easymenu) @@ -105,33 +104,33 @@ "A reimplementation of `remove-if-not'. ERT-PRED is a predicate, ERT-LIST is the input list." - (loop for ert-x in ert-list - if (funcall ert-pred ert-x) - collect ert-x)) + (cl-loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) (defun ert--intersection (a b) "A reimplementation of `intersection'. Intersect the sets A and B. Elements are compared using `eql'." - (loop for x in a - if (memql x b) - collect x)) + (cl-loop for x in a + if (memql x b) + collect x)) (defun ert--set-difference (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eql'." - (loop for x in a - unless (memql x b) - collect x)) + (cl-loop for x in a + unless (memql x b) + collect x)) (defun ert--set-difference-eq (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eq'." - (loop for x in a - unless (memq x b) - collect x)) + (cl-loop for x in a + unless (memq x b) + collect x)) (defun ert--union (a b) "A reimplementation of `union'. Compute the union of the sets A and B. @@ -149,7 +148,7 @@ Elements are compared using `eql'." (make-symbol (format "%s%s" prefix (prog1 ert--gensym-counter - (incf ert--gensym-counter)))))) + (cl-incf ert--gensym-counter)))))) (defun ert--coerce-to-vector (x) "Coerce X to a vector." @@ -158,19 +157,19 @@ Elements are compared using `eql'." x (vconcat x))) -(defun* ert--remove* (x list &key key test) +(cl-defun ert--remove* (x list &key key test) "Does not support all the keywords of remove*." (unless key (setq key #'identity)) (unless test (setq test #'eql)) - (loop for y in list - unless (funcall test x (funcall key y)) - collect y)) + (cl-loop for y in list + unless (funcall test x (funcall key y)) + collect y)) (defun ert--string-position (c s) "Return the position of the first occurrence of C in S, or nil if none." - (loop for i from 0 - for x across s - when (eql x c) return i)) + (cl-loop for i from 0 + for x across s + when (eql x c) return i)) (defun ert--mismatch (a b) "Return index of first element that differs between A and B. @@ -184,29 +183,30 @@ Like `mismatch'. Uses `equal' for comparison." (t (let ((la (length a)) (lb (length b))) - (assert (arrayp a) t) - (assert (arrayp b) t) - (assert (<= la lb) t) - (loop for i below la - when (not (equal (aref a i) (aref b i))) return i - finally (return (if (/= la lb) - la - (assert (equal a b) t) - nil))))))) + (cl-assert (arrayp a) t) + (cl-assert (arrayp b) t) + (cl-assert (<= la lb) t) + (cl-loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (cl-return (if (/= la lb) + la + (cl-assert (equal a b) t) + nil))))))) (defun ert--subseq (seq start &optional end) "Return a subsequence of SEQ from START to END." (when (char-table-p seq) (error "Not supported")) (let ((vector (substring (ert--coerce-to-vector seq) start end))) - (etypecase seq + (cl-etypecase seq (vector vector) (string (concat vector)) (list (append vector nil)) - (bool-vector (loop with result = (make-bool-vector (length vector) nil) - for i below (length vector) do - (setf (aref result i) (aref vector i)) - finally (return result))) - (char-table (assert nil))))) + (bool-vector (cl-loop with result + = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (cl-return result))) + (char-table (cl-assert nil))))) (defun ert-equal-including-properties (a b) "Return t if A and B have similar structure and contents. @@ -225,10 +225,10 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;;; Defining and locating tests. ;; The data structure that represents a test case. -(defstruct ert-test +(cl-defstruct ert-test (name nil) (documentation nil) - (body (assert nil)) + (body (cl-assert nil)) (most-recent-result nil) (expected-result-type ':passed) (tags '())) @@ -273,7 +273,7 @@ Returns a two-element list containing the keys-and-values plist and the body." (let ((extracted-key-accu '()) (remaining keys-and-body)) - (while (and (consp remaining) (keywordp (first remaining))) + (while (keywordp (car-safe remaining)) (let ((keyword (pop remaining))) (unless (consp remaining) (error "Value expected after keyword %S in %S" @@ -283,13 +283,13 @@ and the body." keys-and-body)) (push (cons keyword (pop remaining)) extracted-key-accu))) (setq extracted-key-accu (nreverse extracted-key-accu)) - (list (loop for (key . value) in extracted-key-accu - collect key - collect value) + (list (cl-loop for (key . value) in extracted-key-accu + collect key + collect value) remaining))) ;;;###autoload -(defmacro* ert-deftest (name () &body docstring-keys-and-body) +(cl-defmacro ert-deftest (name () &body docstring-keys-and-body) "Define NAME (a symbol) as a test. BODY is evaluated as a `progn' when the test is run. It should @@ -313,12 +313,13 @@ description of valid values for RESULT-TYPE. (indent 2)) (let ((documentation nil) (documentation-supplied-p nil)) - (when (stringp (first docstring-keys-and-body)) + (when (stringp (car docstring-keys-and-body)) (setq documentation (pop docstring-keys-and-body) documentation-supplied-p t)) - (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) - (tags nil tags-supplied-p)) - body) + (cl-destructuring-bind + ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) (ert--parse-keys-and-body docstring-keys-and-body) `(progn (ert-set-test ',name @@ -405,10 +406,10 @@ DATA is displayed to the user and should state the reason of the failure." (t (let ((fn-name (car form)) (arg-forms (cdr form))) - (assert (or (symbolp fn-name) - (and (consp fn-name) - (eql (car fn-name) 'lambda) - (listp (cdr fn-name))))) + (cl-assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) (let ((fn (ert--gensym "fn-")) (args (ert--gensym "args-")) (value (ert--gensym "value-")) @@ -446,35 +447,34 @@ should return code that calls INNER-FORM and performs the checks and error signaling specific to the particular variant of `should'. The code that INNER-EXPANDER returns must not call FORM-DESCRIPTION-FORM before it has called INNER-FORM." - (lexical-let ((inner-expander inner-expander)) - (ert--expand-should-1 - whole form - (lambda (inner-form form-description-form value-var) - (let ((form-description (ert--gensym "form-description-"))) - `(let (,form-description) - ,(funcall inner-expander - `(unwind-protect - ,inner-form - (setq ,form-description ,form-description-form) - (ert--signal-should-execution ,form-description)) - `,form-description - value-var))))))) - -(defmacro* should (form) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var)))))) + +(cl-defmacro should (form) "Evaluate FORM. If it returns nil, abort the current test as failed. Returns the value of FORM." (ert--expand-should `(should ,form) form - (lambda (inner-form form-description-form value-var) + (lambda (inner-form form-description-form _value-var) `(unless ,inner-form (ert-fail ,form-description-form))))) -(defmacro* should-not (form) +(cl-defmacro should-not (form) "Evaluate FORM. If it returns non-nil, abort the current test as failed. Returns nil." (ert--expand-should `(should-not ,form) form - (lambda (inner-form form-description-form value-var) + (lambda (inner-form form-description-form _value-var) `(unless (not ,inner-form) (ert-fail ,form-description-form))))) @@ -485,10 +485,10 @@ Returns nil." Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, and aborts the current test as failed if it doesn't." (let ((signaled-conditions (get (car condition) 'error-conditions)) - (handled-conditions (etypecase type + (handled-conditions (cl-etypecase type (list type) (symbol (list type))))) - (assert signaled-conditions) + (cl-assert signaled-conditions) (unless (ert--intersection signaled-conditions handled-conditions) (ert-fail (append (funcall form-description-fn) @@ -507,7 +507,7 @@ and aborts the current test as failed if it doesn't." ;; FIXME: The expansion will evaluate the keyword args (if any) in ;; nonstandard order. -(defmacro* should-error (form &rest keys &key type exclude-subtypes) +(cl-defmacro should-error (form &rest keys &key type exclude-subtypes) "Evaluate FORM and check that it signals an error. The error signaled needs to match TYPE. TYPE should be a list @@ -555,20 +555,21 @@ failed." (defun ert--proper-list-p (x) "Return non-nil if X is a proper list, nil otherwise." - (loop + (cl-loop for firstp = t then nil for fast = x then (cddr fast) for slow = x then (cdr slow) do - (when (null fast) (return t)) - (when (not (consp fast)) (return nil)) - (when (null (cdr fast)) (return t)) - (when (not (consp (cdr fast))) (return nil)) - (when (and (not firstp) (eq fast slow)) (return nil)))) + (when (null fast) (cl-return t)) + (when (not (consp fast)) (cl-return nil)) + (when (null (cdr fast)) (cl-return t)) + (when (not (consp (cdr fast))) (cl-return nil)) + (when (and (not firstp) (eq fast slow)) (cl-return nil)))) (defun ert--explain-format-atom (x) "Format the atom X for `ert--explain-equal'." - (typecase x - (fixnum (list x (format "#x%x" x) (format "?%c" x))) + (cl-typecase x + (character (list x (format "#x%x" x) (format "?%c" x))) + (fixnum (list x (format "#x%x" x))) (t x))) (defun ert--explain-equal-rec (a b) @@ -576,7 +577,7 @@ failed." Returns nil if they are." (if (not (equal (type-of a) (type-of b))) `(different-types ,a ,b) - (etypecase a + (cl-etypecase a (cons (let ((a-proper-p (ert--proper-list-p a)) (b-proper-p (ert--proper-list-p b))) @@ -588,19 +589,19 @@ Returns nil if they are." ,a ,b first-mismatch-at ,(ert--mismatch a b)) - (loop for i from 0 - for ai in a - for bi in b - for xi = (ert--explain-equal-rec ai bi) - do (when xi (return `(list-elt ,i ,xi))) - finally (assert (equal a b) t))) + (cl-loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (cl-return `(list-elt ,i ,xi))) + finally (cl-assert (equal a b) t))) (let ((car-x (ert--explain-equal-rec (car a) (car b)))) (if car-x `(car ,car-x) (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) (if cdr-x `(cdr ,cdr-x) - (assert (equal a b) t) + (cl-assert (equal a b) t) nil)))))))) (array (if (not (equal (length a) (length b))) `(arrays-of-different-length ,(length a) ,(length b) @@ -608,12 +609,12 @@ Returns nil if they are." ,@(unless (char-table-p a) `(first-mismatch-at ,(ert--mismatch a b)))) - (loop for i from 0 - for ai across a - for bi across b - for xi = (ert--explain-equal-rec ai bi) - do (when xi (return `(array-elt ,i ,xi))) - finally (assert (equal a b) t)))) + (cl-loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (cl-return `(array-elt ,i ,xi))) + finally (cl-assert (equal a b) t)))) (atom (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) @@ -632,10 +633,10 @@ Returns nil if they are." (defun ert--significant-plist-keys (plist) "Return the keys of PLIST that have non-null values, in order." - (assert (zerop (mod (length plist) 2)) t) - (loop for (key value . rest) on plist by #'cddr - unless (or (null value) (memq key accu)) collect key into accu - finally (return accu))) + (cl-assert (zerop (mod (length plist) 2)) t) + (cl-loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (cl-return accu))) (defun ert--plist-difference-explanation (a b) "Return a programmer-readable explanation of why A and B are different plists. @@ -643,8 +644,8 @@ Returns nil if they are." Returns nil if they are equivalent, i.e., have the same value for each key, where absent values are treated as nil. The order of key/value pairs in each list does not matter." - (assert (zerop (mod (length a) 2)) t) - (assert (zerop (mod (length b) 2)) t) + (cl-assert (zerop (mod (length a) 2)) t) + (cl-assert (zerop (mod (length b) 2)) t) ;; Normalizing the plists would be another way to do this but it ;; requires a total ordering on all lisp objects (since any object ;; is valid as a text property key). Perhaps defining such an @@ -654,21 +655,21 @@ key/value pairs in each list does not matter." (keys-b (ert--significant-plist-keys b)) (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) - (flet ((explain-with-key (key) - (let ((value-a (plist-get a key)) - (value-b (plist-get b key))) - (assert (not (equal value-a value-b)) t) - `(different-properties-for-key - ,key ,(ert--explain-equal-including-properties value-a - value-b))))) + (cl-flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (cl-assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-equal-including-properties value-a + value-b))))) (cond (keys-in-a-not-in-b - (explain-with-key (first keys-in-a-not-in-b))) + (explain-with-key (car keys-in-a-not-in-b))) (keys-in-b-not-in-a - (explain-with-key (first keys-in-b-not-in-a))) + (explain-with-key (car keys-in-b-not-in-a))) (t - (loop for key in keys-a - when (not (equal (plist-get a key) (plist-get b key))) - return (explain-with-key key))))))) + (cl-loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) (defun ert--abbreviate-string (s len suffixp) "Shorten string S to at most LEN chars. @@ -692,29 +693,30 @@ Returns a programmer-readable explanation of why A and B are not `ert-equal-including-properties', or nil if they are." (if (not (equal a b)) (ert--explain-equal a b) - (assert (stringp a) t) - (assert (stringp b) t) - (assert (eql (length a) (length b)) t) - (loop for i from 0 to (length a) - for props-a = (text-properties-at i a) - for props-b = (text-properties-at i b) - for difference = (ert--plist-difference-explanation props-a props-b) - do (when difference - (return `(char ,i ,(substring-no-properties a i (1+ i)) - ,difference - context-before - ,(ert--abbreviate-string - (substring-no-properties a 0 i) - 10 t) - context-after - ,(ert--abbreviate-string - (substring-no-properties a (1+ i)) - 10 nil)))) - ;; TODO(ohler): Get `equal-including-properties' fixed in - ;; Emacs, delete `ert-equal-including-properties', and - ;; re-enable this assertion. - ;;finally (assert (equal-including-properties a b) t) - ))) + (cl-assert (stringp a) t) + (cl-assert (stringp b) t) + (cl-assert (eql (length a) (length b)) t) + (cl-loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation + props-a props-b) + do (when difference + (cl-return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (cl-assert (equal-including-properties a b) t) + ))) (put 'ert-equal-including-properties 'ert-explainer 'ert--explain-equal-including-properties) @@ -729,8 +731,8 @@ Returns a programmer-readable explanation of why A and B are not Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") -(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) - &body body) +(cl-defmacro ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. To be used within ERT tests. MESSAGE-FORM should evaluate to a @@ -750,18 +752,19 @@ and is displayed in front of the value of MESSAGE-FORM." "Non-nil means enter debugger when a test fails or terminates with an error.") ;; The data structures that represent the result of running a test. -(defstruct ert-test-result +(cl-defstruct ert-test-result (messages nil) (should-forms nil) ) -(defstruct (ert-test-passed (:include ert-test-result))) -(defstruct (ert-test-result-with-condition (:include ert-test-result)) - (condition (assert nil)) - (backtrace (assert nil)) - (infos (assert nil))) -(defstruct (ert-test-quit (:include ert-test-result-with-condition))) -(defstruct (ert-test-failed (:include ert-test-result-with-condition))) -(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) +(cl-defstruct (ert-test-passed (:include ert-test-result))) +(cl-defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (cl-assert nil)) + (backtrace (cl-assert nil)) + (infos (cl-assert nil))) +(cl-defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-aborted-with-non-local-exit + (:include ert-test-result))) (defun ert--record-backtrace () @@ -774,7 +777,7 @@ and is displayed in front of the value of MESSAGE-FORM." ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we ;; already have `ert-results-rerun-test-debugging-errors-at-point'. ;; For batch use, however, printing the backtrace may be useful. - (loop + (cl-loop ;; 6 is the number of frames our own debugger adds (when ;; compiled; more when interpreted). FIXME: Need to describe a ;; procedure for determining this constant. @@ -791,33 +794,33 @@ and is displayed in front of the value of MESSAGE-FORM." (print-level 8) (print-length 50)) (dolist (frame backtrace) - (ecase (first frame) + (cl-ecase (car frame) ((nil) ;; Special operator. - (destructuring-bind (special-operator &rest arg-forms) + (cl-destructuring-bind (special-operator &rest arg-forms) (cdr frame) (insert - (format " %S\n" (list* special-operator arg-forms))))) + (format " %S\n" (cons special-operator arg-forms))))) ((t) ;; Function call. - (destructuring-bind (fn &rest args) (cdr frame) + (cl-destructuring-bind (fn &rest args) (cdr frame) (insert (format " %S(" fn)) - (loop for firstp = t then nil - for arg in args do - (unless firstp - (insert " ")) - (insert (format "%S" arg))) + (cl-loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) (insert ")\n"))))))) ;; A container for the state of the execution of a single test and ;; environment data needed during its execution. -(defstruct ert--test-execution-info - (test (assert nil)) - (result (assert nil)) +(cl-defstruct ert--test-execution-info + (test (cl-assert nil)) + (result (cl-assert nil)) ;; A thunk that may be called when RESULT has been set to its final ;; value and test execution should be terminated. Should not ;; return. - (exit-continuation (assert nil)) + (exit-continuation (cl-assert nil)) ;; The binding of `debugger' outside of the execution of the test. next-debugger ;; The binding of `ert-debug-on-error' that is in effect for the @@ -826,7 +829,7 @@ and is displayed in front of the value of MESSAGE-FORM." ;; don't remember whether this feature is important.) ert-debug-on-error) -(defun ert--run-test-debugger (info debugger-args) +(defun ert--run-test-debugger (info args) "During a test run, `debugger' is bound to a closure that calls this function. This function records failures and errors and either terminates @@ -834,21 +837,21 @@ the test silently or calls the interactive debugger, as appropriate. INFO is the ert--test-execution-info corresponding to this test -run. DEBUGGER-ARGS are the arguments to `debugger'." - (destructuring-bind (first-debugger-arg &rest more-debugger-args) - debugger-args - (ecase first-debugger-arg +run. ARGS are the arguments to `debugger'." + (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args) + args + (cl-ecase first-debugger-arg ((lambda debug t exit nil) - (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (apply (ert--test-execution-info-next-debugger info) args)) (error - (let* ((condition (first more-debugger-args)) - (type (case (car condition) + (let* ((condition (car more-debugger-args)) + (type (cl-case (car condition) ((quit) 'quit) (otherwise 'failed))) (backtrace (ert--record-backtrace)) (infos (reverse ert--infos))) (setf (ert--test-execution-info-result info) - (ecase type + (cl-ecase type (quit (make-ert-test-quit :condition condition :backtrace backtrace @@ -859,39 +862,42 @@ run. DEBUGGER-ARGS are the arguments to `debugger'." :infos infos)))) ;; Work around Emacs's heuristic (in eval.c) for detecting ;; errors in the debugger. - (incf num-nonmacro-input-events) + (cl-incf num-nonmacro-input-events) ;; FIXME: We should probably implement more fine-grained ;; control a la non-t `debug-on-error' here. (cond ((ert--test-execution-info-ert-debug-on-error info) - (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (apply (ert--test-execution-info-next-debugger info) args)) (t)) (funcall (ert--test-execution-info-exit-continuation info))))))) -(defun ert--run-test-internal (ert-test-execution-info) - "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. +(defun ert--run-test-internal (test-execution-info) + "Low-level function to run a test according to TEST-EXECUTION-INFO. This mainly sets up debugger-related bindings." - (lexical-let ((info ert-test-execution-info)) - (setf (ert--test-execution-info-next-debugger info) debugger - (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) - (catch 'ert--pass - ;; For now, each test gets its own temp buffer and its own - ;; window excursion, just to be safe. If this turns out to be - ;; too expensive, we can remove it. - (with-temp-buffer - (save-window-excursion - (let ((debugger (lambda (&rest debugger-args) - (ert--run-test-debugger info debugger-args))) - (debug-on-error t) - (debug-on-quit t) - ;; FIXME: Do we need to store the old binding of this - ;; and consider it in `ert--run-test-debugger'? - (debug-ignored-errors nil) - (ert--infos '())) - (funcall (ert-test-body (ert--test-execution-info-test info)))))) - (ert-pass)) - (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + (setf (ert--test-execution-info-next-debugger test-execution-info) debugger + (ert--test-execution-info-ert-debug-on-error test-execution-info) + ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest args) + (ert--run-test-debugger test-execution-info + args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test + test-execution-info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result test-execution-info) + (make-ert-test-passed)) nil) (defun ert--force-message-log-buffer-truncation () @@ -929,18 +935,18 @@ The elements are of type `ert-test'.") Returns the result and stores it in ERT-TEST's `most-recent-result' slot." (setf (ert-test-most-recent-result ert-test) nil) - (block error - (lexical-let ((begin-marker - (with-current-buffer (get-buffer-create "*Messages*") - (set-marker (make-marker) (point-max))))) + (cl-block error + (let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (point-max-marker)))) (unwind-protect - (lexical-let ((info (make-ert--test-execution-info - :test ert-test - :result - (make-ert-test-aborted-with-non-local-exit) - :exit-continuation (lambda () - (return-from error nil)))) - (should-form-accu (list))) + (let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (cl-return-from error nil)))) + (should-form-accu (list))) (unwind-protect (let ((ert--should-execution-observer (lambda (form-description) @@ -982,32 +988,32 @@ t -- Always matches. RESULT." ;; It would be easy to add `member' and `eql' types etc., but I ;; haven't bothered yet. - (etypecase result-type + (cl-etypecase result-type ((member nil) nil) ((member t) t) ((member :failed) (ert-test-failed-p result)) ((member :passed) (ert-test-passed-p result)) (cons - (destructuring-bind (operator &rest operands) result-type - (ecase operator + (cl-destructuring-bind (operator &rest operands) result-type + (cl-ecase operator (and - (case (length operands) + (cl-case (length operands) (0 t) (t - (and (ert-test-result-type-p result (first operands)) - (ert-test-result-type-p result `(and ,@(rest operands))))))) + (and (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(and ,@(cdr operands))))))) (or - (case (length operands) + (cl-case (length operands) (0 nil) (t - (or (ert-test-result-type-p result (first operands)) - (ert-test-result-type-p result `(or ,@(rest operands))))))) + (or (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(or ,@(cdr operands))))))) (not - (assert (eql (length operands) 1)) - (not (ert-test-result-type-p result (first operands)))) + (cl-assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (car operands)))) (satisfies - (assert (eql (length operands) 1)) - (funcall (first operands) result))))))) + (cl-assert (eql (length operands) 1)) + (funcall (car operands) result))))))) (defun ert-test-result-expected-p (test result) "Return non-nil if TEST's expected result type matches RESULT." @@ -1048,9 +1054,9 @@ set implied by them without checking whether it is really contained in UNIVERSE." ;; This code needs to match the etypecase in ;; `ert-insert-human-readable-selector'. - (etypecase selector + (cl-etypecase selector ((member nil) nil) - ((member t) (etypecase universe + ((member t) (cl-etypecase universe (list universe) ((member t) (ert-select-tests "" universe)))) ((member :new) (ert-select-tests @@ -1078,7 +1084,7 @@ contained in UNIVERSE." universe)) ((member :unexpected) (ert-select-tests `(not :expected) universe)) (string - (etypecase universe + (cl-etypecase universe ((member t) (mapcar #'ert-get-test (apropos-internal selector #'ert-test-boundp))) (list (ert--remove-if-not (lambda (test) @@ -1088,51 +1094,51 @@ contained in UNIVERSE." universe)))) (ert-test (list selector)) (symbol - (assert (ert-test-boundp selector)) + (cl-assert (ert-test-boundp selector)) (list (ert-get-test selector))) (cons - (destructuring-bind (operator &rest operands) selector - (ecase operator + (cl-destructuring-bind (operator &rest operands) selector + (cl-ecase operator (member (mapcar (lambda (purported-test) - (etypecase purported-test - (symbol (assert (ert-test-boundp purported-test)) + (cl-etypecase purported-test + (symbol (cl-assert (ert-test-boundp purported-test)) (ert-get-test purported-test)) (ert-test purported-test))) operands)) (eql - (assert (eql (length operands) 1)) + (cl-assert (eql (length operands) 1)) (ert-select-tests `(member ,@operands) universe)) (and ;; Do these definitions of AND, NOT and OR satisfy de ;; Morgan's laws? Should they? - (case (length operands) + (cl-case (length operands) (0 (ert-select-tests 't universe)) - (t (ert-select-tests `(and ,@(rest operands)) - (ert-select-tests (first operands) + (t (ert-select-tests `(and ,@(cdr operands)) + (ert-select-tests (car operands) universe))))) (not - (assert (eql (length operands) 1)) + (cl-assert (eql (length operands) 1)) (let ((all-tests (ert-select-tests 't universe))) (ert--set-difference all-tests - (ert-select-tests (first operands) + (ert-select-tests (car operands) all-tests)))) (or - (case (length operands) + (cl-case (length operands) (0 (ert-select-tests 'nil universe)) - (t (ert--union (ert-select-tests (first operands) universe) - (ert-select-tests `(or ,@(rest operands)) + (t (ert--union (ert-select-tests (car operands) universe) + (ert-select-tests `(or ,@(cdr operands)) universe))))) (tag - (assert (eql (length operands) 1)) - (let ((tag (first operands))) + (cl-assert (eql (length operands) 1)) + (let ((tag (car operands))) (ert-select-tests `(satisfies ,(lambda (test) (member tag (ert-test-tags test)))) universe))) (satisfies - (assert (eql (length operands) 1)) - (ert--remove-if-not (first operands) + (cl-assert (eql (length operands) 1)) + (ert--remove-if-not (car operands) (ert-select-tests 't universe)))))))) (defun ert--insert-human-readable-selector (selector) @@ -1141,26 +1147,27 @@ contained in UNIVERSE." ;; `backtrace' slot of the result objects in the ;; `most-recent-result' slots of test case objects in (eql ...) or ;; (member ...) selectors. - (labels ((rec (selector) - ;; This code needs to match the etypecase in `ert-select-tests'. - (etypecase selector - ((or (member nil t - :new :failed :passed - :expected :unexpected) - string - symbol) - selector) - (ert-test - (if (ert-test-name selector) - (make-symbol (format "<%S>" (ert-test-name selector))) - (make-symbol "<unnamed test>"))) - (cons - (destructuring-bind (operator &rest operands) selector - (ecase operator - ((member eql and not or) - `(,operator ,@(mapcar #'rec operands))) - ((member tag satisfies) - selector))))))) + (cl-labels ((rec (selector) + ;; This code needs to match the etypecase in + ;; `ert-select-tests'. + (cl-etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol "<unnamed test>"))) + (cons + (cl-destructuring-bind (operator &rest operands) selector + (cl-ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) (insert (format "%S" (rec selector))))) @@ -1177,21 +1184,21 @@ contained in UNIVERSE." ;; that corresponds to this run in order to be able to update the ;; statistics correctly when a test is re-run interactively and has a ;; different result than before. -(defstruct ert--stats - (selector (assert nil)) +(cl-defstruct ert--stats + (selector (cl-assert nil)) ;; The tests, in order. - (tests (assert nil) :type vector) + (tests (cl-assert nil) :type vector) ;; A map of test names (or the test objects themselves for unnamed ;; tests) to indices into the `tests' vector. - (test-map (assert nil) :type hash-table) + (test-map (cl-assert nil) :type hash-table) ;; The results of the tests during this run, in order. - (test-results (assert nil) :type vector) + (test-results (cl-assert nil) :type vector) ;; The start times of the tests, in order, as reported by ;; `current-time'. - (test-start-times (assert nil) :type vector) + (test-start-times (cl-assert nil) :type vector) ;; The end times of the tests, in order, as reported by ;; `current-time'. - (test-end-times (assert nil) :type vector) + (test-end-times (cl-assert nil) :type vector) (passed-expected 0) (passed-unexpected 0) (failed-expected 0) @@ -1241,21 +1248,25 @@ Also changes the counters in STATS to match." (results (ert--stats-test-results stats)) (old-test (aref tests pos)) (map (ert--stats-test-map stats))) - (flet ((update (d) - (if (ert-test-result-expected-p (aref tests pos) - (aref results pos)) - (etypecase (aref results pos) - (ert-test-passed (incf (ert--stats-passed-expected stats) d)) - (ert-test-failed (incf (ert--stats-failed-expected stats) d)) - (null) - (ert-test-aborted-with-non-local-exit) - (ert-test-quit)) - (etypecase (aref results pos) - (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) - (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) - (null) - (ert-test-aborted-with-non-local-exit) - (ert-test-quit))))) + (cl-flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (cl-etypecase (aref results pos) + (ert-test-passed + (cl-incf (ert--stats-passed-expected stats) d)) + (ert-test-failed + (cl-incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit)) + (cl-etypecase (aref results pos) + (ert-test-passed + (cl-incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed + (cl-incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit))))) ;; Adjust counters to remove the result that is currently in stats. (update -1) ;; Put new test and result into stats. @@ -1273,11 +1284,11 @@ Also changes the counters in STATS to match." SELECTOR is the selector that was used to select TESTS." (setq tests (ert--coerce-to-vector tests)) (let ((map (make-hash-table :size (length tests)))) - (loop for i from 0 - for test across tests - for key = (ert--stats-test-key test) do - (assert (not (gethash key map))) - (setf (gethash key map) i)) + (cl-loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (cl-assert (not (gethash key map))) + (setf (gethash key map) i)) (make-ert--stats :selector selector :tests tests :test-map map @@ -1319,8 +1330,8 @@ SELECTOR is the selector that was used to select TESTS." (force-mode-line-update) (unwind-protect (progn - (loop for test in tests do - (ert-run-or-rerun-test stats test listener)) + (cl-loop for test in tests do + (ert-run-or-rerun-test stats test listener)) (setq abortedp nil)) (setf (ert--stats-aborted-p stats) abortedp) (setf (ert--stats-end-time stats) (current-time)) @@ -1344,7 +1355,7 @@ SELECTOR is the selector that was used to select TESTS." "Return a character that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." - (let ((s (etypecase result + (let ((s (cl-etypecase result (ert-test-passed ".P") (ert-test-failed "fF") (null "--") @@ -1356,7 +1367,7 @@ EXPECTEDP specifies whether the result was expected." "Return a string that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." - (let ((s (etypecase result + (let ((s (cl-etypecase result (ert-test-passed '("passed" "PASSED")) (ert-test-failed '("failed" "FAILED")) (null '("unknown" "UNKNOWN")) @@ -1378,9 +1389,9 @@ Ensures a final newline is inserted." "Insert `ert-info' infos from RESULT into current buffer. RESULT must be an `ert-test-result-with-condition'." - (check-type result ert-test-result-with-condition) + (cl-check-type result ert-test-result-with-condition) (dolist (info (ert-test-result-with-condition-infos result)) - (destructuring-bind (prefix . message) info + (cl-destructuring-bind (prefix . message) info (let ((begin (point)) (indentation (make-string (+ (length prefix) 4) ?\s)) (end nil)) @@ -1416,14 +1427,14 @@ Returns the stats object." (ert-run-tests selector (lambda (event-type &rest event-args) - (ecase event-type + (cl-ecase event-type (run-started - (destructuring-bind (stats) event-args + (cl-destructuring-bind (stats) event-args (message "Running %s tests (%s)" (length (ert--stats-tests stats)) (ert--format-time-iso8601 (ert--stats-start-time stats))))) (run-ended - (destructuring-bind (stats abortedp) event-args + (cl-destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) (expected-failures (ert--stats-failed-expected stats))) (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" @@ -1441,19 +1452,19 @@ Returns the stats object." (format "\n%s expected failures" expected-failures))) (unless (zerop unexpected) (message "%s unexpected results:" unexpected) - (loop for test across (ert--stats-tests stats) - for result = (ert-test-most-recent-result test) do - (when (not (ert-test-result-expected-p test result)) - (message "%9s %S" - (ert-string-for-test-result result nil) - (ert-test-name test)))) + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) (message "%s" ""))))) (test-started ) (test-ended - (destructuring-bind (stats test result) event-args + (cl-destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) - (etypecase result + (cl-etypecase result (ert-test-passed (message "Test %S passed unexpectedly" (ert-test-name test))) (ert-test-result-with-condition @@ -1479,7 +1490,7 @@ Returns the stats object." (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result))) (goto-char (1- (point-max))) - (assert (looking-at "\n")) + (cl-assert (looking-at "\n")) (delete-char 1) (message "Test %S condition:" (ert-test-name test)) (message "%s" (buffer-string)))) @@ -1527,7 +1538,7 @@ the tests)." (1 font-lock-keyword-face nil t) (2 font-lock-function-name-face nil t))))) -(defun* ert--remove-from-list (list-var element &key key test) +(cl-defun ert--remove-from-list (list-var element &key key test) "Remove ELEMENT from the value of LIST-VAR if present. This can be used as an inverse of `add-to-list'." @@ -1552,7 +1563,7 @@ If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to include the default, if any. Signals an error if no test name was read." - (etypecase default + (cl-etypecase default (string (let ((symbol (intern-soft default))) (unless (and symbol (ert-test-boundp symbol)) (setq default nil)))) @@ -1609,11 +1620,11 @@ Nothing more than an interactive interface to `ert-make-test-unbound'." ;;; Display of test progress and results. ;; An entry in the results buffer ewoc. There is one entry per test. -(defstruct ert--ewoc-entry - (test (assert nil)) +(cl-defstruct ert--ewoc-entry + (test (cl-assert nil)) ;; If the result of this test was expected, its ewoc entry is hidden ;; initially. - (hidden-p (assert nil)) + (hidden-p (cl-assert nil)) ;; An ewoc entry may be collapsed to hide details such as the error ;; condition. ;; @@ -1689,7 +1700,7 @@ Also sets `ert--results-progress-bar-button-begin'." ((ert--stats-current-test stats) 'running) ((ert--stats-end-time stats) 'finished) (t 'preparing)))) - (ecase state + (cl-ecase state (preparing (insert "")) (aborted @@ -1700,12 +1711,12 @@ Also sets `ert--results-progress-bar-button-begin'." (t (insert "Aborted.")))) (running - (assert (ert--stats-current-test stats)) + (cl-assert (ert--stats-current-test stats)) (insert "Running test: ") (ert-insert-test-name-button (ert-test-name (ert--stats-current-test stats)))) (finished - (assert (not (ert--stats-current-test stats))) + (cl-assert (not (ert--stats-current-test stats))) (insert "Finished."))) (insert "\n") (if (ert--stats-end-time stats) @@ -1808,7 +1819,7 @@ non-nil, returns the face for expected results.." (defun ert-face-for-stats (stats) "Return a face that represents STATS." (cond ((ert--stats-aborted-p stats) 'nil) - ((plusp (ert-stats-completed-unexpected stats)) + ((cl-plusp (ert-stats-completed-unexpected stats)) (ert-face-for-test-result nil)) ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) (ert-face-for-test-result t)) @@ -1819,7 +1830,7 @@ non-nil, returns the face for expected results.." (let* ((test (ert--ewoc-entry-test entry)) (stats ert--results-stats) (result (let ((pos (ert--stats-test-pos stats test))) - (assert pos) + (cl-assert pos) (aref (ert--stats-test-results stats) pos))) (hiddenp (ert--ewoc-entry-hidden-p entry)) (expandedp (ert--ewoc-entry-expanded-p entry)) @@ -1845,7 +1856,7 @@ non-nil, returns the face for expected results.." (ert--string-first-line (ert-test-documentation test)) 'font-lock-face 'font-lock-doc-face) "\n")) - (etypecase result + (cl-etypecase result (ert-test-passed (if (ert-test-result-expected-p test result) (insert " passed\n") @@ -1903,9 +1914,10 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (make-string (ert-stats-total stats) (ert-char-for-test-result nil t))) (set (make-local-variable 'ert--results-listener) listener) - (loop for test across (ert--stats-tests stats) do - (ewoc-enter-last ewoc - (make-ert--ewoc-entry :test test :hidden-p t))) + (cl-loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test + :hidden-p t))) (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) (goto-char (1- (point-max))) buffer))))) @@ -1940,21 +1952,21 @@ and how to display message." default nil)) nil)) (unless message-fn (setq message-fn 'message)) - (lexical-let ((output-buffer-name output-buffer-name) - buffer - listener - (message-fn message-fn)) + (let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) (setq listener (lambda (event-type &rest event-args) - (ecase event-type + (cl-ecase event-type (run-started - (destructuring-bind (stats) event-args + (cl-destructuring-bind (stats) event-args (setq buffer (ert--setup-results-buffer stats listener output-buffer-name)) (pop-to-buffer buffer))) (run-ended - (destructuring-bind (stats abortedp) event-args + (cl-destructuring-bind (stats abortedp) event-args (funcall message-fn "%sRan %s tests, %s results were as expected%s" (if (not abortedp) @@ -1971,19 +1983,19 @@ and how to display message." ert--results-ewoc) stats))) (test-started - (destructuring-bind (stats test) event-args + (cl-destructuring-bind (stats test) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) (node (ewoc-nth ewoc pos))) - (assert node) + (cl-assert node) (setf (ert--ewoc-entry-test (ewoc-data node)) test) (aset ert--results-progress-bar-string pos (ert-char-for-test-result nil t)) (ert--results-update-stats-display-maybe ewoc stats) (ewoc-invalidate ewoc node))))) (test-ended - (destructuring-bind (stats test result) event-args + (cl-destructuring-bind (stats test result) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) @@ -2015,28 +2027,28 @@ and how to display message." (define-derived-mode ert-results-mode special-mode "ERT-Results" "Major mode for viewing results of ERT test runs.") -(loop for (key binding) in - '(;; Stuff that's not in the menu. - ("\t" forward-button) - ([backtab] backward-button) - ("j" ert-results-jump-between-summary-and-result) - ("L" ert-results-toggle-printer-limits-for-test-at-point) - ("n" ert-results-next-test) - ("p" ert-results-previous-test) - ;; Stuff that is in the menu. - ("R" ert-results-rerun-all-tests) - ("r" ert-results-rerun-test-at-point) - ("d" ert-results-rerun-test-at-point-debugging-errors) - ("." ert-results-find-test-at-point-other-window) - ("b" ert-results-pop-to-backtrace-for-test-at-point) - ("m" ert-results-pop-to-messages-for-test-at-point) - ("l" ert-results-pop-to-should-forms-for-test-at-point) - ("h" ert-results-describe-test-at-point) - ("D" ert-delete-test) - ("T" ert-results-pop-to-timings) - ) - do - (define-key ert-results-mode-map key binding)) +(cl-loop for (key binding) in + '( ;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) (easy-menu-define ert-results-mode-menu ert-results-mode-map "Menu for `ert-results-mode'." @@ -2116,15 +2128,15 @@ To be used in the ERT results buffer." EWOC-FN specifies the direction and should be either `ewoc-prev' or `ewoc-next'. If there are no more nodes in that direction, an error is signaled with the message ERROR-MESSAGE." - (loop + (cl-loop (setq node (funcall ewoc-fn ert--results-ewoc node)) (when (null node) (error "%s" error-message)) (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) (goto-char (ewoc-location node)) - (return)))) + (cl-return)))) -(defun ert--results-expand-collapse-button-action (button) +(defun ert--results-expand-collapse-button-action (_button) "Expand or collapse the test node BUTTON belongs to." (let* ((ewoc ert--results-ewoc) (node (save-excursion @@ -2153,11 +2165,11 @@ To be used in the ERT results buffer." (defun ert--ewoc-position (ewoc node) ;; checkdoc-order: nil "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." - (loop for i from 0 - for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) - do (when (eql node node-here) - (return i)) - finally (return nil))) + (cl-loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (cl-return i)) + finally (cl-return nil))) (defun ert-results-jump-between-summary-and-result () "Jump back and forth between the test run summary and individual test results. @@ -2205,7 +2217,7 @@ To be used in the ERT results buffer." "Return the test at point, or nil. To be used in the ERT results buffer." - (assert (eql major-mode 'ert-results-mode)) + (cl-assert (eql major-mode 'ert-results-mode)) (if (ert--results-test-node-or-null-at-point) (let* ((node (ert--results-test-node-at-point)) (test (ert--ewoc-entry-test (ewoc-data node)))) @@ -2277,9 +2289,9 @@ definition." (point)) ((eventp last-command-event) (posn-point (event-start last-command-event))) - (t (assert nil)))) + (t (cl-assert nil)))) -(defun ert--results-progress-bar-button-action (button) +(defun ert--results-progress-bar-button-action (_button) "Jump to details for the test represented by the character clicked in BUTTON." (goto-char (ert--button-action-position)) (ert-results-jump-between-summary-and-result)) @@ -2289,7 +2301,7 @@ definition." To be used in the ERT results buffer." (interactive) - (assert (eql major-mode 'ert-results-mode)) + (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) (ert-run-tests-interactively selector (buffer-name)))) @@ -2298,13 +2310,13 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) - (destructuring-bind (test redefinition-state) + (cl-destructuring-bind (test redefinition-state) (ert--results-test-at-point-allow-redefinition) (when (null test) (error "No test at point")) (let* ((stats ert--results-stats) (progress-message (format "Running %stest %S" - (ecase redefinition-state + (cl-ecase redefinition-state ((nil) "") (redefined "new definition of ") (deleted "deleted ")) @@ -2345,7 +2357,7 @@ To be used in the ERT results buffer." (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) - (etypecase result + (cl-etypecase result (ert-test-passed (error "Test passed, no backtrace available")) (ert-test-result-with-condition (let ((backtrace (ert-test-result-with-condition-backtrace result)) @@ -2403,13 +2415,14 @@ To be used in the ERT results buffer." (ert-simple-view-mode) (if (null (ert-test-result-should-forms result)) (insert "\n(No should forms during this test.)\n") - (loop for form-description in (ert-test-result-should-forms result) - for i from 1 do - (insert "\n") - (insert (format "%s: " i)) - (let ((begin (point))) - (ert--pp-with-indentation-and-newline form-description) - (ert--make-xrefs-region begin (point))))) + (cl-loop for form-description + in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) (goto-char (point-min)) (insert "`should' forms executed during test `") (ert-insert-test-name-button (ert-test-name test)) @@ -2438,17 +2451,16 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) (let* ((stats ert--results-stats) - (start-times (ert--stats-test-start-times stats)) - (end-times (ert--stats-test-end-times stats)) (buffer (get-buffer-create "*ERT timings*")) - (data (loop for test across (ert--stats-tests stats) - for start-time across (ert--stats-test-start-times stats) - for end-time across (ert--stats-test-end-times stats) - collect (list test - (float-time (subtract-time end-time - start-time)))))) + (data (cl-loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times + stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time + end-time start-time)))))) (setq data (sort data (lambda (a b) - (> (second a) (second b))))) + (> (cl-second a) (cl-second b))))) (pop-to-buffer buffer) (let ((inhibit-read-only t)) (buffer-disable-undo) @@ -2457,13 +2469,13 @@ To be used in the ERT results buffer." (if (null data) (insert "(No data)\n") (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) - (loop for (test time) in data - for cumul-time = time then (+ cumul-time time) - for i from 1 do - (let ((begin (point))) - (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) - (ert-insert-test-name-button (ert-test-name test)) - (insert "\n")))) + (cl-loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (progn + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) (goto-char (point-min)) (insert "Tests by run time (seconds):\n\n") (forward-line 1)))) @@ -2476,7 +2488,7 @@ To be used in the ERT results buffer." (error "Requires Emacs 24")) (let (test-name test-definition) - (etypecase test-or-test-name + (cl-etypecase test-or-test-name (symbol (setq test-name test-or-test-name test-definition (ert-get-test test-or-test-name))) (ert-test (setq test-name (ert-test-name test-or-test-name) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index e3e5b321047..cf090e5e758 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -441,6 +441,26 @@ The return value is the last VAL in the list. `(logior (logand ,v ,mask) (logand ,getter (lognot ,mask)))))))))) +;;; References + +;;;###autoload +(defmacro gv-ref (place) + "Return a reference to PLACE. +This is like the `&' operator of the C language." + (gv-letplace (getter setter) place + `(cons (lambda () ,getter) + (lambda (gv--val) ,(funcall setter 'gv--val))))) + +(defsubst gv-deref (ref) + "Dereference REF, returning the referenced value. +This is like the `*' operator of the C language. +REF must have been previously obtained with `gv-ref'." + (funcall (car ref))) +;; Don't use `declare' because it seems to introduce circularity problems: +;; Warning: Eager macro-expansion skipped due to cycle: +;; … => (load "gv.el") => (macroexpand-all (defsubst gv-deref …)) => (macroexpand (defun …)) => (load "gv.el") +(gv-define-setter gv-deref (v ref) `(funcall (cdr ,ref) ,v)) + ;;; Vaguely related definitions that should be moved elsewhere. ;; (defun alist-get (key alist) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 024790d7b4b..f2e691102d4 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -209,10 +209,10 @@ If the given section does not exist, return nil." The HEADER is the section string marking the beginning of the section. If the given section does not exist, return nil. -The end of the section is defined as the beginning of the next -section of the same level or lower. The function -`lisp-outline-level' is used to compute the level of a section. -If no such section exists, return the end of the buffer." +The section ends before the first non-comment text or the next +section of the same level or lower; whatever comes first. The +function `lisp-outline-level' is used to compute the level of +a section." (require 'outline) ;; for outline-regexp. (let ((start (lm-section-start header))) (when start @@ -230,9 +230,15 @@ If no such section exists, return the end of the buffer." (beginning-of-line) (lisp-outline-level)) level))) - (if next-section-found - (line-beginning-position) - (point-max))))))) + (min (if next-section-found + (progn (beginning-of-line 0) + (unless (looking-at " ") + (beginning-of-line 2)) + (point)) + (point-max)) + (progn (goto-char start) + (while (forward-comment 1)) + (point)))))))) (defsubst lm-code-start () "Return the buffer location of the `Code' start marker." @@ -283,13 +289,8 @@ The returned value is a list of strings, one per line." (when res (setq res (list res)) (forward-line 1) - (while (and (or (looking-at (concat lm-header-prefix "[\t ]+")) - (and (not (looking-at - (lm-get-header-re "\\sw\\(\\sw\\|\\s_\\)*"))) - (looking-at lm-header-prefix))) - (goto-char (match-end 0)) - (looking-at ".+")) - (setq res (cons (match-string-no-properties 0) res)) + (while (looking-at "^;+\\(\t\\|[\t\s]\\{2,\\}\\)\\(.+\\)") + (push (match-string-no-properties 2) res) (forward-line 1))) (nreverse res)))) @@ -307,10 +308,13 @@ If FILE is nil, execute BODY in the current buffer." (emacs-lisp-mode) ,@body) (save-excursion - ;; Switching major modes is too drastic, so just switch - ;; temporarily to the Emacs Lisp mode syntax table. - (with-syntax-table emacs-lisp-mode-syntax-table - ,@body)))))) + (save-restriction + (widen) + (goto-char (point-min)) + ;; Switching major modes is too drastic, so just switch + ;; temporarily to the Emacs Lisp mode syntax table. + (with-syntax-table emacs-lisp-mode-syntax-table + ,@body))))))) ;; Fixme: Probably this should be amalgamated with copyright.el; also ;; we need a check for ranges in copyright years. @@ -490,6 +494,14 @@ absent, return nil." (when start (buffer-substring-no-properties start (lm-commentary-end)))))) +(defun lm-homepage (&optional file) + "Return the homepage in file FILE, or current buffer if FILE is nil." + (let ((page (lm-with-file file + (lm-header "\\(?:x-\\)?\\(?:homepage\\|url\\)")))) + (if (and page (string-match "^<.+>$" page)) + (substring page 1 -1) + page))) + ;;; Verification and synopses (defun lm-insert-at-column (col &rest strings) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index fc1cfe7afd1..4ebaa0a49d5 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -195,49 +195,38 @@ score-mode.el. KEYWORDS-CASE-INSENSITIVE non-nil means that for font-lock keywords will not be case sensitive." (when lisp-syntax (set-syntax-table lisp-mode-syntax-table)) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'lisp-fill-paragraph) + (setq-local paragraph-ignore-fill-prefix t) + (setq-local fill-paragraph-function 'lisp-fill-paragraph) ;; Adaptive fill mode gets the fill wrong for a one-line paragraph made of ;; a single docstring. Let's fix it here. - (set (make-local-variable 'adaptive-fill-function) - (lambda () (if (looking-at "\\s-+\"[^\n\"]+\"\\s-*$") ""))) + (setq-local adaptive-fill-function + (lambda () (if (looking-at "\\s-+\"[^\n\"]+\"\\s-*$") ""))) ;; Adaptive fill mode gets in the way of auto-fill, ;; and should make no difference for explicit fill ;; because lisp-fill-paragraph should do the job. ;; I believe that newcomment's auto-fill code properly deals with it -stef ;;(set (make-local-variable 'adaptive-fill-mode) nil) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'lisp-indent-line) - (make-local-variable 'outline-regexp) - (setq outline-regexp ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(") - (make-local-variable 'outline-level) - (setq outline-level 'lisp-outline-level) - (make-local-variable 'comment-start) - (setq comment-start ";") - (make-local-variable 'comment-start-skip) + (setq-local indent-line-function 'lisp-indent-line) + (setq-local outline-regexp ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(") + (setq-local outline-level 'lisp-outline-level) + (setq-local add-log-current-defun-function #'lisp-current-defun-name) + (setq-local comment-start ";") ;; Look within the line for a ; following an even number of backslashes ;; after either a non-backslash or the line beginning. - (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") - (make-local-variable 'font-lock-comment-start-skip) + (setq-local comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") ;; Font lock mode uses this only when it KNOWS a comment is starting. - (setq font-lock-comment-start-skip ";+ *") - (make-local-variable 'comment-add) - (setq comment-add 1) ;default to `;;' in comment-region - (make-local-variable 'comment-column) - (setq comment-column 40) + (setq-local font-lock-comment-start-skip ";+ *") + (setq-local comment-add 1) ;default to `;;' in comment-region + (setq-local comment-column 40) ;; Don't get confused by `;' in doc strings when paragraph-filling. - (set (make-local-variable 'comment-use-global-state) t) - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression lisp-imenu-generic-expression) - (make-local-variable 'multibyte-syntax-as-symbol) - (setq multibyte-syntax-as-symbol t) - (set (make-local-variable 'syntax-begin-function) 'beginning-of-defun) + (setq-local comment-use-global-state t) + (setq-local imenu-generic-expression lisp-imenu-generic-expression) + (setq-local multibyte-syntax-as-symbol t) + (setq-local syntax-begin-function 'beginning-of-defun) (setq font-lock-defaults `((lisp-font-lock-keywords lisp-font-lock-keywords-1 lisp-font-lock-keywords-2) - nil ,keywords-case-insensitive (("+-*/.<>=!?$%_&~^:@" . "w")) nil + nil ,keywords-case-insensitive nil nil (font-lock-mark-block-function . mark-defun) (font-lock-syntactic-face-function . lisp-font-lock-syntactic-face-function)))) @@ -249,6 +238,32 @@ font-lock keywords will not be case sensitive." 1000 len))) +(defun lisp-current-defun-name () + "Return the name of the defun at point, or nil." + (save-excursion + (let ((location (point))) + ;; If we are now precisely at the beginning of a defun, make sure + ;; beginning-of-defun finds that one rather than the previous one. + (or (eobp) (forward-char 1)) + (beginning-of-defun) + ;; Make sure we are really inside the defun found, not after it. + (when (and (looking-at "\\s(") + (progn (end-of-defun) + (< location (point))) + (progn (forward-sexp -1) + (>= location (point)))) + (if (looking-at "\\s(") + (forward-char 1)) + ;; Skip the defining construct name, typically "defun" or + ;; "defvar". + (forward-sexp 1) + ;; The second element is usually a symbol being defined. If it + ;; is not, use the first symbol in it. + (skip-chars-forward " \t\n'(") + (buffer-substring-no-properties (point) + (progn (forward-sexp 1) + (point))))))) + (defvar lisp-mode-shared-map (let ((map (make-sparse-keymap))) (define-key map "\e\C-q" 'indent-sexp) @@ -320,6 +335,22 @@ font-lock keywords will not be case sensitive." (bindings--define-key prof-map [prof-func] '(menu-item "Instrument Function..." elp-instrument-function :help "Instrument a function for profiling")) + ;; Maybe this should be in a separate submenu from the ELP stuff? + (bindings--define-key prof-map [sep-natprof] menu-bar-separator) + (bindings--define-key prof-map [prof-natprof-stop] + '(menu-item "Stop Native Profiler" profiler-stop + :help "Stop recording profiling information" + :enable (and (featurep 'profiler) + (profiler-running-p)))) + (bindings--define-key prof-map [prof-natprof-report] + '(menu-item "Show Profiler Report" profiler-report + :help "Show the current profiler report" + :enable (and (featurep 'profiler) + (profiler-running-p)))) + (bindings--define-key prof-map [prof-natprof-start] + '(menu-item "Start Native Profiler..." profiler-start + :help "Start recording profiling information")) + (bindings--define-key menu-map [lint] (cons "Linting" lint-map)) (bindings--define-key lint-map [lint-di] '(menu-item "Lint Directory..." elint-directory @@ -519,10 +550,9 @@ or to switch back to an existing one. Entry to this mode calls the value of `lisp-mode-hook' if that value is non-nil." (lisp-mode-variables nil t) - (set (make-local-variable 'find-tag-default-function) 'lisp-find-tag-default) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") + (setq-local find-tag-default-function 'lisp-find-tag-default) + (setq-local comment-start-skip + "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") (setq imenu-case-fold-search t)) (defun lisp-find-tag-default () @@ -816,6 +846,7 @@ this command arranges for all errors to enter the debugger." (defun eval-defun-1 (form) "Treat some expressions specially. Reset the `defvar' and `defcustom' variables to the initial value. +\(For `defcustom', use the :set function if there is one.) Reinitialize the face according to the `defface' specification." ;; The code in edebug-defun should be consistent with this, but not ;; the same, since this gets a macroexpanded form. @@ -831,14 +862,19 @@ Reinitialize the face according to the `defface' specification." ;; `custom-declare-variable' with a quoted value arg. ((and (eq (car form) 'custom-declare-variable) (default-boundp (eval (nth 1 form) lexical-binding))) - ;; Force variable to be bound. - (set-default (eval (nth 1 form) lexical-binding) - ;; The second arg is an expression that evaluates to - ;; an expression. The second evaluation is the one - ;; normally performed not be normal execution but by - ;; custom-initialize-set (for example), which does not - ;; use lexical-binding. - (eval (eval (nth 2 form) lexical-binding))) + ;; Force variable to be bound, using :set function if specified. + (let ((setfunc (memq :set form))) + (when setfunc + (setq setfunc (car-safe (cdr-safe setfunc))) + (or (functionp setfunc) (setq setfunc nil))) + (funcall (or setfunc 'set-default) + (eval (nth 1 form) lexical-binding) + ;; The second arg is an expression that evaluates to + ;; an expression. The second evaluation is the one + ;; normally performed not by normal execution but by + ;; custom-initialize-set (for example), which does not + ;; use lexical-binding. + (eval (eval (nth 2 form) lexical-binding)))) form) ;; `defface' is macroexpanded to `custom-declare-face'. ((eq (car form) 'custom-declare-face) @@ -847,21 +883,8 @@ Reinitialize the face according to the `defface' specification." (setq face-new-frame-defaults (assq-delete-all face-symbol face-new-frame-defaults)) (put face-symbol 'face-defface-spec nil) - (put face-symbol 'face-documentation (nth 3 form)) - ;; Setting `customized-face' to the new spec after calling - ;; the form, but preserving the old saved spec in `saved-face', - ;; imitates the situation when the new face spec is set - ;; temporarily for the current session in the customize - ;; buffer, thus allowing `face-user-default-spec' to use the - ;; new customized spec instead of the saved spec. - ;; Resetting `saved-face' temporarily to nil is needed to let - ;; `defface' change the spec, regardless of a saved spec. - (prog1 `(prog1 ,form - (put ,(nth 1 form) 'saved-face - ',(get face-symbol 'saved-face)) - (put ,(nth 1 form) 'customized-face - ,(nth 2 form))) - (put face-symbol 'saved-face nil)))) + (put face-symbol 'face-override-spec nil)) + form) ((eq (car form) 'progn) (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) (t form))) @@ -914,11 +937,12 @@ Return the result of evaluation." If the current defun is actually a call to `defvar' or `defcustom', evaluating it this way resets the variable using its initial value -expression even if the variable already has some other value. -\(Normally `defvar' and `defcustom' do not alter the value if there -already is one.) In an analogous way, evaluating a `defface' -overrides any customizations of the face, so that it becomes -defined exactly as the `defface' expression says. +expression (using the defcustom's :set function if there is one), even +if the variable already has some other value. \(Normally `defvar' and +`defcustom' do not alter the value if there already is one.) In an +analogous way, evaluating a `defface' overrides any customizations of +the face, so that it becomes defined exactly as the `defface' expression +says. If `eval-expression-debug-on-error' is non-nil, which is the default, this command arranges for all errors to enter the debugger. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 3bf08ee8a97..6bb796434fd 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -124,7 +124,10 @@ and also to avoid outputting the warning during normal execution." (macroexp--funcall-if-compiled ',when-compiled) ,form)) (t - (message "%s" msg) + (message "%s%s" (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") + msg) form)))) (defun macroexp--obsolete-warning (fun obsolescence-data type) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el new file mode 100644 index 00000000000..b0711fed26c --- /dev/null +++ b/lisp/emacs-lisp/nadvice.el @@ -0,0 +1,457 @@ +;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*- + +;; Copyright (C) 2012-2013 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: extensions, lisp, tools +;; Package: emacs + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package lets you add behavior (which we call "piece of advice") to +;; existing functions, like the old `advice.el' package, but with much fewer +;; bells ans whistles. It comes in 2 parts: +;; +;; - The first part lets you add/remove functions, similarly to +;; add/remove-hook, from any "place" (i.e. as accepted by `setf') that +;; holds a function. +;; This part provides mainly 2 macros: `add-function' and `remove-function'. +;; +;; - The second part provides `advice-add' and `advice-remove' which are +;; refined version of the previous macros specially tailored for the case +;; where the place that we want to modify is a `symbol-function'. + +;;; Code: + +;;;; Lightweight advice/hook +(defvar advice--where-alist + '((:around "\300\301\302\003#\207" 5) + (:before "\300\301\002\"\210\300\302\002\"\207" 4) + (:after "\300\302\002\"\300\301\003\"\210\207" 5) + (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4) + (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4) + (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4) + (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)) + "List of descriptions of how to add a function. +Each element has the form (WHERE BYTECODE STACK) where: + WHERE is a keyword indicating where the function is added. + BYTECODE is the corresponding byte-code that will be used. + STACK is the amount of stack space needed by the byte-code.") + +(defvar advice--bytecodes (mapcar #'cadr advice--where-alist)) + +(defun advice--p (object) + (and (byte-code-function-p object) + (eq 128 (aref object 0)) + (memq (length object) '(5 6)) + (memq (aref object 1) advice--bytecodes) + (eq #'apply (aref (aref object 2) 0)))) + +(defsubst advice--car (f) (aref (aref f 2) 1)) +(defsubst advice--cdr (f) (aref (aref f 2) 2)) +(defsubst advice--props (f) (aref (aref f 2) 3)) + +(defun advice--make-docstring (_string function) + "Build the raw doc-string of SYMBOL, presumably advised." + (let ((flist (indirect-function function)) + (docstring nil)) + (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) + (while (advice--p flist) + (let ((bytecode (aref flist 1)) + (where nil)) + (dolist (elem advice--where-alist) + (if (eq bytecode (cadr elem)) (setq where (car elem)))) + (setq docstring + (concat + docstring + (propertize (format "%s advice: " where) + 'face 'warning) + (let ((fun (advice--car flist))) + (if (symbolp fun) (format "`%S'" fun) + (let* ((name (cdr (assq 'name (advice--props flist)))) + (doc (documentation fun t)) + (usage (help-split-fundoc doc function))) + (if usage (setq doc (cdr usage))) + (if name + (if doc + (format "%s\n%s" name doc) + (format "%s" name)) + (or doc "No documentation"))))) + "\n"))) + (setq flist (advice--cdr flist))) + (if docstring (setq docstring (concat docstring "\n"))) + (let* ((origdoc (unless (eq function flist) ;Avoid inf-loops. + (documentation flist t))) + (usage (help-split-fundoc origdoc function))) + (setq usage (if (null usage) + (let ((arglist (help-function-arglist flist))) + (format "%S" (help-make-usage function arglist))) + (setq origdoc (cdr usage)) (car usage))) + (help-add-fundoc-usage (concat docstring origdoc) usage)))) + +(defvar advice--docstring + ;; Can't eval-when-compile nor use defconst because it then gets pure-copied, + ;; which drops the text-properties. + ;;(eval-when-compile + (propertize "Advised function" + 'dynamic-docstring-function #'advice--make-docstring)) ;; ) + +(defun advice-eval-interactive-spec (spec) + "Evaluate the interactive spec SPEC." + (cond + ((stringp spec) + ;; There's no direct access to the C code (in call-interactively) that + ;; processes those specs, but that shouldn't stop us, should it? + ;; FIXME: Despite appearances, this is not faithful: SPEC and + ;; (advice-eval-interactive-spec SPEC) will behave subtly differently w.r.t + ;; command-history (and maybe a few other details). + (call-interactively `(lambda (&rest args) (interactive ,spec) args))) + ;; ((functionp spec) (funcall spec)) + (t (eval spec)))) + +(defun advice--make-interactive-form (function main) + ;; TODO: make it so that interactive spec can be a constant which + ;; dynamically checks the advice--car/cdr to do its job. + ;; For that, advice-eval-interactive-spec needs to be more faithful. + ;; FIXME: The calls to interactive-form below load autoloaded functions + ;; too eagerly. + (let ((fspec (cadr (interactive-form function)))) + (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? + (setq fspec (nth 1 fspec))) + (if (functionp fspec) + `(funcall ',fspec + ',(cadr (interactive-form main))) + (cadr (or (interactive-form function) + (interactive-form main)))))) + +(defsubst advice--make-1 (byte-code stack-depth function main props) + "Build a function value that adds FUNCTION to MAIN." + (let ((adv-sig (gethash main advertised-signature-table)) + (advice + (apply #'make-byte-code 128 byte-code + (vector #'apply function main props) stack-depth + advice--docstring + (when (or (commandp function) (commandp main)) + (list (advice--make-interactive-form + function main)))))) + (when adv-sig (puthash advice adv-sig advertised-signature-table)) + advice)) + +(defun advice--make (where function main props) + "Build a function value that adds FUNCTION to MAIN at WHERE. +WHERE is a symbol to select an entry in `advice--where-alist'." + (let ((desc (assq where advice--where-alist))) + (unless desc (error "Unknown add-function location `%S'" where)) + (advice--make-1 (nth 1 desc) (nth 2 desc) + function main props))) + +(defun advice--member-p (function definition) + (let ((found nil)) + (while (and (not found) (advice--p definition)) + (if (or (equal function (advice--car definition)) + (equal function (cdr (assq 'name (advice--props definition))))) + (setq found t) + (setq definition (advice--cdr definition)))) + found)) + +(defun advice--tweak (flist tweaker) + (if (not (advice--p flist)) + (funcall tweaker nil flist nil) + (let ((first (advice--car flist)) + (rest (advice--cdr flist)) + (props (advice--props flist))) + (let ((val (funcall tweaker first rest props))) + (if val (car val) + (let ((nrest (advice--tweak rest tweaker))) + (if (eq rest nrest) flist + (advice--make-1 (aref flist 1) (aref flist 3) + first nrest props)))))))) + +;;;###autoload +(defun advice--remove-function (flist function) + (advice--tweak flist + (lambda (first rest props) + (cond ((not first) rest) + ((or (equal function first) + (equal function (cdr (assq 'name props)))) + (list rest)))))) + +(defvar advice--buffer-local-function-sample nil) + +(defun advice--set-buffer-local (var val) + (if (function-equal val advice--buffer-local-function-sample) + (kill-local-variable var) + (set (make-local-variable var) val))) + +;;;###autoload +(defun advice--buffer-local (var) + "Buffer-local value of VAR, presumed to contain a function." + (declare (gv-setter advice--set-buffer-local)) + (if (local-variable-p var) (symbol-value var) + (setq advice--buffer-local-function-sample + (lambda (&rest args) (apply (default-value var) args))))) + +;;;###autoload +(defmacro add-function (where place function &optional props) + ;; TODO: + ;; - obsolete with-wrapper-hook (mostly requires buffer-local support). + ;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP + ;; and tracing want to stay first. + ;; - maybe let `where' specify some kind of predicate and use it + ;; to implement things like mode-local or eieio-defmethod. + ;; Of course, that only makes sense if the predicates of all advices can + ;; be combined and made more efficient. + ;; :before is like a normal add-hook on a normal hook. + ;; :before-while is like add-hook on run-hook-with-args-until-failure. + ;; :before-until is like add-hook on run-hook-with-args-until-success. + ;; Same with :after-* but for (add-hook ... 'append). + "Add a piece of advice on the function stored at PLACE. +FUNCTION describes the code to add. WHERE describes where to add it. +WHERE can be explained by showing the resulting new function, as the +result of combining FUNCTION and the previous value of PLACE, which we +call OLDFUN here: +`:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) +`:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) +`:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) +`:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) +`:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) +`:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) +`:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) +If FUNCTION was already added, do nothing. +PROPS is an alist of additional properties, among which the following have +a special meaning: +- `name': a string or symbol. It can be used to refer to this piece of advice. + +PLACE cannot be a simple variable. Instead it should either be +\(default-value 'VAR) or (local 'VAR) depending on whether FUNCTION +should be applied to VAR buffer-locally or globally. + +If one of FUNCTION or OLDFUN is interactive, then the resulting function +is also interactive. There are 3 cases: +- FUNCTION is not interactive: the interactive spec of OLDFUN is used. +- The interactive spec of FUNCTION is itself a function: it should take one + argument (the interactive spec of OLDFUN, which it can pass to + `advice-eval-interactive-spec') and return the list of arguments to use. +- Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN." + (declare (debug t)) ;;(indent 2) + (cond ((eq 'local (car-safe place)) + (setq place `(advice--buffer-local ,@(cdr place)))) + ((symbolp place) + (error "Use (default-value '%S) or (local '%S)" place place))) + `(advice--add-function ,where (gv-ref ,place) ,function ,props)) + +;;;###autoload +(defun advice--add-function (where ref function props) + (unless (advice--member-p function (gv-deref ref)) + (setf (gv-deref ref) + (advice--make where function (gv-deref ref) props)))) + +(defmacro remove-function (place function) + "Remove the FUNCTION piece of advice from PLACE. +If FUNCTION was not added to PLACE, do nothing. +Instead of FUNCTION being the actual function, it can also be the `name' +of the piece of advice." + (declare (debug t)) + (cond ((eq 'local (car-safe place)) + (setq place `(advice--buffer-local ,@(cdr place)))) + ((symbolp place) + (error "Use (default-value '%S) or (local '%S)" place place))) + (gv-letplace (getter setter) place + (macroexp-let2 nil new `(advice--remove-function ,getter ,function) + `(unless (eq ,new ,getter) ,(funcall setter new))))) + +;;;; Specific application of add-function to `symbol-function' for advice. + +(defun advice--subst-main (old new) + (advice--tweak old + (lambda (first _rest _props) (if (not first) new)))) + +(defun advice--normalize (symbol def) + (cond + ((special-form-p def) + ;; Not worth the trouble trying to handle this, I think. + (error "advice-add failure: %S is a special form" symbol)) + ((and (symbolp def) + (eq 'macro (car-safe (ignore-errors (indirect-function def))))) + (let ((newval (cons 'macro (cdr (indirect-function def))))) + (put symbol 'advice--saved-rewrite (cons def newval)) + newval)) + ;; `f' might be a pure (hence read-only) cons! + ((and (eq 'macro (car-safe def)) + (not (ignore-errors (setcdr def (cdr def)) t))) + (cons 'macro (cdr def))) + (t def))) + +(defsubst advice--strip-macro (x) + (if (eq 'macro (car-safe x)) (cdr x) x)) + +(defun advice--defalias-fset (fsetfun symbol newdef) + (when (get symbol 'advice--saved-rewrite) + (put symbol 'advice--saved-rewrite nil)) + (setq newdef (advice--normalize symbol newdef)) + (let* ((olddef (advice--strip-macro + (if (fboundp symbol) (symbol-function symbol)))) + (oldadv + (cond + ((null (get symbol 'advice--pending)) + (or olddef + (progn + (message "Delayed advice activation failed for %s: no data" + symbol) + nil))) + ((or (not olddef) (autoloadp olddef)) + (prog1 (get symbol 'advice--pending) + (put symbol 'advice--pending nil))) + (t (message "Dropping left-over advice--pending for %s" symbol) + (put symbol 'advice--pending nil) + olddef)))) + (let* ((snewdef (advice--strip-macro newdef)) + (snewadv (advice--subst-main oldadv snewdef))) + (funcall (or fsetfun #'fset) symbol + (if (eq snewdef newdef) snewadv (cons 'macro snewadv)))))) + + +;;;###autoload +(defun advice-add (symbol where function &optional props) + "Like `add-function' but for the function named SYMBOL. +Contrary to `add-function', this will properly handle the cases where SYMBOL +is defined as a macro, alias, command, ..." + ;; TODO: + ;; - record the advice location, to display in describe-function. + ;; - change all defadvice in lisp/**/*.el. + ;; - rewrite advice.el on top of this. + ;; - obsolete advice.el. + (let* ((f (and (fboundp symbol) (symbol-function symbol))) + (nf (advice--normalize symbol f))) + (unless (eq f nf) ;; Most importantly, if nf == nil! + (fset symbol nf)) + (add-function where (cond + ((eq (car-safe nf) 'macro) (cdr nf)) + ;; Reasons to delay installation of the advice: + ;; - If the function is not yet defined, installing + ;; the advice would affect `fboundp'ness. + ;; - If it's an autoloaded command, + ;; advice--make-interactive-form would end up + ;; loading the command eagerly. + ;; - `autoload' does nothing if the function is + ;; not an autoload or undefined. + ((or (not nf) (autoloadp nf)) + (get symbol 'advice--pending)) + (t (symbol-function symbol))) + function props) + (add-function :around (get symbol 'defalias-fset-function) + #'advice--defalias-fset)) + nil) + +;;;###autoload +(defun advice-remove (symbol function) + "Like `remove-function' but for the function named SYMBOL. +Contrary to `remove-function', this will work also when SYMBOL is a macro +and it will not signal an error if SYMBOL is not `fboundp'. +Instead of the actual function to remove, FUNCTION can also be the `name' +of the piece of advice." + (when (fboundp symbol) + (let ((f (symbol-function symbol))) + ;; Can't use the `if' place here, because the body is too large, + ;; resulting in use of code that only works with lexical-scoping. + (remove-function (if (eq (car-safe f) 'macro) + (cdr f) + (symbol-function symbol)) + function) + (unless (advice--p + (if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol))) + ;; Not advised any more. + (remove-function (get symbol 'defalias-fset-function) + #'advice--defalias-fset) + (if (eq (symbol-function symbol) + (cdr (get symbol 'advice--saved-rewrite))) + (fset symbol (car (get symbol 'advice--saved-rewrite)))))) + nil)) + +;; (defun advice-mapc (fun symbol) +;; "Apply FUN to every function added as advice to SYMBOL. +;; FUN is called with a two arguments: the function that was added, and the +;; properties alist that was specified when it was added." +;; (let ((def (or (get symbol 'advice--pending) +;; (if (fboundp symbol) (symbol-function symbol))))) +;; (while (advice--p def) +;; (funcall fun (advice--car def) (advice--props def)) +;; (setq def (advice--cdr def))))) + +;;;###autoload +(defun advice-member-p (advice function-name) + "Return non-nil if ADVICE has been added to FUNCTION-NAME. +Instead of ADVICE being the actual function, it can also be the `name' +of the piece of advice." + (advice--member-p advice + (or (get function-name 'advice--pending) + (advice--strip-macro + (if (fboundp function-name) + (symbol-function function-name)))))) + +;; When code is advised, called-interactively-p needs to be taught to skip +;; the advising frames. +;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p +;; done from the advised function if the deepest advice is an around advice! +;; In other cases (calls from an advice or calls from the advised function when +;; the deepest advice is not an around advice), it should hopefully get +;; it right. +(add-hook 'called-interactively-p-functions + #'advice--called-interactively-skip) +(defun advice--called-interactively-skip (origi frame1 frame2) + (let* ((i origi) + (get-next-frame + (lambda () + (setq frame1 frame2) + (setq frame2 (internal--called-interactively-p--get-frame i)) + ;; (message "Advice Frame %d = %S" i frame2) + (setq i (1+ i))))) + (when (and (eq (nth 1 frame2) 'apply) + (progn + (funcall get-next-frame) + (advice--p (indirect-function (nth 1 frame2))))) + (funcall get-next-frame) + ;; If we now have the symbol, this was the head advice and + ;; we're done. + (while (advice--p (nth 1 frame1)) + ;; This was an inner advice called from some earlier advice. + ;; The stack frames look different depending on the particular + ;; kind of the earlier advice. + (let ((inneradvice (nth 1 frame1))) + (if (and (eq (nth 1 frame2) 'apply) + (progn + (funcall get-next-frame) + (advice--p (indirect-function + (nth 1 frame2))))) + ;; The earlier advice was something like a before/after + ;; advice where the "next" code is called directly by the + ;; advice--p object. + (funcall get-next-frame) + ;; It's apparently an around advice, where the "next" is + ;; called by the body of the advice in any way it sees fit, + ;; so we need to skip the frames of that body. + (while + (progn + (funcall get-next-frame) + (not (and (eq (nth 1 frame2) 'apply) + (eq (nth 3 frame2) inneradvice))))) + (funcall get-next-frame) + (funcall get-next-frame)))) + (- i origi 1)))) + + +(provide 'nadvice) +;;; nadvice.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 6059f03f999..c15c9e079fe 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -735,6 +735,8 @@ It will move point to somewhere in the headers." (package--with-work-buffer location file (package-unpack name version)))) +(defvar package--initialized nil) + (defun package-installed-p (package &optional min-version) "Return true if PACKAGE, of MIN-VERSION or newer, is installed. MIN-VERSION should be a version list." @@ -896,8 +898,6 @@ using `package-compute-transaction'." package-user-dir) (package-activate elt (version-to-list v-string))))) -(defvar package--initialized nil) - ;;;###autoload (defun package-install (name) "Install the package named NAME. @@ -1182,7 +1182,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (require 'lisp-mnt) (let ((package-name (symbol-name package)) (built-in (assq package package--builtins)) - desc pkg-dir reqs version installable) + desc pkg-dir reqs version installable archive) (prin1 package) (princ " is ") (cond @@ -1196,6 +1196,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." ;; Available packages are in `package-archive-contents'. ((setq desc (cdr (assq package package-archive-contents))) (setq version (package-version-join (package-desc-vers desc)) + archive (aref desc (- (length desc) 1)) installable t) (if built-in (insert "a built-in package.\n\n") @@ -1224,8 +1225,10 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (installable (if built-in (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face) - " Alternate version available -- ") - (insert "Available -- ")) + " Alternate version available") + (insert "Available")) + (insert " from " archive) + (insert " -- ") (let ((button-text (if (display-graphic-p) "Install" "[Install]")) (button-face (if (display-graphic-p) '(:box (:line-width 2 :color "dark grey") @@ -1588,10 +1591,11 @@ call will upgrade the package." (length upgrades) (if (= (length upgrades) 1) "" "s"))))) -(defun package-menu-execute () +(defun package-menu-execute (&optional noquery) "Perform marked Package Menu actions. Packages marked for installation are downloaded and installed; -packages marked for deletion are removed." +packages marked for deletion are removed. +Optional argument NOQUERY non-nil means do not ask the user to confirm." (interactive) (unless (derived-mode-p 'package-menu-mode) (error "The current buffer is not in Package Menu mode")) @@ -1611,16 +1615,20 @@ packages marked for deletion are removed." (push (car id) install-list)))) (forward-line))) (when install-list - (if (yes-or-no-p + (if (or + noquery + (yes-or-no-p (if (= (length install-list) 1) (format "Install package `%s'? " (car install-list)) (format "Install these %d packages (%s)? " (length install-list) - (mapconcat 'symbol-name install-list ", ")))) + (mapconcat 'symbol-name install-list ", "))))) (mapc 'package-install install-list))) ;; Delete packages, prompting if necessary. (when delete-list - (if (yes-or-no-p + (if (or + noquery + (yes-or-no-p (if (= (length delete-list) 1) (format "Delete package `%s-%s'? " (caar delete-list) @@ -1630,7 +1638,7 @@ packages marked for deletion are removed." (mapconcat (lambda (elt) (concat (car elt) "-" (cdr elt))) delete-list - ", ")))) + ", "))))) (dolist (elt delete-list) (condition-case-unless-debug err (package-delete (car elt) (cdr elt)) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 69834810d11..e000c343721 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -431,30 +431,31 @@ MATCH is the pattern that needs to be matched, of the form: (match ,symd . ,(pcase--upat (cdr qpat)))) :pcase--fail))) ;; A QPattern but not for a cons, can only go to the `else' side. - ((eq (car-safe pat) '\`) (cons :pcase--fail nil)) + ((eq (car-safe pat) '\`) '(:pcase--fail . nil)) ((and (eq (car-safe pat) 'pred) (or (member (cons 'consp (cadr pat)) pcase-mutually-exclusive-predicates) (member (cons (cadr pat) 'consp) pcase-mutually-exclusive-predicates))) - (cons :pcase--fail nil)))) + '(:pcase--fail . nil)))) (defun pcase--split-equal (elem pat) (cond ;; The same match will give the same result. ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) - (cons :pcase--succeed :pcase--fail)) + '(:pcase--succeed . :pcase--fail)) ;; A different match will fail if this one succeeds. ((and (eq (car-safe pat) '\`) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) - (cons :pcase--fail nil)) + '(:pcase--fail . nil)) ((and (eq (car-safe pat) 'pred) (symbolp (cadr pat)) - (get (cadr pat) 'side-effect-free) - (funcall (cadr pat) elem)) - (cons :pcase--succeed nil)))) + (get (cadr pat) 'side-effect-free)) + (if (funcall (cadr pat) elem) + '(:pcase--succeed . nil) + '(:pcase--fail . nil))))) (defun pcase--split-member (elems pat) ;; Based on pcase--split-equal. @@ -462,7 +463,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; The same match (or a match of membership in a superset) will ;; give the same result, but we don't know how to check it. ;; (??? - ;; (cons :pcase--succeed nil)) + ;; '(:pcase--succeed . nil)) ;; A match for one of the elements may succeed or fail. ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) nil) @@ -471,7 +472,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) - (cons :pcase--fail nil)) + '(:pcase--fail . nil)) ((and (eq (car-safe pat) 'pred) (symbolp (cadr pat)) (get (cadr pat) 'side-effect-free) @@ -479,21 +480,21 @@ MATCH is the pattern that needs to be matched, of the form: (dolist (elem elems) (unless (funcall p elem) (setq all nil))) all)) - (cons :pcase--succeed nil)))) + '(:pcase--succeed . nil)))) (defun pcase--split-pred (upat pat) ;; FIXME: For predicates like (pred (> a)), two such predicates may ;; actually refer to different variables `a'. (let (test) (cond - ((equal upat pat) (cons :pcase--succeed :pcase--fail)) + ((equal upat pat) '(:pcase--succeed . :pcase--fail)) ((and (eq 'pred (car upat)) (eq 'pred (car-safe pat)) (or (member (cons (cadr upat) (cadr pat)) pcase-mutually-exclusive-predicates) (member (cons (cadr pat) (cadr upat)) pcase-mutually-exclusive-predicates))) - (cons :pcase--fail nil)) + '(:pcase--fail . nil)) ((and (eq 'pred (car upat)) (eq '\` (car-safe pat)) (symbolp (cadr upat)) @@ -502,8 +503,8 @@ MATCH is the pattern that needs to be matched, of the form: (ignore-errors (setq test (list (funcall (cadr upat) (cadr pat)))))) (if (car test) - (cons nil :pcase--fail) - (cons :pcase--fail nil)))))) + '(nil . :pcase--fail) + '(:pcase--fail . nil)))))) (defun pcase--fgrep (vars sexp) "Check which of the symbols VARS appear in SEXP." diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 94b3c1553e5..da487e463e2 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -379,7 +379,9 @@ Return the column number after insertion." (setq width (- width shift)) (setq x (+ x shift)))) (if (stringp col-desc) - (insert (propertize label 'help-echo help-echo)) + (insert (if (get-text-property 0 'help-echo label) + label + (propertize label 'help-echo help-echo))) (apply 'insert-text-button label (cdr col-desc))) (let ((next-x (+ x pad-right width))) ;; No need to append any spaces if this is the last column. diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 3eaacd24ec8..8b019d0a785 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -307,13 +307,13 @@ This function is called, by name, directly by the C code." ;; Run handler. ;; We do this after rescheduling so that the handler function ;; can cancel its own timer successfully with cancel-timer. - (condition-case nil + (condition-case-unless-debug err ;; Timer functions should not change the current buffer. ;; If they do, all kinds of nasty surprises can happen, ;; and it can be hellish to track down their source. (save-current-buffer (apply (timer--function timer) (timer--args timer))) - (error nil)) + (error (message "Error in timer: %S" err))) (if retrigger (setf (timer--triggered timer) nil))) (error "Bogus timer event")))) diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 3e55b7c88fa..09c4969cf18 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -1,4 +1,4 @@ -;;; trace.el --- tracing facility for Emacs Lisp functions +;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*- ;; Copyright (C) 1993, 1998, 2000-2013 Free Software Foundation, Inc. @@ -38,11 +38,6 @@ ;; generation of trace output won't interfere with what you are currently ;; doing. -;; Requirement: -;; ============ -;; trace.el needs advice.el version 2.0 or later which you can get from the -;; same place from where you got trace.el. - ;; Restrictions: ;; ============= ;; - Traced subrs when called interactively will always show nil as the @@ -55,17 +50,6 @@ ;; + Macros that were expanded during compilation ;; - All the restrictions that apply to advice.el -;; Installation: -;; ============= -;; Put this file together with advice.el (version 2.0 or later) somewhere -;; into your Emacs `load-path', byte-compile it/them for efficiency, and -;; put the following autoload declarations into your .emacs -;; -;; (autoload 'trace-function "trace" "Trace a function" t) -;; (autoload 'trace-function-background "trace" "Trace a function" t) -;; -;; or explicitly load it with (require 'trace) or (load "trace"). - ;; Usage: ;; ====== ;; - To trace a function say `M-x trace-function' which will ask you for the @@ -151,18 +135,15 @@ ;;; Code: -(require 'advice) - (defgroup trace nil "Tracing facility for Emacs Lisp functions." :prefix "trace-" :group 'lisp) ;;;###autoload -(defcustom trace-buffer (purecopy "*trace-output*") +(defcustom trace-buffer "*trace-output*" "Trace output will by default go to that buffer." - :type 'string - :group 'trace) + :type 'string) ;; Current level of traced function invocation: (defvar trace-level 0) @@ -176,78 +157,111 @@ (defvar inhibit-trace nil "If non-nil, all tracing is temporarily inhibited.") -(defun trace-entry-message (function level argument-bindings) - ;; Generates a string that describes that FUNCTION has been entered at - ;; trace LEVEL with ARGUMENT-BINDINGS. - (format "%s%s%d -> %s: %s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") - (if (> level 1) " " "") - level - function - (let ((print-circle t)) - (mapconcat (lambda (binding) - (concat - (symbol-name (ad-arg-binding-field binding 'name)) - "=" - ;; do this so we'll see strings: - (prin1-to-string - (ad-arg-binding-field binding 'value)))) - argument-bindings - " ")))) - -(defun trace-exit-message (function level value) - ;; Generates a string that describes that FUNCTION has been exited at - ;; trace LEVEL and that it returned VALUE. - (format "%s%s%d <- %s: %s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") - (if (> level 1) " " "") - level - function - ;; do this so we'll see strings: - (let ((print-circle t)) (prin1-to-string value)))) - -(defun trace-make-advice (function buffer background) - ;; Builds the piece of advice to be added to FUNCTION's advice info - ;; so that it will generate the proper trace output in BUFFER - ;; (quietly if BACKGROUND is t). - (ad-make-advice - trace-advice-name nil t - `(advice - lambda () - (let ((trace-level (1+ trace-level)) - (trace-buffer (get-buffer-create ,buffer))) - (unless inhibit-trace - (with-current-buffer trace-buffer - (set (make-local-variable 'window-point-insertion-type) t) - ,(unless background '(display-buffer trace-buffer)) - (goto-char (point-max)) - ;; Insert a separator from previous trace output: - (if (= trace-level 1) (insert trace-separator)) - (insert - (trace-entry-message - ',function trace-level ad-arg-bindings)))) - ad-do-it - (unless inhibit-trace - (with-current-buffer trace-buffer - ,(unless background '(display-buffer trace-buffer)) - (goto-char (point-max)) - (insert - (trace-exit-message - ',function trace-level ad-return-value)))))))) - -(defun trace-function-internal (function buffer background) - ;; Adds trace advice for FUNCTION and activates it. - (ad-add-advice - function - (trace-make-advice function (or buffer trace-buffer) background) - 'around 'last) - (ad-activate function nil)) +(defun trace-entry-message (function level args context) + "Generate a string that describes that FUNCTION has been entered. +LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION, +and CONTEXT is a string describing the dynamic context (e.g. values of +some global variables)." + (let ((print-circle t)) + (format "%s%s%d -> %S%s\n" + (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (if (> level 1) " " "") + level + ;; FIXME: Make it so we can click the function name to jump to its + ;; definition and/or untrace it. + (cons function args) + context))) + +(defun trace-exit-message (function level value context) + "Generate a string that describes that FUNCTION has exited. +LEVEL is the trace level, VALUE value returned by FUNCTION, +and CONTEXT is a string describing the dynamic context (e.g. values of +some global variables)." + (let ((print-circle t)) + (format "%s%s%d <- %s: %S%s\n" + (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (if (> level 1) " " "") + level + function + ;; Do this so we'll see strings: + value + context))) + +(defvar trace--timer nil) + +(defun trace-make-advice (function buffer background context) + "Build the piece of advice to be added to trace FUNCTION. +FUNCTION is the name of the traced function. +BUFFER is the buffer where the trace should be printed. +BACKGROUND if nil means to display BUFFER. +CONTEXT if non-nil should be a function that returns extra info that should +be printed along with the arguments in the trace." + (lambda (body &rest args) + (let ((trace-level (1+ trace-level)) + (trace-buffer (get-buffer-create buffer)) + (ctx (funcall context))) + (unless inhibit-trace + (with-current-buffer trace-buffer + (set (make-local-variable 'window-point-insertion-type) t) + (unless (or background trace--timer + (get-buffer-window trace-buffer 'visible)) + (setq trace--timer + ;; Postpone the display to some later time, in case we + ;; can't actually do it now. + (run-with-timer 0 nil + (lambda () + (setq trace--timer nil) + (display-buffer trace-buffer))))) + (goto-char (point-max)) + ;; Insert a separator from previous trace output: + (if (= trace-level 1) (insert trace-separator)) + (insert + (trace-entry-message + function trace-level args ctx)))) + (let ((result)) + (unwind-protect + (setq result (list (apply body args))) + (unless inhibit-trace + (let ((ctx (funcall context))) + (with-current-buffer trace-buffer + (unless background (display-buffer trace-buffer)) + (goto-char (point-max)) + (insert + (trace-exit-message + function + trace-level + (if result (car result) '\!non-local\ exit\!) + ctx)))))) + (car result))))) + +(defun trace-function-internal (function buffer background context) + "Add trace advice for FUNCTION." + (advice-add + function :around + (trace-make-advice function (or buffer trace-buffer) background + (or context (lambda () ""))) + `((name . ,trace-advice-name)))) (defun trace-is-traced (function) - (ad-find-advice function 'around trace-advice-name)) + (advice-member-p trace-advice-name function)) + +(defun trace--read-args (prompt) + (cons + (intern (completing-read prompt obarray 'fboundp t)) + (when current-prefix-arg + (list + (read-buffer "Output to buffer: " trace-buffer) + (let ((exp + (let ((minibuffer-completing-symbol t)) + (read-from-minibuffer "Context expression: " + nil read-expression-map t + 'read-expression-history)))) + (lambda () + (let ((print-circle t)) + (concat " [" (prin1-to-string (eval exp t)) "]")))))))) ;;;###autoload -(defun trace-function (function &optional buffer) +(defun trace-function-foreground (function &optional buffer context) "Traces FUNCTION with trace output going to BUFFER. For every call of FUNCTION Lisp-style trace messages that display argument and return values will be inserted into BUFFER. This function generates the @@ -257,31 +271,19 @@ Do not use this to trace functions that switch buffers or do any other display oriented stuff, use `trace-function-background' instead. To untrace a function, use `untrace-function' or `untrace-all'." - (interactive - (list - (intern (completing-read "Trace function: " obarray 'fboundp t)) - (read-buffer "Output to buffer: " trace-buffer))) - (trace-function-internal function buffer nil)) + (interactive (trace--read-args "Trace function: ")) + (trace-function-internal function buffer nil context)) ;;;###autoload -(defun trace-function-background (function &optional buffer) +(defun trace-function-background (function &optional buffer context) "Traces FUNCTION with trace output going quietly to BUFFER. -When this tracing is enabled, every call to FUNCTION writes -a Lisp-style trace message (showing the arguments and return value) -into BUFFER. This function generates advice to trace FUNCTION -and activates it together with any other advice there might be. -The trace output goes to BUFFER quietly, without changing -the window or buffer configuration. - -BUFFER defaults to `trace-buffer'. +Like `trace-function-foreground' but without popping up the trace BUFFER or +changing the window configuration." + (interactive (trace--read-args "Trace function in background: ")) + (trace-function-internal function buffer t context)) -To untrace a function, use `untrace-function' or `untrace-all'." - (interactive - (list - (intern - (completing-read "Trace function in background: " obarray 'fboundp t)) - (read-buffer "Output to buffer: " trace-buffer))) - (trace-function-internal function buffer t)) +;;;###autoload +(defalias 'trace-function 'trace-function-foreground) (defun untrace-function (function) "Untraces FUNCTION and possibly activates all remaining advice. @@ -289,16 +291,14 @@ Activation is performed with `ad-update', hence remaining advice will get activated only if the advice of FUNCTION is currently active. If FUNCTION was not traced this is a noop." (interactive - (list (ad-read-advised-function "Untrace function" 'trace-is-traced))) - (when (trace-is-traced function) - (ad-remove-advice function 'around trace-advice-name) - (ad-update function))) + (list (intern (completing-read "Untrace function: " + obarray #'trace-is-traced t)))) + (advice-remove function trace-advice-name)) (defun untrace-all () "Untraces all currently traced functions." (interactive) - (ad-do-advised-functions (function) - (untrace-function function))) + (mapatoms #'untrace-function)) (provide 'trace) |