diff options
Diffstat (limited to 'lisp/emacs-lisp')
76 files changed, 6976 insertions, 6090 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index cac76d2bce1..3d03e894534 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,6 +1,6 @@ -;;; 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-2012 Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 2000-2013 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: FSF @@ -31,10 +31,6 @@ ;;; Commentary: -;; NOTE: This documentation is slightly out of date. In particular, all the -;; references to Emacs-18 are obsolete now, because it is not any longer -;; supported by this version of Advice. - ;; Advice is documented in the Emacs Lisp Manual. ;; @ Introduction: @@ -51,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 @@ -67,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. @@ -81,23 +75,12 @@ ;; - En/disablement mechanism allows the use of different "views" of advised ;; functions depending on what pieces of advice are currently en/disabled ;; - Provides manipulation mechanisms for sets of advised functions via -;; regular expressions that match advice names - -;; @ How to get Advice for Emacs-18: -;; ================================= -;; `advice18.el', a version of Advice that also works in Emacs-18 is available -;; either via anonymous ftp from `ftp.cs.buffalo.edu (128.205.32.9)' with -;; pathname `/pub/Emacs/advice18.el', or from one of the Emacs Lisp archive -;; sites, or send email to <hans@cs.buffalo.edu> and I'll mail it to you. +;; regular expressions that match advice names. ;; @ Overview, or how to read this file: ;; ===================================== -;; NOTE: This documentation is slightly out of date. In particular, all the -;; references to Emacs-18 are obsolete now, because it is not any longer -;; supported by this version of Advice. An up-to-date version will soon be -;; available as an info file (thanks to the kind help of Jack Vinson and -;; David M. Smith). Until then you can use `outline-mode' to help you read -;; this documentation (set `outline-regexp' to `";; @+"'). +;; You can use `outline-mode' to help you read this documentation (set +;; `outline-regexp' to `";; @+"'). ;; ;; The four major sections of this file are: ;; @@ -111,9 +94,6 @@ ;; @ Restrictions: ;; =============== -;; - This version of Advice only works for Emacs 19.26 and later. It uses -;; new versions of the built-in functions `fset/defalias' which are not -;; yet available in Lucid Emacs, hence, it won't work there. ;; - Advised functions/macros/subrs will only exhibit their advised behavior ;; when they are invoked via their function cell. This means that advice will ;; not work for the following: @@ -131,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: @@ -155,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) @@ -224,18 +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-19: Emacs as released by the GNU Project -;; - Lemacs: Lucid's version of Emacs with major version 19 -;; - v18: Any Emacs with major version 18 or built as an extension to that -;; (such as Epoch) -;; - v19: Any Emacs with major version 19 -;; - jwz: Jamie Zawinski - former keeper of Lemacs and creator of the optimizing -;; byte-compiler used in v19s. +;; - Emacs: Emacs as released by the GNU Project ;; - Advice: The name of this package. ;; - advices: Short for "pieces of advice". @@ -259,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. @@ -290,32 +245,31 @@ ;; `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 -;; actually compiled (with a v18 byte-compiler put the `defadvice' -;; into the body of a `defun' to accomplish proper compilation). +;; if appropriate. Only use this if the `defadvice' gets +;; actually compiled. ;; An optional <documentation-string> can be supplied to document the advice. ;; On call of the `documentation' function it will be combined with the ;; 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): @@ -354,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 @@ -367,48 +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 -;; same piece of advice across different versions of Emacs. Some subrs in a -;; v18 Emacs are functions in v19 and vice versa, but for the most part the -;; semantics remain the same, hence, the same piece of advice might be usable -;; in both Emacs versions. +;; 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). @@ -420,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): @@ -435,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, ;; @@ -454,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 @@ -464,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 @@ -490,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 @@ -501,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 @@ -523,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 @@ -531,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: @@ -548,31 +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 -;; definition will be saved, and then the advice will be activated. When a -;; file is loaded in a v18 Emacs the functions/macros it defines are also -;; defined with calls to `defun/defmacro'. Hence, we can forward advise -;; functions/macros which will be defined later during a load/autoload of some -;; file (for compiled files generated by jwz's byte-compiler in a v19 Emacs -;; this is slightly more complicated but the basic idea is the same). +;; 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 - @@ -580,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 @@ -588,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) @@ -608,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: @@ -647,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 @@ -674,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 @@ -694,32 +629,30 @@ ;; specified as disabled) and all other currently enabled pieces of advice to ;; construct an advised definition and an identifying cache-id and makes them ;; part of the `defadvice' expansion which will then be compiled by the -;; byte-compiler (to ensure that in a v18 emacs you have to put the -;; `defadvice' inside a `defun' to get it compiled and then you have to call -;; that compiled `defun' in order to actually execute the `defadvice'). When -;; the file with the compiled, preactivating `defadvice' gets loaded the +;; 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. @@ -731,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 @@ -754,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': ;; ================================================= @@ -788,12 +711,11 @@ ;; @@ 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 -;; is to define file load hooks for files that do not provide such hooks -;; (v19s already come with a general file-load-hook mechanism, v18s don't). +;; 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 ;; `file-x-last-fn'. Then we can define the following advice: @@ -804,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'. @@ -819,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: @@ -835,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. @@ -895,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: @@ -1023,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 @@ -1073,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 @@ -1106,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) @@ -1156,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 @@ -1185,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!" @@ -1297,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-") @@ -1309,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) @@ -1318,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: ;; @@ -1338,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." @@ -1392,7 +1252,7 @@ ;; (ad-activate 'fie) ;; fie ;; -;; (eq cached-definition (symbol-function 'fie)) +;; (eq cached-definition (symbol-function 'ad-Advice-fie)) ;; t ;; ;; (fie 2) @@ -1400,8 +1260,8 @@ ;; ;; 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 have to put the -;; `defadvice' inside a `defun' because the v18 compiler does not compile +;; 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, ;; ;; (defun fg-defadvice-fum () @@ -1442,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") ...) @@ -1466,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: ;; @@ -1475,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) @@ -1483,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. ;; @@ -1496,10 +1354,7 @@ ;; if one advises a subr such as `eval-region' which then gets redefined by ;; some package (e.g., edebug) into a function with different argument names, ;; then a piece of advice written for `eval-region' that was written with -;; the subr arguments in mind will break. Similar situations arise when one -;; switches between major Emacs versions, e.g., certain subrs in v18 are -;; functions in v19 and vice versa. Also, in v19s subr argument lists -;; are available and will be used, while they are not available in v18. +;; the subr arguments in mind will break. ;; ;; Argument access text macros allow one to access arguments of an advised ;; function in a portable way without having to worry about all these @@ -1740,13 +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. +(eval-when-compile (require 'cl-lib)) ;; @@ Variable definitions: ;; ======================== @@ -1812,84 +1663,6 @@ generates a copy of TREE." (funcall fUnCtIoN tReE)) (t tReE))) -;; this is just faster than `ad-substitute-tree': -(defun ad-copy-tree (tree) - "Return a copy of the list structure of TREE." - (cond ((consp tree) - (cons (ad-copy-tree (car tree)) - (ad-copy-tree (cdr tree)))) - (t tree))) - -(defmacro ad-dolist (varform &rest body) - "A Common-Lisp-style dolist iterator with the following syntax: - - (ad-dolist (VAR INIT-FORM [RESULT-FORM]) - BODY-FORM...) - -which will iterate over the list yielded by INIT-FORM binding VAR to the -current head at every iteration. If RESULT-FORM is supplied its value will -be returned at the end of the iteration, nil otherwise. The iteration can be -exited prematurely with `(ad-do-return [VALUE])'." - (let ((expansion - `(let ((ad-dO-vAr ,(car (cdr varform))) - ,(car varform)) - (while ad-dO-vAr - (setq ,(car varform) (car ad-dO-vAr)) - ,@body - ;;work around a backquote bug: - ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong - ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar))) - ,'(setq ad-dO-vAr (cdr ad-dO-vAr))) - ,(car (cdr (cdr varform)))))) - ;;ok, this wastes some cons cells but only during compilation: - (if (catch 'contains-return - (ad-substitute-tree - (function (lambda (subtree) - (cond ((eq (car-safe subtree) 'ad-dolist)) - ((eq (car-safe subtree) 'ad-do-return) - (throw 'contains-return t))))) - 'identity body) - nil) - `(catch 'ad-dO-eXiT ,expansion) - expansion))) - -(defmacro ad-do-return (value) - `(throw 'ad-dO-eXiT ,value)) - -(if (not (get 'ad-dolist 'lisp-indent-hook)) - (put 'ad-dolist 'lisp-indent-hook 1)) - - -;; @@ 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: ;; ========================== @@ -1903,7 +1676,7 @@ exited prematurely with `(ad-do-return [VALUE])'." ;; (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 @@ -1924,19 +1697,15 @@ exited prematurely with `(ad-do-return [VALUE])'." ad-advised-functions))) (defmacro ad-do-advised-functions (varform &rest body) - "`ad-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)." - `(ad-dolist (,(car varform) - ad-advised-functions - ,(car (cdr varform))) - (setq ,(car varform) (intern (car ,(car varform)))) - ,@body)) - -(if (not (get 'ad-do-advised-functions 'lisp-indent-hook)) - (put 'ad-do-advised-functions 'lisp-indent-hook 1)) + (declare (indent 1)) + `(dolist (,(car varform) ad-advised-functions) + (setq ,(car varform) (intern (car ,(car varform)))) + ,@body)) (defun ad-get-advice-info (function) (get function 'ad-advice-info)) @@ -1944,16 +1713,23 @@ 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) - `(ad-copy-tree (get ,function 'ad-advice-info))) + `(copy-tree (get ,function 'ad-advice-info))) (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. @@ -1993,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) @@ -2017,13 +1792,10 @@ 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." - (ad-dolist (advice (ad-get-advice-info-field function class)) - (if (ad-advice-enabled advice) (ad-do-return t)))) + (cl-dolist (advice (ad-get-advice-info-field function class)) + (if (ad-advice-enabled advice) (cl-return t)))) (defun ad-has-redefining-advice (function) "True if FUNCTION's advice info defines at least 1 redefining advice. @@ -2036,14 +1808,14 @@ 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) - (ad-dolist (class ad-advice-classes nil) + (cl-dolist (class ad-advice-classes) (if (ad-get-advice-info-field function class) - (ad-do-return t))))) + (cl-return t))))) (defun ad-get-enabled-advices (function class) "Return the list of enabled advices of FUNCTION in CLASS." (let (enabled-advices) - (ad-dolist (advice (ad-get-advice-info-field function class)) + (dolist (advice (ad-get-advice-info-field function class)) (if (ad-advice-enabled advice) (push advice enabled-advices))) (reverse enabled-advices))) @@ -2052,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)) - -(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))) - - -;; @@ 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'. +(defalias 'ad-activate-internal 'ad-activate) -(defun ad-make-origname (function) - "Make name to be used to call the original FUNCTION." - (intern (format "ad-Orig-%s" function))) +(defun ad-make-advicefunname (function) + "Make name to be used to call the assembled advice function." + (intern (format "ad-Advice-%s" function))) -(defmacro ad-get-orig-definition (function) - `(let ((origname (ad-get-advice-info-field ,function 'origname))) - (if (fboundp origname) - (symbol-function origname)))) +(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) -(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: @@ -2139,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)))) @@ -2148,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)) - (ad-do-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 Lemacs' `completing-read'..... - (funcall ad-pReDiCaTe (intern (car function)))))) + (lambda (function) + (funcall predicate (intern (car function))))) t))) (if (equal function "") (if (ad-is-advised default) @@ -2184,9 +1906,9 @@ be returned on empty input (defaults to the first non-empty advice class of FUNCTION)." (setq default (or default - (ad-dolist (class ad-advice-classes) + (cl-dolist (class ad-advice-classes) (if (ad-get-advice-info-field function class) - (ad-do-return class))) + (cl-return class))) (error "ad-read-advice-class: `%s' has no advices" function))) (let ((class (completing-read (format "%s (default %s): " (or prompt "Class") default) @@ -2255,18 +1977,18 @@ NAME can be a symbol or a regular expression matching part of an advice name. If CLASS is `any' all valid advice classes will be checked." (if (ad-is-advised function) (let (found-advice) - (ad-dolist (advice-class ad-advice-classes) + (cl-dolist (advice-class ad-advice-classes) (if (or (eq class 'any) (eq advice-class class)) (setq found-advice - (ad-dolist (advice (ad-get-advice-info-field + (cl-dolist (advice (ad-get-advice-info-field function advice-class)) (if (or (and (stringp name) (string-match name (symbol-name (ad-advice-name advice)))) (eq name (ad-advice-name advice))) - (ad-do-return advice))))) - (if found-advice (ad-do-return found-advice)))))) + (cl-return advice))))) + (if found-advice (cl-return found-advice)))))) (defun ad-enable-advice-internal (function class name flag) "Set enable FLAG of FUNCTION's advices in CLASS matching NAME. @@ -2277,10 +1999,10 @@ considered. The number of changed advices will be returned (or nil if FUNCTION was not advised)." (if (ad-is-advised function) (let ((matched-advices 0)) - (ad-dolist (advice-class ad-advice-classes) + (dolist (advice-class ad-advice-classes) (if (or (eq class 'any) (eq advice-class class)) - (ad-dolist (advice (ad-get-advice-info-field - function advice-class)) + (dolist (advice (ad-get-advice-info-field + function advice-class)) (cond ((or (and (stringp name) (string-match name (symbol-name (ad-advice-name advice)))) @@ -2385,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)) @@ -2418,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)) @@ -2441,12 +2157,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation." ;;"non-nil if DEFINITION is a piece of advice." `(eq (car-safe ,definition) 'advice)) -;; Emacs/Lemacs cross-compatibility -;; (compiled-function-p is an obsolete function in Emacs): -(if (and (not (fboundp 'byte-code-function-p)) - (fboundp 'compiled-function-p)) - (ad-safe-fset 'byte-code-function-p 'compiled-function-p)) - (defmacro ad-compiled-p (definition) "Return non-nil if DEFINITION is a compiled byte-code object." `(or (byte-code-function-p ,definition) @@ -2469,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)) @@ -2484,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)) @@ -2507,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." @@ -2522,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. @@ -2555,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." @@ -2566,30 +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)))))) - -(defun ad-prognify (forms) - (cond ((<= (length forms) 1) - (car forms)) - (t (cons 'progn forms)))) + "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: ;; ============================= @@ -2701,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) @@ -2727,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)) @@ -2780,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))) @@ -2794,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 @@ -2810,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: ;; =========================================== @@ -2833,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)) @@ -2849,27 +2529,24 @@ 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)) - (ad-dolist (class ad-advice-classes) - (ad-dolist (advice (ad-get-enabled-advices function class)) + (dolist (class ad-advice-classes) + (dolist (advice (ad-get-enabled-advices function class)) (setq advice-docstring (ad-make-single-advice-docstring advice class style)) (if advice-docstring @@ -2878,37 +2555,35 @@ 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: ;; ======================================================== (defun ad-advised-arglist (function) "Find first defined arglist in FUNCTION's redefining advices." - (ad-dolist (advice (append (ad-get-enabled-advices function 'before) + (cl-dolist (advice (append (ad-get-enabled-advices function 'before) (ad-get-enabled-advices function 'around) (ad-get-enabled-advices function 'after))) (let ((arglist (ad-arglist (ad-advice-definition advice)))) (if arglist ;; We found the first one, use it: - (ad-do-return arglist))))) + (cl-return arglist))))) (defun ad-advised-interactive-form (function) "Find first interactive form in FUNCTION's redefining advices." - (ad-dolist (advice (append (ad-get-enabled-advices function 'before) + (cl-dolist (advice (append (ad-get-enabled-advices function 'before) (ad-get-enabled-advices function 'around) (ad-get-enabled-advices function 'after))) (let ((interactive-form (ad-interactive-form (ad-advice-definition advice)))) (if interactive-form ;; We found the first one, use it: - (ad-do-return interactive-form))))) + (cl-return interactive-form))))) ;; @@@ Putting it all together: ;; ============================ @@ -2918,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 @@ -2985,71 +2614,67 @@ 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." - - (let (before-forms around-form around-form-protected after-forms definition) - (ad-dolist (advice befores) - (cond ((and (ad-advice-protected advice) - before-forms) - (setq before-forms - `((unwind-protect - ,(ad-prognify before-forms) - ,@(ad-body-forms - (ad-advice-definition advice)))))) - (t (setq before-forms - (append before-forms - (ad-body-forms (ad-advice-definition advice))))))) - - (setq around-form `(setq ad-return-value ,orig)) - (ad-dolist (advice (reverse arounds)) - ;; If any of the around advices is protected then we - ;; protect the complete around advice onion: - (if (ad-advice-protected advice) - (setq around-form-protected t)) - (setq around-form - (ad-substitute-tree - (function (lambda (form) (eq form 'ad-do-it))) - (function (lambda (form) around-form)) - (ad-prognify (ad-body-forms (ad-advice-definition advice)))))) + ;; The ad-do-it call should always have the right number of arguments, + ;; but the compiler might signal a bogus warning because it checks the call + ;; against the advertised calling convention. + (let ((around-form `(setq ad-return-value (with-no-warnings ,orig))) + before-forms around-form-protected after-forms definition) + (dolist (advice befores) + (cond ((and (ad-advice-protected advice) + before-forms) + (setq before-forms + `((unwind-protect + ,(macroexp-progn before-forms) + ,@(ad-body-forms + (ad-advice-definition advice)))))) + (t (setq before-forms + (append before-forms + (ad-body-forms (ad-advice-definition advice))))))) + + (dolist (advice (reverse arounds)) + ;; If any of the around advices is protected then we + ;; protect the complete around advice onion: + (if (ad-advice-protected advice) + (setq around-form-protected t)) + (setq around-form + (ad-substitute-tree + (lambda (form) (eq form 'ad-do-it)) + (lambda (_form) around-form) + (macroexp-progn (ad-body-forms (ad-advice-definition advice)))))) (setq after-forms (if (and around-form-protected before-forms) `((unwind-protect - ,(ad-prognify before-forms) + ,(macroexp-progn before-forms) ,around-form)) (append before-forms (list around-form)))) - (ad-dolist (advice afters) - (cond ((and (ad-advice-protected advice) - after-forms) - (setq after-forms - `((unwind-protect - ,(ad-prognify after-forms) - ,@(ad-body-forms - (ad-advice-definition advice)))))) - (t (setq after-forms - (append after-forms - (ad-body-forms (ad-advice-definition advice))))))) + (dolist (advice afters) + (cond ((and (ad-advice-protected advice) + after-forms) + (setq after-forms + `((unwind-protect + ,(macroexp-progn after-forms) + ,@(ad-body-forms + (ad-advice-definition advice)))))) + (t (setq after-forms + (append after-forms + (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))) @@ -3061,7 +2686,7 @@ should be modified. The assembled function will be returned." (ad-body-forms (ad-advice-definition advice)))) (ad-get-enabled-advices function hook-name)))) (if hook-forms - (ad-prognify (apply 'append hook-forms))))) + (macroexp-progn (apply 'append hook-forms))))) ;; @@ Caching: @@ -3146,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)))))) @@ -3171,11 +2796,11 @@ advised definition from scratch." (nth 2 cache-id))))) (defun ad-verify-cache-class-id (cache-class-id advices) - (ad-dolist (advice advices (null cache-class-id)) + (cl-dolist (advice advices (null cache-class-id)) (if (ad-advice-enabled advice) (if (eq (car cache-class-id) (ad-advice-name advice)) (setq cache-class-id (cdr cache-class-id)) - (ad-do-return nil))))) + (cl-return nil))))) ;; There should be a way to monitor if and why a cache verification failed ;; in order to determine whether a certain preactivation could be used or @@ -3201,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) @@ -3241,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 @@ -3258,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: @@ -3357,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 @@ -3407,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: @@ -3459,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) @@ -3491,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))))) @@ -3517,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)))) @@ -3532,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)))) @@ -3614,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) @@ -3633,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 @@ -3659,18 +3195,20 @@ 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] BODY...)" - (declare (doc-string 3)) + (declare (doc-string 3) + (debug (&define name ;; thing being advised. + (name ;; class is [&or "before" "around" "after" + ;; "activation" "deactivation"] + name ;; name of advice + &rest sexp ;; optional position and flags + ) + [&optional stringp] + [&optional ("interactive" interactive)] + def-body))) (if (not (ad-name-p function)) (error "defadvice: Invalid function name: %s" function)) (let* ((class (car args)) @@ -3706,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: @@ -3739,6 +3272,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) For any members of FUNCTIONS that are not currently advised the rebinding will be a noop. Any modifications done to the definitions of FUNCTIONS will be undone on exit of this macro." + (declare (indent 1)) (let* ((index -1) ;; Make let-variables to store current definitions: (current-bindings @@ -3755,67 +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)))))) - -(if (not (get 'ad-with-originals 'lisp-indent-hook)) - (put 'ad-with-originals 'lisp-indent-hook 1)) - + (mapcar (lambda (function) + (setq index (1+ index)) + `(fset ',function + ,(car (nth index current-bindings)))) + functions)))))) -;; @@ Advising `documentation': -;; ============================ -;; Use the advice mechanism to advise `documentation' to make it -;; generate proper documentation strings for advised definitions: ;; @@ 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/authors.el b/lisp/emacs-lisp/authors.el index 6c70642ba83..270badd53cb 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -1,6 +1,6 @@ ;;; authors.el --- utility for maintaining Emacs's AUTHORS file -*-coding: utf-8 -*- -;; Copyright (C) 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 2000-2013 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: Kim F. Storm <storm@cua.dk> @@ -295,6 +295,14 @@ Changes to files matching one of the regexps in this list are not listed.") "calc/INSTALL" "calc/Makefile" "vms-pp.trans" "_emacs" "batcomp.com" "notes/cpp" ; admin/ "emacsver.texi.in" + "vpath.sed" + "Cocoa/Emacs.base/Contents/Info.plist" + "Cocoa/Emacs.base/Contents/Resources/English.lproj/InfoPlist.strings" + "GNUstep/Emacs.base/Resources/Info-gnustep.plist" + "GNUstep/Emacs.base/Resources/Emacs.desktop" + "Cocoa/Emacs.base/Contents/Resources/English.lproj" + ;; Only existed briefly, then deleted: + "coccinelle/overlay.cocci" "coccinelle/symbol.cocci" ;; MH-E stuff not in Emacs: "import-emacs" "release-utils" ;; Erc stuff not in Emacs: @@ -540,6 +548,7 @@ Changes to files in this list are not listed.") "makedist.bat" "makefile.def" "makefile.nt" + "ns.mk" "debug.bat.in" "emacs.bat.in" ".gdbinit-union" "alloca.s" @@ -553,15 +562,17 @@ Changes to files in this list are not listed.") "ymakefile" "permute-index" "index.perm" "ibmrs6000.inp" - "b2m.c" "b2m.1" "b2m.pl" + "b2m.c" "b2m.1" "b2m.pl" "rcs-checkin.1" "emacs.bash" "emacs.csh" "ms-kermit" "emacs.ico" "emacs21.ico" + "emacs.py" "emacs2.py" "emacs3.py" "BABYL" "LPF" "LEDIT" "OTHER.EMACSES" "emacs16_mac.png" "emacs24_mac.png" "emacs256_mac.png" "emacs32_mac.png" "emacs48_mac.png" "emacs512_mac.png" "revdiff" ; admin/ + "vcdiff" "rcs-checkin" "tindex.pl" "mainmake" "sed1.inp" "sed2.inp" "sed3.inp" ; msdos/ "mac-fix-env.m" ;; Deleted vms stuff: @@ -580,6 +591,7 @@ in the repository.") ("s/windowsnt.h" . "s/ms-w32.h") ("s/ms-w32.h" . "inc/ms-w32.h") ("winnt.el" . "w32-fns.el") + ("emacs.manifest" . "emacs-x86.manifest") ("config.emacs" . "configure") ("configure.in" . "configure.ac") ("config.h.dist" . "config.in") @@ -616,6 +628,8 @@ in the repository.") ("build-install" . "build-ins.in") ("build-install.in" . "build-ins.in") ("unidata/Makefile" . "unidata/Makefile.in") + ("move-if-change" . "build-aux/move-if-change") + ("update-subdirs" . "build-aux/update-subdirs") ;; Not renamed, but we only have the latter in the Emacs repo. ("trampver.texi.in" . "trampver.texi") ("e/eterm" . "e/eterm-color") diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index e6e2d1e60e0..dbb4a239f02 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,6 +1,6 @@ ;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- -;; Copyright (C) 1991-1997, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1991-1997, 2001-2013 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Keywords: maint @@ -52,7 +52,10 @@ FormFeed character.") (defvar generated-autoload-load-name nil "Load name for `autoload' statements generated from autoload cookies. -If nil, this defaults to the file name, sans extension.") +If nil, this defaults to the file name, sans extension. +Typically, you need to set this when the directory containing the file +is not in `load-path'. +This also affects the generated cus-load.el file.") ;;;###autoload (put 'generated-autoload-load-name 'safe-local-variable 'stringp) @@ -153,7 +156,7 @@ expression, in which case we want to handle forms differently." easy-mmode-define-minor-mode define-minor-mode cl-defun defun* cl-defmacro defmacro* define-overloadable-function)) - (let* ((macrop (memq car '(defmacro defmacro*))) + (let* ((macrop (memq car '(defmacro cl-defmacro defmacro*))) (name (nth 1 form)) (args (pcase car ((or `defun `defmacro diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 1f00677cd00..4481bc9ae61 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -1,6 +1,6 @@ ;;; avl-tree.el --- balanced binary trees, AVL-trees -;; Copyright (C) 1995, 2007-2012 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2007-2013 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index 870127ceac8..2dc84e9ddfb 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -1,6 +1,7 @@ ;;; backquote.el --- implement the ` Lisp construct -;; Copyright (C) 1990, 1992, 1994, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1990, 1992, 1994, 2001-2013 Free Software Foundation, +;; Inc. ;; Author: Rick Sladkey <jrs@world.std.com> ;; Maintainer: FSF diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 9029c81f279..c97b33f4e7d 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -1,6 +1,6 @@ ;;; benchmark.el --- support for benchmarking code -;; Copyright (C) 2003-2012 Free Software Foundation, Inc. +;; Copyright (C) 2003-2013 Free Software Foundation, Inc. ;; Author: Dave Love <fx@gnu.org> ;; Keywords: lisp, extensions diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 03d55f376af..86d72fef9b5 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -1,6 +1,6 @@ ;;; bindat.el --- binary data structure packing and unpacking. -;; Copyright (C) 2002-2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Kim F. Storm <storm@cua.dk> ;; Assignment name: struct.el diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index a4c3e8aac4e..7375c2176ba 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,6 +1,6 @@ ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*- -;; Copyright (C) 1991, 1994, 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1994, 2000-2013 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> @@ -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 d1382f42b19..8f0999b2f80 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -1,6 +1,6 @@ ;;; byte-run.el --- byte-compiler support for inlining -*- lexical-binding: t -*- -;; Copyright (C) 1992, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> @@ -79,10 +79,17 @@ The return value of this function is not used." (list 'quote f) (list 'quote arglist) (list 'quote when)))) (list 'obsolete #'(lambda (f _args new-name when) - `(make-obsolete ',f ',new-name ,when))) + (list 'make-obsolete + (list 'quote f) (list 'quote new-name) (list 'quote when)))) (list 'compiler-macro - #'(lambda (f _args compiler-function) - `(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)))) @@ -115,7 +122,7 @@ and the VALUES and should return the code to use to set this property.") (defalias 'defmacro (cons 'macro - #'(lambda (name arglist &optional docstring decl &rest body) + #'(lambda (name arglist &optional docstring &rest body) "Define NAME as a macro. When the macro is called, as in (NAME ARGS...), the function (lambda ARGLIST BODY...) is applied to @@ -124,32 +131,38 @@ and the result should be a form to be evaluated instead of the original. DECL is a declaration, optional, of the form (declare DECLS...) where DECLS is a list of elements of the form (PROP . VALUES). These are interpreted according to `macro-declarations-alist'. -The return value is undefined." - (if (stringp docstring) nil - (if decl (setq body (cons decl body))) - (setq decl docstring) - (setq docstring nil)) - (if (or (null decl) (eq 'declare (car-safe decl))) nil - (setq body (cons decl body)) - (setq decl nil)) - (if (null body) (setq body '(nil))) - (if docstring (setq body (cons docstring body))) - ;; Can't use backquote because it's not defined yet! - (let* ((fun (list 'function (cons 'lambda (cons arglist body)))) - (def (list 'defalias - (list 'quote name) - (list 'cons ''macro fun))) - (declarations - (mapcar - #'(lambda (x) - (let ((f (cdr (assq (car x) macro-declarations-alist)))) - (if f (apply (car f) name arglist (cdr x)) - (message "Warning: Unknown macro property %S in %S" - (car x) name)))) - (cdr decl)))) - (if declarations - (cons 'prog1 (cons def declarations)) - def))))) +The return value is undefined. + +\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" + ;; We can't just have `decl' as an &optional argument, because we need + ;; to distinguish + ;; (defmacro foo (arg) (bar) nil) + ;; from + ;; (defmacro foo (arg) (bar)). + (let ((decls (cond + ((eq (car-safe docstring) 'declare) + (prog1 (cdr docstring) (setq docstring nil))) + ((and (stringp docstring) + (eq (car-safe (car body)) 'declare)) + (prog1 (cdr (car body)) (setq body (cdr body))))))) + (if docstring (setq body (cons docstring body)) + (if (null body) (setq body '(nil)))) + ;; Can't use backquote because it's not defined yet! + (let* ((fun (list 'function (cons 'lambda (cons arglist body)))) + (def (list 'defalias + (list 'quote name) + (list 'cons ''macro fun))) + (declarations + (mapcar + #'(lambda (x) + (let ((f (cdr (assq (car x) macro-declarations-alist)))) + (if f (apply (car f) name arglist (cdr x)) + (message "Warning: Unknown macro property %S in %S" + (car x) name)))) + decls))) + (if declarations + (cons 'prog1 (cons def declarations)) + def)))))) ;; Now that we defined defmacro we can use it! (defmacro defun (name arglist &optional docstring &rest body) @@ -171,7 +184,8 @@ The return value is undefined. (let ((decls (cond ((eq (car-safe docstring) 'declare) (prog1 (cdr docstring) (setq docstring nil))) - ((eq (car-safe (car body)) 'declare) + ((and (stringp docstring) + (eq (car-safe (car body)) 'declare)) (prog1 (cdr (car body)) (setq body (cdr body))))))) (if docstring (setq body (cons docstring body)) (if (null body) (setq body '(nil)))) @@ -186,7 +200,13 @@ The return value is undefined. (memq (car x) ;C.f. cl-do-proclaim. '(special inline notinline optimize warn))) (push (list 'declare x) - (if (stringp docstring) (cdr body) body)) + (if (stringp docstring) + (if (eq (car-safe (cadr body)) 'interactive) + (cddr body) + (cdr body)) + (if (eq (car-safe (car body)) 'interactive) + (cdr body) + body))) nil) (t (message "Warning: Unknown defun property `%S' in %S" (car x) name))))) @@ -232,7 +252,8 @@ The return value is undefined. ;; fns))) (defmacro defsubst (name arglist &rest body) - "Define an inline function. The syntax is just like that of `defun'." + "Define an inline function. The syntax is just like that of `defun'. +\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" (declare (debug defun) (doc-string 3)) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) @@ -253,7 +274,9 @@ convention was modified." advertised-signature-table)) (defun make-obsolete (obsolete-name current-name &optional when) - "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. + "Make the byte-compiler warn that function OBSOLETE-NAME is obsolete. +OBSOLETE-NAME should be a function name or macro name (a symbol). + The warning will say that CURRENT-NAME should be used instead. If CURRENT-NAME is a string, that is the `use instead' message \(it should end with a period, and not start with a capital). @@ -312,7 +335,7 @@ This uses `defvaralias' and `make-obsolete-variable' (which see). See the Info node `(elisp)Variable Aliases' for more details. If CURRENT-NAME is a defcustom (more generally, any variable -where OBSOLETE-NAME may be set, e.g. in a .emacs file, before the +where OBSOLETE-NAME may be set, e.g. in an init file, before the alias is defined), then the define-obsolete-variable-alias statement should be evaluated before the defcustom, if user customizations are to be respected. The simplest way to achieve @@ -356,7 +379,7 @@ obsolete." (defmacro dont-compile (&rest body) "Like `progn', but the body always runs interpreted (not compiled). If you think you need this, you're probably making a mistake somewhere." - (declare (debug t) (indent 0)) + (declare (debug t) (indent 0) (obsolete nil "24.4")) (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body))))) @@ -370,19 +393,19 @@ 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) "Like `progn', but prevents compiler warnings in the body." + (declare (indent 0)) ;; The implementation for the interpreter is basically trivial. (car (last body))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 10bc37c6dcd..e603f76f41d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1,7 +1,7 @@ ;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*- -;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2013 Free Software +;; Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> @@ -289,10 +289,11 @@ Elements of the list may be: obsolete obsolete variables and functions. noruntime functions that may not be defined at runtime (typically defined only under `eval-when-compile'). - cl-functions calls to runtime functions from the CL package (as - distinguished from macros and aliases). + cl-functions calls to runtime functions (as distinguished from macros and + aliases) from the old CL package (not the newer cl-lib). interactive-only commands that normally shouldn't be called from Lisp code. + lexical global/dynamic variables lacking a prefix. make-local calls to make-variable-buffer-local that may be incorrect. mapcar mapcar called for effect. constants let-binding of, or assignment to, constants/nonvariables. @@ -410,6 +411,9 @@ specify different fields to sort on." (defvar byte-compile-bound-variables nil "List of dynamic variables bound in the context of the current form. This list lives partly on the stack.") +(defvar byte-compile-lexical-variables nil + "List of variables that have been treated as lexical. +Filled in `cconv-analyse-form' but initialized and consulted here.") (defvar byte-compile-const-variables nil "List of variables declared as constants during compilation of this file.") (defvar byte-compile-free-references) @@ -419,8 +423,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 +433,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 +746,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)))) @@ -846,7 +863,7 @@ CONST2 may be evaluated multiple times." (defun byte-compile-cl-file-p (file) "Return non-nil if FILE is one of the CL files." (and (stringp file) - (string-match "^cl\\>" (file-name-nondirectory file)))) + (string-match "^cl\\.el" (file-name-nondirectory file)))) (defun byte-compile-eval (form) "Eval FORM and mark the functions defined therein. @@ -863,25 +880,14 @@ 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 - ((symbolp s) - (unless (memq s old-autoloads) - (push s byte-compile-noruntime-functions))) ((and (consp s) (eq t (car s))) (push (cdr s) old-autoloads)) - ((and (consp s) (eq 'autoload (car s))) - (push (cdr s) byte-compile-noruntime-functions))))))) + ((and (consp s) (memq (car s) '(autoload defun))) + (unless (memq (cdr s) old-autoloads) + (push (cdr s) byte-compile-noruntime-functions)))))))) ;; Go through current-load-list for the locally defined funs. (let (old-autoloads) (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig))) @@ -1005,17 +1011,29 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defvar byte-compile-root-dir nil "Directory relative to which file names in error messages are written.") +;; FIXME: We should maybe extend abbreviate-file-name with an optional DIR +;; argument to try and use a relative file-name. +(defun byte-compile-abbreviate-file (file &optional dir) + (let ((f1 (abbreviate-file-name file)) + (f2 (file-relative-name file dir))) + (if (< (length f2) (length f1)) f2 f1))) + ;; This is used as warning-prefix for the compiler. ;; It is always called with the warnings buffer current. (defun byte-compile-warning-prefix (level entry) (let* ((inhibit-read-only t) (dir (or byte-compile-root-dir default-directory)) (file (cond ((stringp byte-compile-current-file) - (format "%s:" (file-relative-name + (format "%s:" (byte-compile-abbreviate-file byte-compile-current-file dir))) ((bufferp byte-compile-current-file) (format "Buffer %s:" (buffer-name byte-compile-current-file))) + ;; We might be simply loading a file that + ;; contains explicit calls to byte-compile functions. + ((stringp load-file-name) + (format "%s:" (byte-compile-abbreviate-file + load-file-name dir))) (t ""))) (pos (if (and byte-compile-current-file (integerp byte-compile-read-position)) @@ -1096,8 +1114,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) @@ -1111,18 +1128,12 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." "Warn that SYMBOL (a variable or function) is obsolete." (when (byte-compile-warning-enabled-p 'obsolete) (let* ((funcp (get symbol 'byte-obsolete-info)) - (obsolete (or funcp (get symbol 'byte-obsolete-variable))) - (instead (car obsolete)) - (asof (nth 2 obsolete))) + (msg (macroexp--obsolete-warning + symbol + (or funcp (get symbol 'byte-obsolete-variable)) + (if funcp "function" "variable")))) (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) - (byte-compile-warn "`%s' is an obsolete %s%s%s" symbol - (if funcp "function" "variable") - (if asof (concat " (as of " asof ")") "") - (cond ((stringp instead) - (concat "; " instead)) - (instead - (format "; use `%s' instead." instead)) - (t "."))))))) + (byte-compile-warn "%s" msg))))) (defun byte-compile-report-error (error-info) "Report Lisp error in compilation. ERROR-INFO is the error data." @@ -1481,6 +1492,7 @@ extra args." (byte-compile--outbuffer nil) (byte-compile-function-environment nil) (byte-compile-bound-variables nil) + (byte-compile-lexical-variables nil) (byte-compile-const-variables nil) (byte-compile-free-references nil) (byte-compile-free-assignments nil) @@ -1587,7 +1599,9 @@ that already has a `.elc' file." (setq directories (nconc directories (list source)))) ;; It is an ordinary file. Decide whether to compile it. (if (and (string-match emacs-lisp-file-regexp source) + ;; The next 2 tests avoid compiling lock files (file-readable-p source) + (not (string-match "\\`\\.#" file)) (not (auto-save-file-name-p source)) (not (string-equal dir-locals-file (file-name-nondirectory source)))) @@ -1668,6 +1682,9 @@ If compilation is needed, this functions returns the result of (load (if (file-exists-p dest) dest filename))) 'no-byte-compile))) +(defvar byte-compile-level 0 ; bug#13787 + "Depth of a recursive byte compilation.") + ;;;###autoload (defun byte-compile-file (filename &optional load) "Compile a file of Lisp code named FILENAME into a file of byte code. @@ -1710,7 +1727,13 @@ The value is non-nil if there were no errors, nil if errors." (setq target-file (byte-compile-dest-file filename)) (setq byte-compile-dest-file target-file) (with-current-buffer - (setq input-buffer (get-buffer-create " *Compiler Input*")) + ;; It would be cleaner to use a temp buffer, but if there was + ;; an error, we leave this buffer around for diagnostics. + ;; Its name is documented in the lispref. + (setq input-buffer (get-buffer-create + (concat " *Compiler Input*" + (if (zerop byte-compile-level) "" + (format "-%s" byte-compile-level))))) (erase-buffer) (setq buffer-file-coding-system nil) ;; Always compile an Emacs Lisp file as multibyte @@ -1741,6 +1764,9 @@ The value is non-nil if there were no errors, nil if errors." ;; There may be a file local variable setting (bug#10419). (setq buffer-read-only nil filename buffer-file-name)) + ;; Don't inherit lexical-binding from caller (bug#12938). + (unless (local-variable-p 'lexical-binding) + (setq-local lexical-binding nil)) ;; Set the default directory, in case an eval-when-compile uses it. (setq default-directory (file-name-directory filename))) ;; Check if the file's local variables explicitly specify not to @@ -1748,11 +1774,11 @@ The value is non-nil if there were no errors, nil if errors." (if (with-current-buffer input-buffer no-byte-compile) (progn ;; (message "%s not compiled because of `no-byte-compile: %s'" - ;; (file-relative-name filename) + ;; (byte-compile-abbreviate-file filename) ;; (with-current-buffer input-buffer no-byte-compile)) (when (file-exists-p target-file) (message "%s deleted because of `no-byte-compile: %s'" - (file-relative-name target-file) + (byte-compile-abbreviate-file target-file) (buffer-local-value 'no-byte-compile input-buffer)) (condition-case nil (delete-file target-file) (error nil))) ;; We successfully didn't compile this file. @@ -1765,7 +1791,8 @@ The value is non-nil if there were no errors, nil if errors." ;; within byte-compile-from-buffer lingers in that buffer. (setq output-buffer (save-current-buffer - (byte-compile-from-buffer input-buffer))) + (let ((byte-compile-level (1+ byte-compile-level))) + (byte-compile-from-buffer input-buffer)))) (if byte-compiler-error-flag nil (when byte-compile-verbose @@ -1785,8 +1812,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 @@ -1873,7 +1898,10 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-close-variables (with-current-buffer (setq byte-compile--outbuffer - (get-buffer-create " *Compiler Output*")) + (get-buffer-create + (concat " *Compiler Output*" + (if (<= byte-compile-level 1) "" + (format "-%s" (1- byte-compile-level)))))) (set-buffer-multibyte t) (erase-buffer) ;; (emacs-lisp-mode) @@ -1955,7 +1983,7 @@ and will be removed soon. See (elisp)Backquote in the manual.")) (widen) (delete-char delta)))) -(defun byte-compile-insert-header (filename outbuffer) +(defun byte-compile-insert-header (_filename outbuffer) "Insert a header at the start of OUTBUFFER. Call from the source buffer." (let ((dynamic-docstrings byte-compile-dynamic-docstrings) @@ -1974,11 +2002,7 @@ Call from the source buffer." ;; >4 byte x version %d (insert ";ELC" 23 "\000\000\000\n" - ";;; Compiled by " - (or (and (boundp 'user-mail-address) user-mail-address) - (concat (user-login-name) "@" (system-name))) - " on " (current-time-string) "\n" - ";;; from file " filename "\n" + ";;; Compiled\n" ";;; in Emacs version " emacs-version "\n" ";;; with" (cond @@ -2195,9 +2219,14 @@ list that represents a doc string reference. (eq (car (nth 1 form)) 'quote) (consp (cdr (nth 1 form))) (symbolp (nth 1 (nth 1 form)))) - (push (cons (nth 1 (nth 1 form)) - (cons 'autoload (cdr (cdr form)))) - byte-compile-function-environment) + ;; Don't add it if it's already defined. Otherwise, it might + ;; hide the actual definition. However, do remove any entry from + ;; byte-compile-noruntime-functions, in case we have an autoload + ;; of foo-func following an (eval-when-compile (require 'foo)). + (unless (fboundp (nth 1 (nth 1 form))) + (push (cons (nth 1 (nth 1 form)) + (cons 'autoload (cdr (cdr form)))) + byte-compile-function-environment)) ;; If an autoload occurs _before_ the first call to a function, ;; byte-compile-callargs-warn does not add an entry to ;; byte-compile-unresolved-functions. Here we mimic the logic @@ -2205,11 +2234,14 @@ list that represents a doc string reference. ;; autoload comes _after_ the function call. ;; Alternatively, similar logic could go in ;; byte-compile-warn-about-unresolved-functions. - (or (memq (nth 1 (nth 1 form)) byte-compile-noruntime-functions) - (setq byte-compile-unresolved-functions - (delq (assq (nth 1 (nth 1 form)) - byte-compile-unresolved-functions) - byte-compile-unresolved-functions)))) + (if (memq (nth 1 (nth 1 form)) byte-compile-noruntime-functions) + (setq byte-compile-noruntime-functions + (delq (nth 1 (nth 1 form)) byte-compile-noruntime-functions) + byte-compile-noruntime-functions) + (setq byte-compile-unresolved-functions + (delq (assq (nth 1 (nth 1 form)) + byte-compile-unresolved-functions) + byte-compile-unresolved-functions)))) (if (stringp (nth 3 form)) form ;; No doc string, so we can compile this as a normal form. @@ -2217,15 +2249,24 @@ list that represents a doc string reference. (put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) -(defun byte-compile-file-form-defvar (form) - (when (and (symbolp (nth 1 form)) - (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + +(defun byte-compile--declare-var (sym) + (when (and (symbolp sym) + (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical)) (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) - (push (nth 1 form) byte-compile-bound-variables) - (if (eq (car form) 'defconst) - (push (nth 1 form) byte-compile-const-variables)) + sym)) + (when (memq sym byte-compile-lexical-variables) + (setq byte-compile-lexical-variables + (delq sym byte-compile-lexical-variables)) + (byte-compile-warn "Variable `%S' declared after its first use" sym)) + (push sym byte-compile-bound-variables)) + +(defun byte-compile-file-form-defvar (form) + (let ((sym (nth 1 form))) + (byte-compile--declare-var sym) + (if (eq (car form) 'defconst) + (push sym byte-compile-const-variables))) (if (and (null (cddr form)) ;No `value' provided. (eq (car form) 'defvar)) ;Just a declaration. nil @@ -2239,7 +2280,7 @@ list that represents a doc string reference. 'byte-compile-file-form-define-abbrev-table) (defun byte-compile-file-form-define-abbrev-table (form) (if (eq 'quote (car-safe (car-safe (cdr form)))) - (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) + (byte-compile--declare-var (car-safe (cdr (cadr form))))) (byte-compile-keep-pending form)) (put 'custom-declare-variable 'byte-hunk-handler @@ -2247,7 +2288,7 @@ list that represents a doc string reference. (defun byte-compile-file-form-custom-declare-variable (form) (when (byte-compile-warning-enabled-p 'callargs) (byte-compile-nogroup-warn form)) - (push (nth 1 (nth 1 form)) byte-compile-bound-variables) + (byte-compile--declare-var (nth 1 (nth 1 form))) (byte-compile-keep-pending form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) @@ -2499,8 +2540,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. @@ -2548,19 +2589,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." "Return a list of the variables in the lambda argument list ARGLIST." (remq '&rest (remq '&optional arglist))) -(defun byte-compile-make-lambda-lexenv (form) +(defun byte-compile-make-lambda-lexenv (args) "Return a new lexical environment for a lambda expression FORM." - ;; See if this is a closure or not - (let ((args (byte-compile-arglist-vars (cadr form)))) - (let ((lexenv nil)) - ;; Fill in the initial stack contents - (let ((stackpos 0)) - ;; Add entries for each argument - (dolist (arg args) - (push (cons arg stackpos) lexenv) - (setq stackpos (1+ stackpos))) - ;; Return the new lexical environment - lexenv)))) + (let* ((lexenv nil) + (stackpos 0)) + ;; Add entries for each argument. + (dolist (arg args) + (push (cons arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment. + lexenv)) (defun byte-compile-make-args-desc (arglist) (let ((mandatory 0) @@ -2598,9 +2636,9 @@ for symbols generated by the byte compiler itself." (byte-compile-set-symbol-position 'lambda)) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) + (arglistvars (byte-compile-arglist-vars arglist)) (byte-compile-bound-variables - (append (and (not lexical-binding) - (byte-compile-arglist-vars arglist)) + (append (if (not lexical-binding) arglistvars) byte-compile-bound-variables)) (body (cdr (cdr fun))) (doc (if (stringp (car body)) @@ -2648,7 +2686,8 @@ for symbols generated by the byte compiler itself." ;; args (since lambda expressions should be ;; closed by now). (and lexical-binding - (byte-compile-make-lambda-lexenv fun)) + (byte-compile-make-lambda-lexenv + arglistvars)) reserved-csts))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) @@ -2813,7 +2852,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) @@ -3406,32 +3446,38 @@ discarding." (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) +;; Is this worth it? Both -before and -after are written in C. (defun byte-compile-char-before (form) - (cond ((= 2 (length form)) + (cond ((or (= 1 (length form)) + (and (= 2 (length form)) (not (nth 1 form)))) + (byte-compile-form '(char-after (1- (point))))) + ((= 2 (length form)) (byte-compile-form (list 'char-after (if (numberp (nth 1 form)) (1- (nth 1 form)) - `(1- ,(nth 1 form)))))) - ((= 1 (length form)) - (byte-compile-form '(char-after (1- (point))))) + `(1- (or ,(nth 1 form) + (point))))))) (t (byte-compile-subr-wrong-args form "0-1")))) ;; backward-... ==> forward-... with negated argument. +;; Is this worth it? Both -backward and -forward are written in C. (defun byte-compile-backward-char (form) - (cond ((= 2 (length form)) + (cond ((or (= 1 (length form)) + (and (= 2 (length form)) (not (nth 1 form)))) + (byte-compile-form '(forward-char -1))) + ((= 2 (length form)) (byte-compile-form (list 'forward-char (if (numberp (nth 1 form)) (- (nth 1 form)) - `(- ,(nth 1 form)))))) - ((= 1 (length form)) - (byte-compile-form '(forward-char -1))) + `(- (or ,(nth 1 form) 1)))))) (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-backward-word (form) - (cond ((= 2 (length form)) + (cond ((or (= 1 (length form)) + (and (= 2 (length form)) (not (nth 1 form)))) + (byte-compile-form '(forward-word -1))) + ((= 2 (length form)) (byte-compile-form (list 'forward-word (if (numberp (nth 1 form)) (- (nth 1 form)) - `(- ,(nth 1 form)))))) - ((= 1 (length form)) - (byte-compile-form '(forward-word -1))) + `(- (or ,(nth 1 form) 1)))))) (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-list (form) @@ -3694,10 +3740,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))) @@ -3833,9 +3879,8 @@ that suppresses all warnings during execution of BODY." "Emit byte-codes to push the initialization value for CLAUSE on the stack. Return the offset in the form (VAR . OFFSET)." (let* ((var (if (consp clause) (car clause) clause))) - ;; We record the stack position even of dynamic bindings and - ;; variables in non-stack lexical environments; we'll put - ;; them in the proper place below. + ;; We record the stack position even of dynamic bindings; we'll put + ;; them in the proper place later. (prog1 (cons var byte-compile-depth) (if (consp clause) (byte-compile-form (cadr clause)) @@ -3853,33 +3898,41 @@ Return the offset in the form (VAR . OFFSET)." INIT-LEXENV should be a lexical-environment alist describing the positions of the init value that have been pushed on the stack. Return non-nil if the TOS value was popped." - ;; The presence of lexical bindings mean that we may have to + ;; The mix of lexical and dynamic bindings mean that we may have to ;; juggle things on the stack, to move them to TOS for ;; dynamic binding. - (cond ((not (byte-compile-not-lexical-var-p var)) - ;; VAR is a simple stack-allocated lexical variable - (push (assq var init-lexenv) - byte-compile--lexical-environment) - nil) - ((eq var (caar init-lexenv)) - ;; VAR is dynamic and is on the top of the - ;; stack, so we can just bind it like usual - (byte-compile-dynamic-variable-bind var) - t) - (t - ;; VAR is dynamic, but we have to get its - ;; value out of the middle of the stack - (let ((stack-pos (cdr (assq var init-lexenv)))) - (byte-compile-stack-ref stack-pos) - (byte-compile-dynamic-variable-bind var) - ;; Now we have to store nil into its temporary - ;; stack position to avoid problems with GC - (byte-compile-push-constant nil) - (byte-compile-stack-set stack-pos)) - nil))) - -(defun byte-compile-unbind (clauses init-lexenv - &optional preserve-body-value) + (if (and lexical-binding (not (byte-compile-not-lexical-var-p var))) + ;; VAR is a simple stack-allocated lexical variable. + (progn (push (assq var init-lexenv) + byte-compile--lexical-environment) + nil) + ;; VAR should be dynamically bound. + (while (assq var byte-compile--lexical-environment) + ;; This dynamic binding shadows a lexical binding. + (setq byte-compile--lexical-environment + (remq (assq var byte-compile--lexical-environment) + byte-compile--lexical-environment))) + (cond + ((eq var (caar init-lexenv)) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual. + (byte-compile-dynamic-variable-bind var) + t) + (t + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack. + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position so it doesn't prevent the value from being GC'd. + ;; FIXME: Not worth the trouble. + ;; (byte-compile-push-constant nil) + ;; (byte-compile-stack-set stack-pos) + ) + nil)))) + +(defun byte-compile-unbind (clauses init-lexenv preserve-body-value) "Emit byte-codes to unbind the variables bound by CLAUSES. CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a lexical-environment alist describing the positions of the init value that @@ -3887,7 +3940,7 @@ have been pushed on the stack. If PRESERVE-BODY-VALUE is true, then an additional value on the top of the stack, above any lexical binding slots, is preserved, so it will be on the top of the stack after all binding slots have been popped." - ;; Unbind dynamic variables + ;; Unbind dynamic variables. (let ((num-dynamic-bindings 0)) (dolist (clause clauses) (unless (assq (if (consp clause) (car clause) clause) @@ -3898,14 +3951,15 @@ binding slots have been popped." ;; Pop lexical variables off the stack, possibly preserving the ;; return value of the body. (when init-lexenv - ;; INIT-LEXENV contains all init values left on the stack + ;; INIT-LEXENV contains all init values left on the stack. (byte-compile-discard (length init-lexenv) preserve-body-value))) (defun byte-compile-let (form) - "Generate code for the `let' form FORM." + "Generate code for the `let' or `let*' form FORM." (let ((clauses (cadr form)) - (init-lexenv nil)) - (when (eq (car form) 'let) + (init-lexenv nil) + (is-let (eq (car form) 'let))) + (when is-let ;; First compute the binding values in the old scope. (dolist (var clauses) (push (byte-compile-push-binding-init var) init-lexenv))) @@ -3917,28 +3971,20 @@ binding slots have been popped." ;; For `let', do it in reverse order, because it makes no ;; semantic difference, but it is a lot more efficient since the ;; values are now in reverse order on the stack. - (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses)) - (unless (eq (car form) 'let) + (dolist (var (if is-let (reverse clauses) clauses)) + (unless is-let (push (byte-compile-push-binding-init var) init-lexenv)) (let ((var (if (consp var) (car var) var))) - (cond ((null lexical-binding) - ;; If there are no lexical bindings, we can do things simply. - (byte-compile-dynamic-variable-bind var)) - ((byte-compile-bind var init-lexenv) - (pop init-lexenv))))) + (if (byte-compile-bind var init-lexenv) + (pop init-lexenv)))) ;; Emit the body. (let ((init-stack-depth byte-compile-depth)) (byte-compile-body-do-effect (cdr (cdr form))) - ;; Unbind the variables. - (if lexical-binding - ;; Unbind both lexical and dynamic variables. - (progn - (cl-assert (or (eq byte-compile-depth init-stack-depth) - (eq byte-compile-depth (1+ init-stack-depth)))) - (byte-compile-unbind clauses init-lexenv (> byte-compile-depth - init-stack-depth))) - ;; Unbind dynamic variables. - (byte-compile-out 'byte-unbind (length clauses))))))) + ;; Unbind both lexical and dynamic variables. + (cl-assert (or (eq byte-compile-depth init-stack-depth) + (eq byte-compile-depth (1+ init-stack-depth)))) + (byte-compile-unbind clauses init-lexenv + (> byte-compile-depth init-stack-depth)))))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 5a1d6265848..761e33c059d 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -1,6 +1,6 @@ ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*- -;; Copyright (C) 2011-2012 Free Software Foundation, Inc. +;; Copyright (C) 2011-2013 Free Software Foundation, Inc. ;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> ;; Maintainer: FSF @@ -81,7 +81,6 @@ ;; and other oddities. ;; - new byte codes for unwind-protect, catch, and condition-case so that ;; closures aren't needed at all. -;; - inline source code of different binding mode by first compiling it. ;; - a reference to a var that is known statically to always hold a constant ;; should be turned into a byte-constant rather than a byte-stack-ref. ;; Hmm... right, that's called constant propagation and could be done here, @@ -95,6 +94,7 @@ ;; (defmacro dlet (binders &rest body) ;; ;; Works in both lexical and non-lexical mode. +;; (declare (indent 1) (debug let)) ;; `(progn ;; ,@(mapcar (lambda (binder) ;; `(defvar ,(if (consp binder) (car binder) binder))) @@ -489,6 +489,7 @@ places where they originally did not directly appear." (unless (fboundp 'byte-compile-not-lexical-var-p) ;; Only used to test the code in non-lexbind Emacs. (defalias 'byte-compile-not-lexical-var-p 'boundp)) +(defvar byte-compile-lexical-variables) (defun cconv--analyse-use (vardata form varkind) "Analyze the use of a variable. @@ -530,6 +531,7 @@ FORM is the parent form that binds this var." ;; outside of it. (envcopy (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env)) + (byte-compile-bound-variables byte-compile-bound-variables) (newenv envcopy)) ;; Push it before recursing, so cconv-freevars-alist contains entries in ;; the order they'll be used by closure-convert-rec. @@ -541,6 +543,7 @@ FORM is the parent form that binds this var." (format "Argument %S is not a lexical variable" arg))) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... (t (let ((varstruct (list arg nil nil nil nil))) + (cl-pushnew arg byte-compile-lexical-variables) (push (cons (list arg) (cdr varstruct)) newvars) (push varstruct newenv))))) (dolist (form body) ;Analyze body forms. @@ -579,6 +582,7 @@ and updates the data stored in ENV." (let ((orig-env env) (newvars nil) (var nil) + (byte-compile-bound-variables byte-compile-bound-variables) (value nil)) (dolist (binder binders) (if (not (consp binder)) @@ -592,6 +596,7 @@ and updates the data stored in ENV." (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) (unless (byte-compile-not-lexical-var-p var) + (cl-pushnew var byte-compile-lexical-variables) (let ((varstruct (list var nil nil nil nil))) (push (cons binder (cdr varstruct)) newvars) (push varstruct env)))) @@ -616,7 +621,8 @@ and updates the data stored in ENV." (`((lambda . ,_) . ,_) ; First element is lambda expression. (byte-compile-log-warning - "Use of deprecated ((lambda ...) ...) form" t :warning) + (format "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) + t :warning) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyse-form exp env))) @@ -645,6 +651,7 @@ and updates the data stored in ENV." (`(track-mouse . ,body) (cconv--analyse-function () body env form)) + (`(defvar ,var) (push var byte-compile-bound-variables)) (`(,(or `defconst `defvar) ,var ,value . ,_) (push var byte-compile-bound-variables) (cconv-analyse-form value env)) @@ -668,7 +675,9 @@ and updates the data stored in ENV." ;; seem worth the trouble. (dolist (form forms) (cconv-analyse-form form nil))) - (`(declare . ,_) nil) ;The args don't contain code. + ;; `declare' should now be macro-expanded away (and if they're not, we're + ;; in trouble because they *can* contain code nowadays). + ;; (`(declare . ,_) nil) ;The args don't contain code. (`(,_ . ,body-forms) ; First element is a function or whatever. (dolist (form body-forms) (cconv-analyse-form form env))) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 31aeb1f8076..032eced7592 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -1,7 +1,7 @@ ;;; chart.el --- Draw charts (bar charts, etc) -*- lexical-binding: t -*- -;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2013 Free +;; Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 @@ -470,7 +470,7 @@ See `chart-sort-matchlist' for more details." (progn (chart-sort-matchlist s2 s1 pred) (setq s (oref s2 data))) - (error "Sorting of chart %s not supported" (object-name c)))) + (error "Sorting of chart %s not supported" (eieio-object-name c)))) (if (eq (oref c direction) 'horizontal) (oset (oref c y-axis) items s) (oset (oref c x-axis) items s) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index d4213899ef6..367db5240c9 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -1,6 +1,6 @@ ;;; check-declare.el --- Check declare-function statements -;; Copyright (C) 2007-2012 Free Software Foundation, Inc. +;; Copyright (C) 2007-2013 Free Software Foundation, Inc. ;; Author: Glenn Morris <rgm@gnu.org> ;; Keywords: lisp, tools, maint diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index ee8cbd2c3bc..6540a8e9f14 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1,6 +1,6 @@ ;;; checkdoc.el --- check documentation strings for style requirements -;; Copyright (C) 1997-1998, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1997-1998, 2001-2013 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.6.2 @@ -124,7 +124,7 @@ ;; Adding your own checks: ;; ;; You can experiment with adding your own checks by setting the -;; hooks `checkdoc-style-hooks' and `checkdoc-comment-style-hooks'. +;; hooks `checkdoc-style-functions' and `checkdoc-comment-style-functions'. ;; Return a string which is the error you wish to report. The cursor ;; position should be preserved. ;; @@ -274,17 +274,21 @@ made in the style guide relating to order." :type 'boolean) ;;;###autoload(put 'checkdoc-arguments-in-order-flag 'safe-local-variable 'booleanp) -(defvar checkdoc-style-hooks nil - "Hooks called after the standard style check is completed. -All hooks must return nil or a string representing the error found. +(define-obsolete-variable-alias 'checkdoc-style-hooks + 'checkdoc-style-functions "24.3") +(defvar checkdoc-style-functions nil + "Hook run after the standard style check is completed. +All functions must return nil or a string representing the error found. Useful for adding new user implemented commands. Each hook is called with two parameters, (DEFUNINFO ENDPOINT). DEFUNINFO is the return value of `checkdoc-defun-info'. ENDPOINT is the location of end of the documentation string.") -(defvar checkdoc-comment-style-hooks nil - "Hooks called after the standard comment style check is completed. +(define-obsolete-variable-alias 'checkdoc-comment-style-hooks + 'checkdoc-comment-style-functions "24.3") +(defvar checkdoc-comment-style-functions nil + "Hook run after the standard comment style check is completed. Must return nil if no errors are found, or a string describing the problem discovered. This is useful for adding additional checks.") @@ -1843,7 +1847,7 @@ Replace with \"%s\"? " original replace) ;; and reliance on the Ispell program. (checkdoc-ispell-docstring-engine e) ;; User supplied checks - (save-excursion (checkdoc-run-hooks 'checkdoc-style-hooks fp e)) + (save-excursion (checkdoc-run-hooks 'checkdoc-style-functions fp e)) ;; Done! ))) @@ -2062,7 +2066,8 @@ If the offending word is in a piece of quoted text, then it is skipped." ;;; Ispell engine ;; -(eval-when-compile (require 'ispell)) +(defvar ispell-process) +(declare-function ispell-buffer-local-words "ispell" ()) (defun checkdoc-ispell-init () "Initialize Ispell process (default version) with Lisp words. @@ -2070,19 +2075,14 @@ The words used are from `checkdoc-ispell-lisp-words'. If `ispell' cannot be loaded, then set `checkdoc-spellcheck-documentation-flag' to nil." (require 'ispell) - (if (not (symbol-value 'ispell-process)) ;Silence byteCompiler - (condition-case nil - (progn - (ispell-buffer-local-words) - ;; This code copied in part from ispell.el Emacs 19.34 - (let ((w checkdoc-ispell-lisp-words)) - (while w - (process-send-string - ;; Silence byte compiler - (symbol-value 'ispell-process) - (concat "@" (car w) "\n")) - (setq w (cdr w))))) - (error (setq checkdoc-spellcheck-documentation-flag nil))))) + (unless ispell-process + (condition-case nil + (progn + (ispell-buffer-local-words) + ;; This code copied in part from ispell.el Emacs 19.34 + (dolist (w checkdoc-ispell-lisp-words) + (process-send-string ispell-process (concat "@" w "\n")))) + (error (setq checkdoc-spellcheck-documentation-flag nil))))) (defun checkdoc-ispell-docstring-engine (end) "Run the Ispell tools on the doc string between point and END. @@ -2183,14 +2183,13 @@ News agents may remove it" ;;; Comment checking engine ;; -(eval-when-compile - ;; We must load this to: - ;; a) get symbols for compile and - ;; b) determine if we have lm-history symbol which doesn't always exist - (require 'lisp-mnt)) - (defvar generate-autoload-cookie) +(eval-when-compile (require 'lisp-mnt)) ; expand silly defsubsts +(declare-function lm-summary "lisp-mnt" (&optional file)) +(declare-function lm-section-start "lisp-mnt" (header &optional after)) +(declare-function lm-section-end "lisp-mnt" (header)) + (defun checkdoc-file-comments-engine () "Return a message list if this file does not match the Emacs standard. This checks for style only, such as the first line, Commentary:, @@ -2353,7 +2352,7 @@ Code:, and others referenced in the style guide." err (or ;; Generic Full-file checks (should be comment related) - (checkdoc-run-hooks 'checkdoc-comment-style-hooks) + (checkdoc-run-hooks 'checkdoc-comment-style-functions) err)) ;; Done with full file comment checks err))) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index ea5e1cf9beb..70ad1283cb2 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -1,6 +1,6 @@ ;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2000-2013 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Keywords: extensions @@ -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) @@ -131,7 +132,7 @@ TYPE is the sequence type to return. ;;;###autoload (defun cl-maplist (cl-func cl-list &rest cl-rest) "Map FUNCTION to each sublist of LIST or LISTs. -Like `mapcar', except applies to lists and their cdr's rather than to +Like `cl-mapcar', except applies to lists and their cdr's rather than to the elements themselves. \n(fn FUNCTION LIST...)" (if cl-rest @@ -149,8 +150,9 @@ the elements themselves. (setq cl-list (cdr cl-list))) (nreverse cl-res)))) +;;;###autoload (defun cl-mapc (cl-func cl-seq &rest cl-rest) - "Like `mapcar', but does not accumulate values returned by the function. + "Like `cl-mapcar', but does not accumulate values returned by the function. \n(fn FUNCTION SEQUENCE...)" (if cl-rest (progn (apply 'cl-map nil cl-func cl-seq cl-rest) @@ -169,7 +171,7 @@ the elements themselves. ;;;###autoload (defun cl-mapcan (cl-func cl-seq &rest cl-rest) - "Like `mapcar', but nconc's together the values returned by the function. + "Like `cl-mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))) @@ -438,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. @@ -595,8 +597,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (macroexp-let2 nil d def (funcall do `(cl-getf ,getter ,k ,d) (lambda (v) - (funcall setter - `(cl--set-getf ,getter ,k ,v)))))))))) + (macroexp-let2 nil val v + `(progn + ,(funcall setter + `(cl--set-getf ,getter ,k ,val)) + ,val)))))))))) (setplist '--cl-getf-symbol-- plist) (or (get '--cl-getf-symbol-- tag) ;; Originally we called cl-get here, @@ -674,6 +679,9 @@ PROPLIST is a list of the sort returned by `symbol-plist'. ;;;###autoload (defun cl-prettyexpand (form &optional full) + "Expand macros in FORM and insert the pretty-printed result. +Optional argument FULL non-nil means to expand all macros, +including `cl-block' and `cl-eval-when'." (message "Expanding...") (let ((cl--compiling-file full) (byte-compile-macro-environment nil)) @@ -689,7 +697,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'. ;; Local variables: ;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 01bdfbf4bf2..bbfe9ec6424 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -1,6 +1,6 @@ ;;; cl-indent.el --- enhanced lisp-indent mode -;; Copyright (C) 1987, 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 1987, 2000-2013 Free Software Foundation, Inc. ;; Author: Richard Mlynarik <mly@eddie.mit.edu> ;; Created: July 1987 @@ -809,4 +809,6 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\ ;(put 'defclass 'common-lisp-indent-function '((&whole 2 &rest (&whole 2 &rest 1) &rest (&whole 2 &rest 1))) ;(put 'defgeneric 'common-lisp-indent-function 'defun) +(provide 'cl-indent) + ;;; cl-indent.el ends here diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 532c81c502c..52f123c83ec 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -1,9 +1,9 @@ ;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 +;; Version: 1.0 ;; Keywords: extensions ;; This file is part of GNU Emacs. @@ -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 @@ -113,15 +113,9 @@ printer proceeds to the next function on the list. This variable is not used at present, but it is defined in hopes that a future Emacs interpreter will be able to use it.") -(defun cl-unload-function () - "Stop unloading of the Common Lisp extensions." - (message "Cannot unload the feature `cl'") - ;; Stop standard unloading! - t) - ;;; Generalized variables. ;; These macros are defined here so that they -;; can safely be used in .emacs files. +;; can safely be used in init files. (defmacro cl-incf (place &optional x) "Increment PLACE by X (1 by default). @@ -162,8 +156,8 @@ an element already on the list. ;; earlier and should have triggered them already. (with-no-warnings ,place) (setq ,place (cons ,var ,place)))) - (list 'setq place (cl-list* 'cl-adjoin x place keys))) - (cl-list* 'cl-callf2 'cl-adjoin x place keys))) + `(setq ,place (cl-adjoin ,x ,place ,@keys))) + `(cl-callf2 cl-adjoin ,x ,place ,@keys))) (defun cl--set-elt (seq n val) (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) @@ -248,37 +242,36 @@ 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) - (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) - (push spec cl-proclaims-deferred)) + "Record a global declaration specified by SPEC." + (if (fboundp 'cl--do-proclaim) (cl--do-proclaim spec t) + (push spec cl--proclaims-deferred)) nil) (defmacro cl-declaim (&rest specs) - (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 + "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 (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. -(defun cl-floatp-safe (object) - "Return t if OBJECT is a floating point number. -On Emacs versions that lack floating-point support, this function -always returns nil." - (and (numberp object) (not (integerp object)))) +(define-obsolete-function-alias 'cl-floatp-safe 'floatp "24.4") (defsubst cl-plusp (number) "Return t if NUMBER is positive." @@ -296,7 +289,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. @@ -656,7 +650,7 @@ If ALIST is non-nil, the new pairs are prepended to it." (gv-define-setter face-foreground (x f &optional s) `(set-face-foreground ,f ,x ,s)) (gv-define-setter face-underline-p (x f &optional s) - `(set-face-underline-p ,f ,x ,s)) + `(set-face-underline ,f ,x ,s)) (gv-define-simple-setter file-modes set-file-modes t) (gv-define-simple-setter frame-height set-screen-height t) (gv-define-simple-setter frame-parameters modify-frame-parameters t) @@ -728,7 +722,8 @@ If ALIST is non-nil, the new pairs are prepended to it." ;;;###autoload (progn ;; Make sure functions defined with cl-defsubst can be inlined even in - ;; packages which do not require CL. + ;; packages which do not require CL. We don't put an autoload cookie + ;; directly on that function, since those cookies only go to cl-loaddefs. (autoload 'cl--defsubst-expand "cl-macs") ;; Autoload, so autoload.el and font-lock can use it even when CL ;; is not loaded. @@ -741,11 +736,8 @@ If ALIST is non-nil, the new pairs are prepended to it." (provide 'cl-lib) -(run-hooks 'cl-load-hook) - ;; Local variables: ;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) ;; End: ;;; cl-lib.el ends here diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index c12e8ccacb1..33ee7c0bbd2 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,8 +10,8 @@ ;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl--set-frame-visible-p ;;;;;; 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-maplist cl-map cl--mapcar-many cl-equalp cl-coerce) -;;;;;; "cl-extra" "cl-extra.el" "535a24c1cff55a16e3d51219498a7858") +;;;;;; cl-mapl cl-mapc cl-maplist cl-map cl--mapcar-many cl-equalp +;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "011111887a1f353218e59e14d0b09c68") ;;; Generated autoloads from cl-extra.el (autoload 'cl-coerce "cl-extra" "\ @@ -41,18 +41,23 @@ TYPE is the sequence type to return. (autoload 'cl-maplist "cl-extra" "\ Map FUNCTION to each sublist of LIST or LISTs. -Like `mapcar', except applies to lists and their cdr's rather than to +Like `cl-mapcar', except applies to lists and their cdr's rather than to the elements themselves. \(fn FUNCTION LIST...)" nil nil) +(autoload 'cl-mapc "cl-extra" "\ +Like `cl-mapcar', but does not accumulate values returned by the function. + +\(fn FUNCTION SEQUENCE...)" nil nil) + (autoload 'cl-mapl "cl-extra" "\ Like `cl-maplist', but does not accumulate values returned by the function. \(fn FUNCTION LIST...)" nil nil) (autoload 'cl-mapcan "cl-extra" "\ -Like `mapcar', but nconc's together the values returned by the function. +Like `cl-mapcar', but nconc's together the values returned by the function. \(fn FUNCTION SEQUENCE...)" nil nil) @@ -219,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. @@ -243,7 +248,9 @@ Remove from SYMBOL's plist the property PROPNAME and its value. \(fn SYMBOL PROPNAME)" nil nil) (autoload 'cl-prettyexpand "cl-extra" "\ - +Expand macros in FORM and insert the pretty-printed result. +Optional argument FULL non-nil means to expand all macros, +including `cl-block' and `cl-eval-when'. \(fn FORM &optional FULL)" nil nil) @@ -255,12 +262,12 @@ Remove from SYMBOL's plist the property PROPNAME and its value. ;;;;;; 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" "6d0676869af66e5b5a671f95ee069461") +;;;;;; "cl-macs" "cl-macs.el" "80cb53f97b21adb6069c43c38a2e094d") ;;; Generated autoloads from cl-macs.el (autoload 'cl--compiler-macro-list* "cl-macs" "\ @@ -315,7 +322,7 @@ its argument list allows full Common Lisp conventions. \(fn FUNC)" nil t) (autoload 'cl-destructuring-bind "cl-macs" "\ - +Bind the variables in ARGS to the result of EXPR and execute BODY. \(fn ARGS EXPR &rest BODY)" nil t) @@ -409,30 +416,48 @@ This is compatible with Common Lisp, but note that `defun' and (put 'cl-return-from 'lisp-indent-function '1) (autoload 'cl-loop "cl-macs" "\ -The Common Lisp `cl-loop' macro. -Valid clauses are: - for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, - for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, - for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND, - always COND, never COND, thereis COND, collect EXPR into VAR, - append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR, - count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR, - if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, - finally return EXPR, named NAME. +The Common Lisp `loop' macro. +Valid clauses include: + For clauses: + for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 by EXPR3 + for VAR = EXPR1 then EXPR2 + for VAR in/on/in-ref LIST by FUNC + for VAR across/across-ref ARRAY + for VAR being: + the elements of/of-ref SEQUENCE [using (index VAR2)] + the symbols [of OBARRAY] + the hash-keys/hash-values of HASH-TABLE [using (hash-values/hash-keys V2)] + the key-codes/key-bindings/key-seqs of KEYMAP [using (key-bindings VAR2)] + the overlays/intervals [of BUFFER] [from POS1] [to POS2] + the frames/buffers + the windows [of FRAME] + Iteration clauses: + repeat INTEGER + while/until/always/never/thereis CONDITION + Accumulation clauses: + collect/append/nconc/concat/vconcat/count/sum/maximize/minimize FORM + [into VAR] + Miscellaneous clauses: + with VAR = INIT + if/when/unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...] + named NAME + initially/finally [do] EXPRS... + do EXPRS... + [finally] return EXPR + +For more details, see Info node `(cl)Loop Facility'. \(fn CLAUSE...)" nil t) (autoload 'cl-do "cl-macs" "\ -The Common Lisp `cl-do' loop. +The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil t) (put 'cl-do 'lisp-indent-function '2) (autoload 'cl-do* "cl-macs" "\ -The Common Lisp `cl-do*' loop. +The Common Lisp `do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil t) @@ -458,6 +483,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 @@ -468,9 +506,9 @@ from OBARRAY. (put 'cl-do-symbols 'lisp-indent-function '1) (autoload 'cl-do-all-symbols "cl-macs" "\ +Like `cl-do-symbols', but use the default obarray. - -\(fn SPEC &rest BODY)" nil t) +\(fn (VAR [RESULT]) BODY...)" nil t) (put 'cl-do-all-symbols 'lisp-indent-function '1) @@ -485,7 +523,7 @@ before assigning any symbols SYM to the corresponding values. Bind SYMBOLS to VALUES dynamically in BODY. The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. Each symbol in the first list is bound to the corresponding value in the -second list (or made unbound if VALUES is shorter than SYMBOLS); then the +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. @@ -494,7 +532,7 @@ a `let' form, except that the list of symbols can be computed at run-time. (put 'cl-progv 'lisp-indent-function '2) (autoload 'cl-flet "cl-macs" "\ -Make temporary function definitions. +Make local function definitions. Like `cl-labels' but the definitions are not recursive. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) @@ -502,7 +540,7 @@ Like `cl-labels' but the definitions are not recursive. (put 'cl-flet 'lisp-indent-function '1) (autoload 'cl-flet* "cl-macs" "\ -Make temporary function definitions. +Make local function definitions. Like `cl-flet' but the definitions can refer to previous ones. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) @@ -559,12 +597,12 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (put 'cl-multiple-value-setq 'lisp-indent-function '1) (autoload 'cl-locally "cl-macs" "\ - +Equivalent to `progn'. \(fn &rest BODY)" nil t) (autoload 'cl-the "cl-macs" "\ - +At present this ignores _TYPE and is simply equivalent to FORM. \(fn TYPE FORM)" nil t) @@ -657,8 +695,9 @@ copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'. You can use the accessors to set the corresponding slots, via `setf'. NAME may instead take the form (NAME OPTIONS...), where each -OPTION is either a single keyword or (KEYWORD VALUE). -See Info node `(cl)Structures' for a list of valid keywords. +OPTION is either a single keyword or (KEYWORD VALUE) where +KEYWORD can be one of :conc-name, :constructor, :copier, :predicate, +:type, :named, :initial-offset, :print-function, or :include. Each SLOT may instead take the form (SLOT SLOT-OPTS...), where SLOT-OPTS are keyword-value pairs for that slot. Currently, only @@ -715,7 +754,10 @@ and then returning foo. \(fn FUNC ARGS &rest BODY)" nil t) (autoload 'cl-compiler-macroexpand "cl-macs" "\ - +Like `macroexpand', but for compiler macros. +Expands FORM repeatedly until no further expansion is possible. +Returns FORM unchanged if it has no compiler macro, or if it has a +macro that returns its `&whole' argument. \(fn FORM)" nil nil) @@ -748,7 +790,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" "b444601641dcbd14a23ca5182bc80ffa") +;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "51a70dea9cbc225165a50135956609aa") ;;; Generated autoloads from cl-seq.el (autoload 'cl-reduce "cl-seq" "\ @@ -1009,7 +1051,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. @@ -1039,7 +1081,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 16ac14f8fe9..66ad8e769b5 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,6 +1,6 @@ ;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*- -;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 @@ -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. @@ -216,12 +216,17 @@ The name is made by appending a number to PREFIX, default \"G\"." (defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) (defun cl--transform-lambda (form bind-block) + "Transform a function form FORM of name BIND-BLOCK. +BIND-BLOCK is the name of the symbol to which the function will be bound, +and which will be used for the name of the `cl-block' surrounding the +function's body. +FORM is of the form (ARGS . BODY)." (let* ((args (car form)) (body (cdr form)) (orig-args args) (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) (header nil) (simple-args nil)) (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive cl-declare))) + (memq (car-safe (car body)) '(interactive declare cl-declare))) (push (pop body) header)) (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) @@ -260,9 +265,11 @@ The name is made by appending a number to PREFIX, default \"G\"." (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) @@ -424,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)) @@ -433,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))) @@ -469,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 @@ -554,6 +561,7 @@ its argument list allows full Common Lisp conventions." ;;;###autoload (defmacro cl-destructuring-bind (args expr &rest body) + "Bind the variables in ARGS to the result of EXPR and execute BODY." (declare (indent 2) (debug (&define cl-macro-list def-form cl-declarations def-body))) (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil) @@ -566,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) @@ -578,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)) @@ -751,22 +759,41 @@ 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) - "The Common Lisp `cl-loop' macro. -Valid clauses are: - for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, - for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, - for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND, - always COND, never COND, thereis COND, collect EXPR into VAR, - append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR, - count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR, - if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, - finally return EXPR, named NAME. + "The Common Lisp `loop' macro. +Valid clauses include: + For clauses: + for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 by EXPR3 + for VAR = EXPR1 then EXPR2 + for VAR in/on/in-ref LIST by FUNC + for VAR across/across-ref ARRAY + for VAR being: + the elements of/of-ref SEQUENCE [using (index VAR2)] + the symbols [of OBARRAY] + the hash-keys/hash-values of HASH-TABLE [using (hash-values/hash-keys V2)] + the key-codes/key-bindings/key-seqs of KEYMAP [using (key-bindings VAR2)] + the overlays/intervals [of BUFFER] [from POS1] [to POS2] + the frames/buffers + the windows [of FRAME] + Iteration clauses: + repeat INTEGER + while/until/always/never/thereis CONDITION + Accumulation clauses: + collect/append/nconc/concat/vconcat/count/sum/maximize/minimize FORM + [into VAR] + Miscellaneous clauses: + with VAR = INIT + if/when/unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...] + named NAME + initially/finally [do] EXPRS... + do EXPRS... + [finally] return EXPR + +For more details, see Info node `(cl)Loop Facility'. \(fn CLAUSE...)" (declare (debug (&rest &or @@ -784,7 +811,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) @@ -795,14 +823,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 @@ -822,7 +852,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))) @@ -832,7 +863,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 @@ -987,7 +1019,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 @@ -1002,17 +1034,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))))) @@ -1028,7 +1064,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 @@ -1037,15 +1074,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)) @@ -1079,7 +1120,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)) @@ -1091,7 +1132,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 @@ -1128,14 +1170,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 @@ -1158,15 +1201,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 @@ -1174,16 +1219,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--")) @@ -1195,11 +1243,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)) @@ -1209,15 +1259,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 @@ -1237,7 +1289,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 @@ -1259,8 +1312,9 @@ Valid clauses are: loop-for-steps))) (t + ;; This is an advertised interface: (info "(cl)Other Clauses"). (let ((handler (and (symbolp word) - (get word 'cl--loop-for-handler)))) + (get word 'cl-loop-for-handler)))) (if handler (funcall handler var) (error "Expected a `for' preposition, found %s" word))))) @@ -1331,7 +1385,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)))) @@ -1342,7 +1397,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)) @@ -1355,19 +1411,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)) @@ -1375,11 +1435,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)) @@ -1401,17 +1461,20 @@ 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)) (t - (let ((handler (and (symbolp word) (get word 'cl--loop-handler)))) + ;; This is an advertised interface: (info "(cl)Other Clauses"). + (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) (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)) @@ -1430,10 +1493,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) @@ -1442,24 +1507,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) @@ -1498,7 +1566,7 @@ such that COMBO is equivalent to (and . CLAUSES)." ;;;###autoload (defmacro cl-do (steps endtest &rest body) - "The Common Lisp `cl-do' loop. + "The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" (declare (indent 2) @@ -1506,17 +1574,17 @@ 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) - "The Common Lisp `cl-do*' loop. + "The Common Lisp `do*' loop. \(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)) @@ -1544,9 +1612,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) @@ -1557,9 +1625,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) @@ -1579,6 +1693,9 @@ from OBARRAY. ;;;###autoload (defmacro cl-do-all-symbols (spec &rest body) + "Like `cl-do-symbols', but use the default obarray. + +\(fn (VAR [RESULT]) BODY...)" (declare (indent 1) (debug ((symbolp &optional form) cl-declarations body))) `(cl-do-symbols (,(car spec) nil ,(cadr spec)) ,@body)) @@ -1603,23 +1720,22 @@ before assigning any symbols SYM to the corresponding values. "Bind SYMBOLS to VALUES dynamically in BODY. The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. Each symbol in the first list is bound to the corresponding value in the -second list (or made unbound if VALUES is shorter than SYMBOLS); then the +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) @@ -1642,7 +1758,7 @@ a `let' form, except that the list of symbols can be computed at run-time." ;;;###autoload (defmacro cl-flet (bindings &rest body) - "Make temporary function definitions. + "Make local function definitions. Like `cl-labels' but the definitions are not recursive. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" @@ -1666,7 +1782,7 @@ Like `cl-labels' but the definitions are not recursive. ;;;###autoload (defmacro cl-flet* (bindings &rest body) - "Make temporary function definitions. + "Make local function definitions. Like `cl-flet' but the definitions can refer to previous ones. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" @@ -1881,18 +1997,20 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). ;;;###autoload (defmacro cl-locally (&rest body) + "Equivalent to `progn'." (declare (debug t)) (cons 'progn body)) ;;;###autoload (defmacro cl-the (_type form) + "At present this ignores _TYPE and is simply equivalent to FORM." (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 @@ -1917,9 +2035,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)) @@ -1931,10 +2049,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) @@ -1947,8 +2065,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. @@ -2154,8 +2272,9 @@ copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'. You can use the accessors to set the corresponding slots, via `setf'. NAME may instead take the form (NAME OPTIONS...), where each -OPTION is either a single keyword or (KEYWORD VALUE). -See Info node `(cl)Structures' for a list of valid keywords. +OPTION is either a single keyword or (KEYWORD VALUE) where +KEYWORD can be one of :conc-name, :constructor, :copier, :predicate, +:type, :named, :initial-offset, :print-function, or :include. Each SLOT may instead take the form (SLOT SLOT-OPTS...), where SLOT-OPTS are keyword-value pairs for that slot. Currently, only @@ -2193,7 +2312,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))) @@ -2323,26 +2442,29 @@ value, that slot cannot be set via `setf'. (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) forms) (push (cons accessor t) side-eff) - ;; Don't bother defining a setf-expander, since gv-get can use - ;; the compiler macro to get the same result. - ;;(push `(gv-define-setter ,accessor (cl-val cl-x) - ;; ,(if (cadr (memq :read-only (cddr desc))) - ;; `(progn (ignore cl-x cl-val) - ;; (error "%s is a read-only slot" - ;; ',accessor)) - ;; ;; If cl is loaded only for compilation, - ;; ;; the call to cl--struct-setf-expander would - ;; ;; cause a warning because it may not be - ;; ;; defined at run time. Suppress that warning. - ;; `(progn - ;; (declare-function - ;; cl--struct-setf-expander "cl-macs" - ;; (x name accessor pred-form pos)) - ;; (cl--struct-setf-expander - ;; cl-val cl-x ',name ',accessor - ;; ,(and pred-check `',pred-check) - ;; ,pos)))) - ;; forms) + (if (cadr (memq :read-only (cddr desc))) + (push `(gv-define-expander ,accessor + (lambda (_cl-do _cl-x) + (error "%s is a read-only slot" ',accessor))) + forms) + ;; For normal slots, we don't need to define a setf-expander, + ;; since gv-get can use the compiler macro to get the + ;; same result. + ;; (push `(gv-define-setter ,accessor (cl-val cl-x) + ;; ;; If cl is loaded only for compilation, + ;; ;; the call to cl--struct-setf-expander would + ;; ;; cause a warning because it may not be + ;; ;; defined at run time. Suppress that warning. + ;; (progn + ;; (declare-function + ;; cl--struct-setf-expander "cl-macs" + ;; (x name accessor pred-form pos)) + ;; (cl--struct-setf-expander + ;; cl-val cl-x ',name ',accessor + ;; ,(and pred-check `',pred-check) + ;; ,pos))) + ;; forms) + ) (if print-auto (nconc print-func (list `(princ ,(format " %s" slot) cl-s) @@ -2416,7 +2538,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." ((memq type '(nil t)) type) ((eq type 'null) `(null ,val)) ((eq type 'atom) `(atom ,val)) - ((eq type 'float) `(cl-floatp-safe ,val)) + ((eq type 'float) `(floatp ,val)) ((eq type 'real) `(numberp ,val)) ((eq type 'fixnum) `(integerp ,val)) ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef @@ -2435,7 +2557,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) @@ -2460,7 +2583,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) @@ -2480,7 +2603,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) @@ -2528,6 +2651,10 @@ and then returning foo." ;;;###autoload (defun cl-compiler-macroexpand (form) + "Like `macroexpand', but for compiler macros. +Expands FORM repeatedly until no further expansion is possible. +Returns FORM unchanged if it has no compiler macro, or if it has a +macro that returns its `&whole' argument." (while (let ((func (car-safe form)) (handler nil)) (while (and (symbolp func) @@ -2630,16 +2757,16 @@ surrounded by (cl-block NAME ...). (cond ((eq test 'eq) `(assq ,a ,list)) ((eq test 'equal) `(assoc ,a ,list)) ((and (macroexp-const-p a) (or (null keys) (eq test 'eql))) - (if (cl-floatp-safe (cl--const-expr-val a)) + (if (floatp (cl--const-expr-val a)) `(assoc ,a ,list) `(assq ,a ,list))) (t form)))) ;;;###autoload (defun cl--compiler-macro-adjoin (form a list &rest keys) - (if (and (cl--simple-expr-p a) (cl--simple-expr-p list) - (not (memq :key keys))) - `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list)) - form)) + (if (memq :key keys) form + (macroexp-let2 macroexp-copyable-p va a + (macroexp-let2 macroexp-copyable-p vlist list + `(if (cl-member ,va ,vlist ,@keys) ,vlist (cons ,va ,vlist)))))) (defun cl--compiler-macro-get (_form sym prop &optional def) (if def @@ -2667,26 +2794,25 @@ surrounded by (cl-block NAME ...). (put y 'side-effect-free t)) ;;; Things that are inline. -(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany +(cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany cl-notevery cl--set-elt cl-revappend cl-nreconc gethash)) ;;; 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-list* cl-subst cl-acons cl-equalp + cl-random-state-p copy-tree cl-sublis)) (run-hooks 'cl-macs-load-hook) ;; Local variables: ;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index b55f1df5ba5..fbf68f62b4a 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -1,6 +1,6 @@ ;;; cl-seq.el --- Common Lisp features, part 3 -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 @@ -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)) @@ -1010,7 +1015,6 @@ Atoms are compared by `eql'; cons cells are compared recursively. ;; Local variables: ;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index ae0852d6c87..ea4d9511f9d 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -1,6 +1,6 @@ ;;; cl.el --- Compatibility aliases for the old CL library. -*- lexical-binding: t -*- -;; Copyright (C) 2012 Free Software Foundation, Inc. +;; Copyright (C) 2012-2013 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions @@ -83,6 +83,12 @@ ;; (delete-region (1- (point)) (point))) ;; (save-buffer))))) +(defun cl-unload-function () + "Stop unloading of the Common Lisp extensions." + (message "Cannot unload the feature `cl'") + ;; Stop standard unloading! + t) + ;;; Aliases to cl-lib's features. (dolist (var '( @@ -107,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) @@ -222,13 +220,12 @@ callf2 callf letf* - ;; letf + letf rotatef shiftf remf psetf (define-setf-method . define-setf-expander) - declare the locally multiple-value-setq @@ -239,8 +236,6 @@ psetq do-all-symbols do-symbols - dotimes - dolist do* do loop @@ -322,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 @@ -452,7 +456,7 @@ definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet) - (obsolete "Use either `cl-flet' or `cl-letf'." "24.3")) + (obsolete "use either `cl-flet' or `cl-letf'." "24.3")) `(letf ,(mapcar (lambda (x) (if (or (and (fboundp (car x)) @@ -500,25 +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. -Like `cl-letf', but with some extra backward compatibility." - ;; 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. @@ -544,13 +529,15 @@ Like `cl-letf', but with some extra backward compatibility." (defmacro define-setf-expander (name arglist &rest body) "Define a `setf' method. -This method shows how to handle `setf's to places of the form (NAME ARGS...). -The argument forms ARGS are bound according to ARGLIST, as if NAME were -going to be expanded as a macro, then the BODY forms are executed and must -return a list of five elements: a temporary-variables list, a value-forms -list, a store-variables list (of length one), a store-form, and an access- -form. See `gv-define-expander', `gv-define-setter', and `gv-define-expander' -for a better and simpler ways to define setf-methods." +This method shows how to handle `setf's to places of the form +\(NAME ARGS...). The argument forms ARGS are bound according to +ARGLIST, as if NAME were going to be expanded as a macro, then +the BODY forms are executed and must return a list of five elements: +a temporary-variables list, a value-forms list, a store-variables list +\(of length one), a store-form, and an access- form. + +See `gv-define-expander', and `gv-define-setter' for better and +simpler ways to define setf-methods." (declare (debug (&define name cl-lambda-list cl-declarations-or-string def-body))) `(progn @@ -563,22 +550,30 @@ for a better and simpler ways to define setf-methods." (defmacro defsetf (name arg1 &rest args) "Define a `setf' method. -This macro is an easy-to-use substitute for `define-setf-expander' that works -well for simple place forms. In the simple `defsetf' form, `setf's of -the form (setf (NAME ARGS...) VAL) are transformed to function or macro -calls of the form (FUNC ARGS... VAL). Example: +This macro is an easy-to-use substitute for `define-setf-expander' +that works well for simple place forms. + +In the simple `defsetf' form, `setf's of the form (setf (NAME +ARGS...) VAL) are transformed to function or macro calls of the +form (FUNC ARGS... VAL). For example: + + (defsetf aref aset) - (cl-defsetf aref aset) +You can replace this form with `gv-define-simple-setter'. -Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...). -Here, the above `setf' call is expanded by binding the argument forms ARGS -according to ARGLIST, binding the value form VAL to STORE, then executing -BODY, which must return a Lisp form that does the necessary `setf' operation. -Actually, ARGLIST and STORE may be bound to temporary variables which are -introduced automatically to preserve proper execution order of the arguments. -Example: +Alternate form: (defsetf NAME ARGLIST (STORE) BODY...). - (cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) +Here, the above `setf' call is expanded by binding the argument +forms ARGS according to ARGLIST, binding the value form VAL to +STORE, then executing BODY, which must return a Lisp form that +does the necessary `setf' operation. Actually, ARGLIST and STORE +may be bound to temporary variables which are introduced +automatically to preserve proper execution order of the arguments. +For example: + + (defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) + +You can replace this form with `gv-define-setter'. \(fn NAME [FUNC | ARGLIST (STORE) BODY...])" (declare (debug @@ -594,7 +589,7 @@ Example: (cl-function (lambda (,@(car args) ,@arg1) ,@(cdr args))) do args))) - `(gv-define-simple-setter ,name ,arg1))) + `(gv-define-simple-setter ,name ,arg1 ,(car args)))) ;; FIXME: CL used to provide a setf method for `apply', but I haven't been able ;; to find a case where it worked. The code below tries to handle it as well. @@ -636,8 +631,12 @@ Example: (defmacro define-modify-macro (name arglist func &optional doc) "Define a `setf'-like modify macro. -If NAME is called, it combines its PLACE argument with the other arguments -from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" +If NAME is called, it combines its PLACE argument with the other +arguments from ARGLIST using FUNC. For example: + + (define-modify-macro incf (&optional (n 1)) +) + +You can replace this macro with `gv-letplace'." (declare (debug (&define name cl-lambda-list ;; should exclude &key symbolp &optional stringp))) @@ -690,6 +689,7 @@ from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" 'cl--map-keymap-recursively "24.3") (define-obsolete-function-alias 'cl-map-intervals 'cl--map-intervals "24.3") (define-obsolete-function-alias 'cl-map-extents 'cl--map-overlays "24.3") +(define-obsolete-function-alias 'cl-set-getf 'cl--set-getf "24.3") (defun cl-maclisp-member (item list) (declare (obsolete member "24.3")) @@ -720,4 +720,7 @@ from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" (list accessor temp)))) (provide 'cl) + +(run-hooks 'cl-load-hook) + ;;; cl.el ends here diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index c3616c6e490..b3fc6fb887a 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -1,6 +1,7 @@ ;;; copyright.el --- update the copyright notice in current buffer -;; Copyright (C) 1991-1995, 1998, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1991-1995, 1998, 2001-2013 Free Software Foundation, +;; Inc. ;; Author: Daniel Pfeiffer <occitan@esperanto.org> ;; Keywords: maint, tools diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 87c9b280bea..b8e327625e7 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -1,6 +1,6 @@ ;;; crm.el --- read multiple strings with completion -;; Copyright (C) 1985-1986, 1993-2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1993-2013 Free Software Foundation, Inc. ;; Author: Sen Nagata <sen@eccosys.com> ;; Keywords: completion, minibuffer, multiple elements @@ -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 @@ -264,7 +263,8 @@ Completion is available on a per-element basis. For example, if the contents of the minibuffer are 'alice,bob,eve' and point is between 'l' and 'i', pressing TAB operates on the element 'alice'. -The return value of this function is a list of the read strings. +The return value of this function is a list of the read strings +with empty strings removed. See the documentation for `completing-read' for details on the arguments: PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, HIST, DEF, and @@ -282,13 +282,14 @@ 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))) (and def (string-equal input "") (setq input def)) - (split-string input crm-separator))) + ;; Remove empty strings in the list of read strings. + (split-string input crm-separator t))) (remove-hook 'choose-completion-string-functions 'crm--choose-completion-string))) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 188c0800eb8..0728e86d072 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -1,6 +1,7 @@ -;;; 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-2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1994, 2001-2013 Free Software Foundation, +;; Inc. ;; Maintainer: FSF ;; Keywords: lisp, tools, maint @@ -49,9 +50,9 @@ the middle is discarded, and just the beginning and end are displayed." :version "21.1") (defcustom debugger-bury-or-kill 'bury - "How to proceed with the debugger buffer when exiting `debug'. -The value used here affects the behavior of operations on any -window previously showing the debugger buffer. + "What to do with the debugger buffer when exiting `debug'. +The value affects the behavior of operations on any window +previously showing the debugger buffer. `nil' means that if its window is not deleted when exiting the debugger, invoking `switch-to-prev-buffer' will usually show @@ -75,14 +76,11 @@ window previously showing the debugger buffer. The value used here is passed to `quit-restore-window'." :type '(choice (const :tag "Keep alive" nil) - (const :tag "Append" 'append) - (const :tag "Bury" 'bury) - (const :tag "Kill" 'kill)) + (const :tag "Append" append) + (const :tag "Bury" bury) + (const :tag "Kill" kill)) :group 'debugger - :version "24.2") - -(defvar debug-function-list nil - "List of functions currently set for debug on entry.") + :version "24.3") (defvar debugger-step-after-exit nil "Non-nil means \"single-step\" after the debugger exits.") @@ -96,6 +94,9 @@ The value used here is passed to `quit-restore-window'." (defvar debugger-previous-window nil "This is the window last showing the debugger buffer.") +(defvar debugger-previous-window-height nil + "The last recorded height of `debugger-previous-window'.") + (defvar debugger-previous-backtrace nil "The contents of the previous backtrace (including text properties). This is to optimize `debugger-make-xrefs'.") @@ -107,10 +108,6 @@ This is to optimize `debugger-make-xrefs'.") (defvar debugger-outer-track-mouse) (defvar debugger-outer-last-command) (defvar debugger-outer-this-command) -;; unread-command-char is obsolete, -;; but we still save and restore it -;; in case some user program still tries to set it. -(defvar debugger-outer-unread-command-char) (defvar debugger-outer-unread-command-events) (defvar debugger-outer-unread-post-input-method-events) (defvar debugger-outer-last-input-event) @@ -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. @@ -162,13 +159,13 @@ first will be printed into the backtrace buffer." (unless noninteractive (message "Entering debugger...")) (let (debugger-value - (debug-on-error nil) - (debug-on-quit nil) (debugger-previous-state (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) (debugger-step-after-exit nil) (debugger-will-be-back nil) @@ -184,8 +181,6 @@ first will be printed into the backtrace buffer." (debugger-outer-track-mouse track-mouse) (debugger-outer-last-command last-command) (debugger-outer-this-command this-command) - (debugger-outer-unread-command-char - (with-no-warnings unread-command-char)) (debugger-outer-unread-command-events unread-command-events) (debugger-outer-unread-post-input-method-events unread-post-input-method-events) @@ -217,14 +212,13 @@ first will be printed into the backtrace buffer." (or enable-recursive-minibuffers (> (minibuffer-depth) 0))) (standard-input t) (standard-output t) inhibit-redisplay - (cursor-in-echo-area nil)) + (cursor-in-echo-area nil) + (window-configuration (current-window-configuration))) (unwind-protect (save-excursion - (with-no-warnings - (setq unread-command-char -1)) (when (eq (car debugger-args) 'debug) ;; Skip the frames for backtrace-debug, byte-code, - ;; and implement-debug-on-entry. + ;; 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 4)))) @@ -236,7 +230,17 @@ first will be printed into the backtrace buffer." . (,(when debugger-previous-window `(previous-window . ,debugger-previous-window))))) (setq debugger-window (selected-window)) - (setq debugger-previous-window debugger-window) + (if (eq debugger-previous-window debugger-window) + (when debugger-jumping-flag + ;; Try to restore previous height of debugger + ;; window. + (condition-case nil + (window-resize + debugger-window + (- debugger-previous-window-height + (window-total-size debugger-window))) + (error nil))) + (setq debugger-previous-window debugger-window)) (debugger-mode) (debugger-setup-buffer debugger-args) (when noninteractive @@ -264,8 +268,19 @@ first will be printed into the backtrace buffer." (recursive-edit)))) (when (and (window-live-p debugger-window) (eq (window-buffer debugger-window) debugger-buffer)) - ;; Unshow debugger-buffer. - (quit-restore-window debugger-window debugger-bury-or-kill)) + ;; Record height of debugger window. + (setq debugger-previous-window-height + (window-total-size debugger-window))) + (if debugger-will-be-back + ;; Restore previous window configuration (Bug#12623). + (set-window-configuration window-configuration) + (when (and (window-live-p debugger-window) + (eq (window-buffer debugger-window) debugger-buffer)) + (progn + ;; Unshow debugger-buffer. + (quit-restore-window debugger-window debugger-bury-or-kill) + ;; Restore current buffer (Bug#12502). + (set-buffer debugger-old-buffer)))) ;; Restore previous state of debugger-buffer in case we were ;; in a recursive invocation of the debugger, otherwise just ;; erase the buffer and put it into fundamental mode. @@ -288,8 +303,6 @@ first will be printed into the backtrace buffer." (setq track-mouse debugger-outer-track-mouse) (setq last-command debugger-outer-last-command) (setq this-command debugger-outer-this-command) - (with-no-warnings - (setq unread-command-char debugger-outer-unread-command-char)) (setq unread-command-events debugger-outer-unread-command-events) (setq unread-post-input-method-events debugger-outer-unread-post-input-method-events) @@ -304,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) @@ -320,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) @@ -342,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 @@ -350,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, @@ -511,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)) @@ -591,16 +607,7 @@ Applies to the frame whose line point is on in the backtrace." (cursor-in-echo-area debugger-outer-cursor-in-echo-area)) (set-match-data debugger-outer-match-data) (prog1 - (let ((save-ucc (with-no-warnings unread-command-char))) - (unwind-protect - (progn - (with-no-warnings - (setq unread-command-char debugger-outer-unread-command-char)) - (prog1 (progn ,@body) - (with-no-warnings - (setq debugger-outer-unread-command-char unread-command-char)))) - (with-no-warnings - (setq unread-command-char save-ucc)))) + (progn ,@body) (setq debugger-outer-match-data (match-data)) (setq debugger-outer-load-read-function load-read-function) (setq debugger-outer-overriding-terminal-local-map @@ -689,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) @@ -772,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." @@ -780,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. @@ -803,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 @@ -812,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. @@ -852,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." @@ -935,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 ea72e9492f0..96c223c9e18 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -1,7 +1,8 @@ ;;; derived.el --- allow inheritance of major modes ;; (formerly mode-clone.el) -;; Copyright (C) 1993-1994, 1999, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 1999, 2001-2013 Free Software Foundation, +;; Inc. ;; Author: David Megginson (dmeggins@aix1.uottawa.ca) ;; Maintainer: FSF @@ -191,12 +192,11 @@ See Info node `(elisp)Derived Modes' for more details." parent child docstring syntax abbrev)) `(progn - (unless (get ',hook 'variable-documentation) - (put ',hook 'variable-documentation - (purecopy ,(format "Hook run when entering %s mode. + (defvar ,hook nil + ,(format "Hook run after entering %s mode. No problems result if this variable is not bound. `add-hook' automatically binds it. (This is true for all hook variables.)" - name)))) + name)) (unless (boundp ',map) (put ',map 'definition-name ',child)) (with-no-warnings (defvar ,map (make-sparse-keymap))) @@ -276,10 +276,10 @@ A mode's class is the first ancestor which is NOT a derived mode. Use the `derived-mode-parent' property of the symbol to trace backwards. Since major-modes might all derive from `fundamental-mode', this function is not very useful." + (declare (obsolete derived-mode-p "22.1")) (while (get mode 'derived-mode-parent) (setq mode (get mode 'derived-mode-parent))) mode) -(make-obsolete 'derived-mode-class 'derived-mode-p "22.1") ;;; PRIVATE @@ -295,16 +295,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/disass.el b/lisp/emacs-lisp/disass.el index 206166bc77a..dc0e55df500 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -1,6 +1,6 @@ ;;; disass.el --- disassembler for compiled Emacs Lisp code -;; Copyright (C) 1986, 1991, 2002-2012 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1991, 2002-2013 Free Software Foundation, Inc. ;; Author: Doug Cutting <doug@csli.stanford.edu> ;; Jamie Zawinski <jwz@lucid.com> diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index ee4e36a9eba..ed10080cc35 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -1,6 +1,6 @@ ;;; easy-mmode.el --- easy definition for major and minor modes -;; Copyright (C) 1997, 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2000-2013 Free Software Foundation, Inc. ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> ;; Maintainer: Stefan Monnier <monnier@gnu.org> @@ -90,12 +90,17 @@ MODE (you can override this with the :variable keyword, see below). DOC is the documentation for the mode toggle command. The defined mode command takes one optional (prefix) argument. -Interactively with no prefix argument it toggles the mode. -With a prefix argument, it enables the mode if the argument is -positive and otherwise disables it. When called from Lisp, it -enables the mode if the argument is omitted or nil, and toggles -the mode if the argument is `toggle'. If DOC is nil this -function adds a basic doc-string stating these facts. +Interactively with no prefix argument, it toggles the mode. +A prefix argument enables the mode if the argument is positive, +and disables it otherwise. + +When called from Lisp, the mode command toggles the mode if the +argument is `toggle', disables the mode if the argument is a +non-positive integer, and enables the mode otherwise (including +if the argument is omitted or nil or a positive integer). + +If DOC is nil, give the mode command a basic doc-string +documenting what its argument does. Optional INIT-VALUE is the initial value of the mode's variable. Optional LIGHTER is displayed in the mode line when the mode is on. @@ -127,13 +132,14 @@ BODY contains code to execute each time the mode is enabled or disabled. :require SYM Same as in `defcustom'. :variable PLACE The location to use instead of the variable MODE to store the state of the mode. This can be simply a different - named variable, or more generally anything that can be used - with the CL macro `setf'. PLACE can also be of the form - \(GET . SET), where GET is an expression that returns the - current state, and SET is a function that takes one argument, - the new state, and sets it. If you specify a :variable, - this function does not define a MODE variable (nor any of - the terms used in :variable). + named variable, or a generalized variable. + PLACE can also be of the form \(GET . SET), where GET is + an expression that returns the current state, and SET is + a function that takes one argument, the new state, and + sets it. If you specify a :variable, this function does + not define a MODE variable (nor any of the terms used + in :variable). + :after-hook A single lisp form which is evaluated after the mode hooks have been run. It should not be quoted. @@ -290,6 +296,12 @@ the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. ;; up-to-here. :autoload-end + (defvar ,hook nil + ,(format "Hook run after entering or leaving `%s'. +No problems result if this variable is not bound. +`add-hook' automatically binds it. (This is true for all hook variables.)" + mode)) + ;; Define the minor-mode keymap. ,(unless (symbolp keymap) ;nil is also a symbol. `(defvar ,keymap-sym @@ -335,9 +347,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) @@ -348,6 +365,8 @@ 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"))) + (minor-MODE-hook (intern (concat mode-name "-hook"))) + (MODE-set-explicitly (intern (concat mode-name "-set-explicitly"))) (MODE-major-mode (intern (concat (symbol-name mode) "-major-mode"))) keyw) @@ -391,13 +410,9 @@ 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) - (remove-hook 'change-major-mode-after-body-hook - ',MODE-enable-in-buffers) (remove-hook 'find-file-hook ',MODE-check-buffers) (remove-hook 'change-major-mode-hook ',MODE-cmhh)) @@ -410,6 +425,17 @@ See `%s' for more information on %s." ;; up-to-here. :autoload-end + ;; MODE-set-explicitly is set in MODE-set-explicitly and cleared by + ;; kill-all-local-variables. + (defvar-local ,MODE-set-explicitly nil) + (defun ,MODE-set-explicitly () + (setq ,MODE-set-explicitly t)) + (put ',MODE-set-explicitly 'definition-name ',global-mode) + + ;; 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-set-explicitly) + ;; List of buffers left to process. (defvar ,MODE-buffers nil) @@ -418,14 +444,14 @@ 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))))))) + (unless ,MODE-set-explicitly + (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,18 +470,9 @@ See `%s' for more information on %s." ;;; easy-mmode-defmap ;;; -(eval-and-compile - (if (fboundp 'set-keymap-parents) - (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents) - (defun easy-mmode-set-keymap-parents (m parents) - (set-keymap-parent - m - (cond - ((not (consp parents)) parents) - ((not (cdr parents)) (car parents)) - (t (let ((m (copy-keymap (pop parents)))) - (easy-mmode-set-keymap-parents m parents) - m))))))) +(defun easy-mmode-set-keymap-parents (m parents) + (set-keymap-parent + m (if (cdr parents) (make-composed-keymap parents) (car parents)))) ;;;###autoload (defun easy-mmode-define-keymap (bs &optional name m args) diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 7f9f8a33634..f33ae54bf25 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -1,6 +1,6 @@ ;;; easymenu.el --- support the easymenu interface for defining a menu -;; Copyright (C) 1994, 1996, 1998-2012 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1996, 1998-2013 Free Software Foundation, Inc. ;; Keywords: emulations ;; Author: Richard Stallman <rms@gnu.org> @@ -44,111 +44,102 @@ menus, turn this variable off, otherwise it is probably better to keep it on.") ;;;###autoload (defmacro easy-menu-define (symbol maps doc menu) - "Define a menu bar submenu in maps MAPS, according to MENU. + "Define a pop-up menu and/or menu bar menu specified by MENU. +If SYMBOL is non-nil, define SYMBOL as a function to pop up the +submenu defined by MENU, with DOC as its doc string. -If SYMBOL is non-nil, store the menu keymap in the value of SYMBOL, -and define SYMBOL as a function to pop up the menu, with DOC as its doc string. -If SYMBOL is nil, just store the menu keymap into MAPS. +MAPS, if non-nil, should be a keymap or a list of keymaps; add +the submenu defined by MENU to the keymap or each of the keymaps, +as a top-level menu bar item. -The first element of MENU must be a string. It is the menu bar item name. -It may be followed by the following keyword argument pairs +The first element of MENU must be a string. It is the menu bar +item name. It may be followed by the following keyword argument +pairs: - :filter FUNCTION + :filter FUNCTION + FUNCTION must be a function which, if called with one + argument---the list of the other menu items---returns the + items to actually display. -FUNCTION is a function with one argument, the rest of menu items. -It returns the remaining items of the displayed menu. + :visible INCLUDE + INCLUDE is an expression. The menu is visible if the + expression evaluates to a non-nil value. `:included' is an + alias for `:visible'. - :visible INCLUDE + :active ENABLE + ENABLE is an expression. The menu is enabled for selection + if the expression evaluates to a non-nil value. `:enable' is + an alias for `:active'. -INCLUDE is an expression; this menu is only visible if this -expression has a non-nil value. `:included' is an alias for `:visible'. +The rest of the elements in MENU are menu items. +A menu item can be a vector of three elements: - :active ENABLE - -ENABLE is an expression; the menu is enabled for selection whenever -this expression's value is non-nil. `:enable' is an alias for `:active'. - -The rest of the elements in MENU, are menu items. - -A menu item is usually a vector of three elements: [NAME CALLBACK ENABLE] + [NAME CALLBACK ENABLE] NAME is a string--the menu item name. -CALLBACK is a command to run when the item is chosen, -or a list to evaluate when the item is chosen. +CALLBACK is a command to run when the item is chosen, or an +expression to evaluate when the item is chosen. -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. +ENABLE is an expression; the item is enabled for selection if the +expression evaluates to a non-nil value. Alternatively, a menu item may have the form: - [ NAME CALLBACK [ KEYWORD ARG ] ... ] - -Where KEYWORD is one of the symbols defined below. - - :keys KEYS - -KEYS is a string; a complex keyboard equivalent to this menu item. -This is normally not needed because keyboard equivalents are usually -computed automatically. -KEYS is expanded with `substitute-command-keys' before it is used. - - :key-sequence KEYS - -KEYS is nil, a string or a vector; nil or a keyboard equivalent to this -menu item. -This is a hint that will considerably speed up Emacs's first display of -a menu. Use `:key-sequence nil' when you know that this menu item has no -keyboard equivalent. - - :active ENABLE - -ENABLE is an expression; the item is enabled for selection whenever -this expression's value is non-nil. `:enable' is an alias for `:active'. - - :visible INCLUDE - -INCLUDE is an expression; this item is only visible if this -expression has a non-nil value. `:included' is an alias for `:visible'. - - :label FORM + [ NAME CALLBACK [ KEYWORD ARG ]... ] -FORM is an expression that will be dynamically evaluated and whose -value will be used for the menu entry's text label (the default is NAME). +where NAME and CALLBACK have the same meanings as above, and each +optional KEYWORD and ARG pair should be one of the following: - :suffix FORM + :keys KEYS + KEYS is a string; a keyboard equivalent to the menu item. + This is normally not needed because keyboard equivalents are + usually computed automatically. KEYS is expanded with + `substitute-command-keys' before it is used. -FORM is an expression that will be dynamically evaluated and whose -value will be concatenated to the menu entry's label. + :key-sequence KEYS + KEYS is a hint for speeding up Emacs's first display of the + menu. It should be nil if you know that the menu item has no + keyboard equivalent; otherwise it should be a string or + vector specifying a keyboard equivalent for the menu item. - :style STYLE + :active ENABLE + ENABLE is an expression; the item is enabled for selection + whenever this expression's value is non-nil. `:enable' is an + alias for `:active'. -STYLE is a symbol describing the type of menu item. The following are -defined: + :visible INCLUDE + INCLUDE is an expression; this item is only visible if this + expression has a non-nil value. `:included' is an alias for + `:visible'. -toggle: A checkbox. - Prepend the name with `(*) ' or `( ) ' depending on if selected or not. -radio: A radio button. - Prepend the name with `[X] ' or `[ ] ' depending on if selected or not. -button: Surround the name with `[' and `]'. Use this for an item in the - menu bar itself. -anything else means an ordinary menu item. + :label FORM + FORM is an expression that is dynamically evaluated and whose + value serves as the menu item's label (the default is NAME). - :selected SELECTED + :suffix FORM + FORM is an expression that is dynamically evaluated and whose + value is concatenated with the menu entry's label. -SELECTED is an expression; the checkbox or radio button is selected -whenever this expression's value is non-nil. + :style STYLE + STYLE is a symbol describing the type of menu item; it should + be `toggle' (a checkbox), or `radio' (a radio button), or any + other value (meaning an ordinary menu item). - :help HELP + :selected SELECTED + SELECTED is an expression; the checkbox or radio button is + selected whenever the expression's value is non-nil. -HELP is a string, the help to display for the menu item. + :help HELP + HELP is a string, the help to display for the menu item. -A menu item can be a string. Then that string appears in the menu as -unselectable text. A string consisting solely of hyphens is displayed -as a solid horizontal line. +Alternatively, a menu item can be a string. Then that string +appears in the menu as unselectable text. A string consisting +solely of dashes is displayed as a menu separator. -A menu item can be a list with the same format as MENU. This is a submenu." - (declare (indent defun)) +Alternatively, a menu item can be a list with the same format as +MENU. This is a submenu." + (declare (indent defun) (debug (symbolp body))) `(progn ,(if symbol `(defvar ,symbol nil ,doc)) (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 7fcd339d6d2..319af588eac 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1,6 +1,7 @@ -;;; edebug.el --- a source-level debugger for Emacs Lisp +;;; edebug.el --- a source-level debugger for Emacs Lisp -*- lexical-binding: t -*- -;; Copyright (C) 1988-1995, 1997, 1999-2012 Free Software Foundation, Inc. +;; Copyright (C) 1988-1995, 1997, 1999-2013 Free Software Foundation, +;; Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> ;; Maintainer: FSF @@ -52,10 +53,8 @@ ;;; Code: (require 'macroexp) - -;;; Bug reporting - -(defalias 'edebug-submit-bug-report 'report-emacs-bug) +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'pcase)) ;;; Options @@ -235,14 +234,9 @@ If the result is non-nil, then break. Errors are ignored." ;;; Form spec utilities. -(defmacro def-edebug-form-spec (symbol spec-form) - "For compatibility with old version." - (def-edebug-spec symbol (eval spec-form))) -(make-obsolete 'def-edebug-form-spec 'def-edebug-spec "22.1") - (defun get-edebug-spec (symbol) ;; Get the spec of symbol resolving all indirection. - (let ((edebug-form-spec nil) + (let ((spec nil) (indirect symbol)) (while (progn @@ -250,9 +244,8 @@ If the result is non-nil, then break. Errors are ignored." (setq indirect (function-get indirect 'edebug-form-spec 'macro)))) ;; (edebug-trace "indirection: %s" edebug-form-spec) - (setq edebug-form-spec indirect)) - edebug-form-spec - )) + (setq spec indirect)) + spec)) ;;;###autoload (defun edebug-basic-spec (spec) @@ -342,9 +335,7 @@ A lambda list keyword is a symbol that starts with `&'." (lambda (e1 e2) (funcall function (car e1) (car e2)))))) -;;(def-edebug-spec edebug-save-restriction t) - -;; Not used. If it is used, def-edebug-spec must be defined before use. +;; Not used. '(defmacro edebug-save-restriction (&rest body) "Evaluate BODY while saving the current buffers restriction. BODY may change buffer outside of current restriction, unlike @@ -352,6 +343,7 @@ save-restriction. BODY may change the current buffer, and the restriction will be restored to the original buffer, and the current buffer remains current. Return the result of the last expression in BODY." + (declare (debug t)) `(let ((edebug:s-r-beg (point-min-marker)) (edebug:s-r-end (point-max-marker))) (unwind-protect @@ -369,6 +361,7 @@ Return the result of the last expression in BODY." ;; Select WINDOW if it is provided and still exists. Otherwise, ;; if buffer is currently shown in several windows, choose one. ;; Otherwise, find a new window, possibly splitting one. + ;; FIXME: We should probably just be using `pop-to-buffer'. (setq window (cond ((and (edebug-window-live-p window) @@ -377,10 +370,10 @@ Return the result of the last expression in BODY." ((eq (window-buffer (selected-window)) buffer) ;; Selected window already displays BUFFER. (selected-window)) - ((edebug-get-buffer-window buffer)) + ((get-buffer-window buffer 0)) ((one-window-p 'nomini) ;; When there's one window only, split it. - (split-window)) + (split-window (minibuffer-selected-window))) ((let ((trace-window (get-buffer-window edebug-trace-buffer))) (catch 'found (dolist (elt (window-list nil 'nomini)) @@ -391,13 +384,10 @@ Return the result of the last expression in BODY." (throw 'found elt)))))) ;; All windows are dedicated or show `edebug-trace-buffer', split ;; selected one. - (t (split-window)))) - (select-window window) + (t (split-window (minibuffer-selected-window))))) (set-window-buffer window buffer) - (set-window-hscroll window 0);; should this be?? - ;; Selecting the window does not set the buffer until command loop. - ;;(set-buffer buffer) - ) + (select-window window) + (set-window-hscroll window 0)) ;; should this be?? (defun edebug-get-displayed-buffer-points () ;; Return a list of buffer point pairs, for all displayed buffers. @@ -450,18 +440,14 @@ Return the result of the last expression in BODY." window-info) (set-window-configuration window-info))) -(defalias 'edebug-get-buffer-window 'get-buffer-window) -(defalias 'edebug-sit-for 'sit-for) -(defalias 'edebug-input-pending-p 'input-pending-p) - - ;;; Redefine read and eval functions ;; read is redefined to maybe instrument forms. ;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs. ;; Save the original read function -(or (fboundp 'edebug-original-read) - (defalias 'edebug-original-read (symbol-function 'read))) +(defalias 'edebug-original-read + (symbol-function (if (fboundp 'edebug-original-read) + 'edebug-original-read 'read))) (defun edebug-read (&optional stream) "Read one Lisp expression as text from STREAM, return as Lisp object. @@ -476,8 +462,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) @@ -486,6 +472,8 @@ also dependent on the values of `edebug-all-defs' and (or (fboundp 'edebug-original-eval-defun) (defalias 'edebug-original-eval-defun (symbol-function 'eval-defun))) +(defvar edebug-result) ; The result of the function call returned by body. + ;; We should somehow arrange to be able to do this ;; without actually replacing the eval-defun command. (defun edebug-eval-defun (edebug-it) @@ -499,9 +487,9 @@ 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 -invoked without a prefix argument +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, `Edebug: FUNCTION' is printed in the minibuffer. If not instrumented, @@ -626,36 +614,29 @@ already is one.)" ;; The internal data that is needed for edebugging is kept in the ;; buffer-local variable `edebug-form-data'. -(make-variable-buffer-local 'edebug-form-data) - -(defvar edebug-form-data nil) -;; A list of entries associating symbols with buffer regions. -;; This is an automatic buffer local variable. Each entry looks like: -;; @code{(@var{symbol} @var{begin-marker} @var{end-marker}). The markers -;; are at the beginning and end of an entry level form and @var{symbol} is -;; a symbol that holds all edebug related information for the form on its -;; property list. - -;; In the future, the symbol will be irrelevant and edebug data will -;; be stored in the definitions themselves rather than in the property -;; list of a symbol. - -(defun edebug-make-form-data-entry (symbol begin end) - (list symbol begin end)) - -(defsubst edebug-form-data-name (entry) - (car entry)) - -(defsubst edebug-form-data-begin (entry) - (nth 1 entry)) - -(defsubst edebug-form-data-end (entry) - (nth 2 entry)) +(defvar-local edebug-form-data nil + "A list of entries associating symbols with buffer regions. +Each entry is an `edebug--form-data' struct with fields: +SYMBOL, BEGIN-MARKER, and END-MARKER. The markers +are at the beginning and end of an entry level form and SYMBOL is +a symbol that holds all edebug related information for the form on its +property list. + +In the future (haha!), the symbol will be irrelevant and edebug data will +be stored in the definitions themselves rather than in the property +list of a symbol.") + +(cl-defstruct (edebug--form-data + ;; Some callers expect accessors to return nil when passed nil. + (:type list) + (:constructor edebug--make-form-data-entry (name begin end)) + (:predicate nil) (:constructor nil) (:copier nil)) + name begin end) (defsubst edebug-set-form-data-entry (entry name begin end) - (setcar entry name);; in case name is changed - (set-marker (nth 1 entry) begin) - (set-marker (nth 2 entry) end)) + (setf (edebug--form-data-name entry) name) ;; In case name is changed. + (set-marker (edebug--form-data-begin entry) begin) + (set-marker (edebug--form-data-end entry) end)) (defun edebug-get-form-data-entry (pnt &optional end-point) ;; Find the edebug form data entry which is closest to PNT. @@ -663,17 +644,17 @@ already is one.)" ;; Return `nil' if none found. (let ((rest edebug-form-data) closest-entry - (closest-dist 999999)) ;; need maxint here + (closest-dist 999999)) ;; Need maxint here. (while (and rest (< 0 closest-dist)) (let* ((entry (car rest)) - (begin (edebug-form-data-begin entry)) + (begin (edebug--form-data-begin entry)) (dist (- pnt begin))) (setq rest (cdr rest)) (if (and (<= 0 dist) (< dist closest-dist) (or (not end-point) - (= end-point (edebug-form-data-end entry))) - (<= pnt (edebug-form-data-end entry))) + (= end-point (edebug--form-data-end entry))) + (<= pnt (edebug--form-data-end entry))) (setq closest-dist dist closest-entry entry)))) closest-entry)) @@ -682,19 +663,19 @@ already is one.)" ;; and find an entry given a symbol, which should be just assq. (defun edebug-form-data-symbol () -;; Return the edebug data symbol of the form where point is in. -;; If point is not inside a edebuggable form, cause error. - (or (edebug-form-data-name (edebug-get-form-data-entry (point))) + "Return the edebug data symbol of the form where point is in. +If point is not inside a edebuggable form, cause error." + (or (edebug--form-data-name (edebug-get-form-data-entry (point))) (error "Not inside instrumented form"))) (defun edebug-make-top-form-data-entry (new-entry) ;; Make NEW-ENTRY the first element in the `edebug-form-data' list. (edebug-clear-form-data-entry new-entry) - (setq edebug-form-data (cons new-entry edebug-form-data))) + (push new-entry edebug-form-data)) (defun edebug-clear-form-data-entry (entry) -;; If non-nil, clear ENTRY out of the form data. -;; Maybe clear the markers and delete the symbol's edebug property? + "If non-nil, clear ENTRY out of the form data. +Maybe clear the markers and delete the symbol's edebug property?" (if entry (progn ;; Instead of this, we could just find all contained forms. @@ -1086,7 +1067,8 @@ already is one.)" ;; If it gets an error, make it nil. (let ((temp-hook edebug-setup-hook)) (setq edebug-setup-hook nil) - (run-hooks 'temp-hook)) + (if (functionp temp-hook) (funcall temp-hook) + (mapc #'funcall temp-hook))) (let (result edebug-top-window-data @@ -1223,8 +1205,8 @@ already is one.)" (defvar edebug-offset-list) ; the list of offset positions. (defun edebug-inc-offset (offset) - ;; modifies edebug-offset-index and edebug-offset-list - ;; accesses edebug-func-marc and buffer point + ;; Modifies edebug-offset-index and edebug-offset-list + ;; accesses edebug-func-marc and buffer point. (prog1 edebug-offset-index (setq edebug-offset-list (cons (- offset edebug-form-begin-marker) @@ -1237,13 +1219,11 @@ already is one.)" ;; given FORM. Looks like: ;; (edebug-after (edebug-before BEFORE-INDEX) AFTER-INDEX FORM) ;; Also increment the offset index for subsequent use. - (list 'edebug-after - (list 'edebug-before before-index) - after-index form)) + `(edebug-after (edebug-before ,before-index) ,after-index ,form)) (defun edebug-make-after-form (form after-index) ;; Like edebug-make-before-and-after-form, but only after. - (list 'edebug-after 0 after-index form)) + `(edebug-after 0 ,after-index ,form)) (defun edebug-unwrap (sexp) @@ -1293,7 +1273,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Set this marker before parsing. (edebug-form-begin-marker (if form-data-entry - (edebug-form-data-begin form-data-entry) + (edebug--form-data-begin form-data-entry) ;; Buffer must be current-buffer for this to work: (set-marker (make-marker) form-begin)))) @@ -1303,7 +1283,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; For definitions. ;; (edebug-containing-def-name edebug-def-name) ;; Get name from form-data, if any. - (edebug-old-def-name (edebug-form-data-name form-data-entry)) + (edebug-old-def-name (edebug--form-data-name form-data-entry)) edebug-def-name edebug-def-args edebug-def-interactive @@ -1333,7 +1313,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; In the latter case, pointers to the entry remain eq. (if (not form-data-entry) (setq form-data-entry - (edebug-make-form-data-entry + (edebug--make-form-data-entry edebug-def-name edebug-form-begin-marker ;; Buffer must be current-buffer. @@ -1519,18 +1499,18 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Otherwise it signals an error. The place of the error is found ;; with the two before- and after-offset functions. -(defun edebug-no-match (cursor &rest edebug-args) +(defun edebug-no-match (cursor &rest args) ;; Throw a no-match, or signal an error immediately if gate is active. ;; Remember this point in case we need to report this error. (setq edebug-error-point (or edebug-error-point (edebug-before-offset cursor)) - edebug-best-error (or edebug-best-error edebug-args)) + edebug-best-error (or edebug-best-error args)) (if (and edebug-gate (not edebug-&optional)) (progn (if edebug-error-point (goto-char edebug-error-point)) - (apply 'edebug-syntax-error edebug-args)) - (funcall 'throw 'no-match edebug-args))) + (apply 'edebug-syntax-error args)) + (throw 'no-match args))) (defun edebug-match (cursor specs) @@ -1757,7 +1737,7 @@ expressions; a `progn' form will be returned enclosing these forms." specs)))) -(defun edebug-match-gate (cursor) +(defun edebug-match-gate (_cursor) ;; Simply set the gate to prevent backtracking at this level. (setq edebug-gate t) nil) @@ -1846,7 +1826,7 @@ expressions; a `progn' form will be returned enclosing these forms." nil)) -(defun edebug-match-function (cursor) +(defun edebug-match-function (_cursor) (error "Use function-form instead of function in edebug spec")) (defun edebug-match-&define (cursor specs) @@ -1903,7 +1883,7 @@ expressions; a `progn' form will be returned enclosing these forms." (edebug-move-cursor cursor) (list name))) -(defun edebug-match-colon-name (cursor spec) +(defun edebug-match-colon-name (_cursor spec) ;; Set the edebug-def-name to the spec. (setq edebug-def-name (if edebug-def-name @@ -1988,6 +1968,8 @@ expressions; a `progn' form will be returned enclosing these forms." def-body)) ;; FIXME? Isn't this missing the doc-string? Cf defun. (def-edebug-spec defmacro + ;; FIXME: Improve `declare' so we can Edebug gv-expander and + ;; gv-setter declarations. (&define name lambda-list [&optional ("declare" &rest sexp)] def-body)) (def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list. @@ -2018,11 +2000,6 @@ expressions; a `progn' form will be returned enclosing these forms." ;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro]))) ;; Standard functions that take function-forms arguments. -(def-edebug-spec mapcar (function-form form)) -(def-edebug-spec mapconcat (function-form form form)) -(def-edebug-spec mapatoms (function-form &optional form)) -(def-edebug-spec apply (function-form &rest form)) -(def-edebug-spec funcall (function-form &rest form)) ;; FIXME? The manual uses this form (maybe that's just for illustration?): ;; (def-edebug-spec let @@ -2088,58 +2065,16 @@ expressions; a `progn' form will be returned enclosing these forms." &or ("quote" edebug-\`) def-form)) ;; New byte compiler. -(def-edebug-spec defsubst defun) -(def-edebug-spec dont-compile t) -(def-edebug-spec eval-when-compile t) -(def-edebug-spec eval-and-compile t) (def-edebug-spec save-selected-window t) (def-edebug-spec save-current-buffer t) -(def-edebug-spec delay-mode-hooks t) -(def-edebug-spec with-temp-file t) -(def-edebug-spec with-temp-message t) -(def-edebug-spec with-syntax-table t) -(def-edebug-spec push (form sexp)) -(def-edebug-spec pop (sexp)) - -(def-edebug-spec 1value (form)) -(def-edebug-spec noreturn (form)) - ;; Anything else? - -;; Some miscellaneous specs for macros in public packages. -;; Send me yours. - -;; advice.el by Hans Chalupsky (hans@cs.buffalo.edu) - -(def-edebug-spec ad-dolist ((symbolp form &optional form) body)) -(def-edebug-spec defadvice - (&define name ;; thing being advised. - (name ;; class is [&or "before" "around" "after" - ;; "activation" "deactivation"] - name ;; name of advice - &rest sexp ;; optional position and flags - ) - [&optional stringp] - [&optional ("interactive" interactive)] - def-body)) - -(def-edebug-spec easy-menu-define (symbolp body)) - -(def-edebug-spec with-custom-print body) - - ;;; The debugger itself (defvar edebug-active nil) ;; Non-nil when edebug is active -;;; add minor-mode-alist entry -(or (assq 'edebug-active minor-mode-alist) - (setq minor-mode-alist (cons (list 'edebug-active " *Debugging*") - minor-mode-alist))) - (defvar edebug-stack nil) ;; Stack of active functions evaluated via edebug. ;; Should be nil at the top level. @@ -2167,16 +2102,12 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Dynamically bound variables, declared globally but left unbound. (defvar edebug-function) ; the function being executed. change name!! -(defvar edebug-args) ; the arguments of the function (defvar edebug-data) ; the edebug data for the function -(defvar edebug-value) ; the result of the expression -(defvar edebug-after-index) (defvar edebug-def-mark) ; the mark for the definition (defvar edebug-freq-count) ; the count of expression visits. (defvar edebug-coverage) ; the coverage results of each expression of function. (defvar edebug-buffer) ; which buffer the function is in. -(defvar edebug-result) ; the result of the function call returned by body (defvar edebug-outside-executing-macro) (defvar edebug-outside-defining-kbd-macro) @@ -2186,8 +2117,6 @@ expressions; a `progn' form will be returned enclosing these forms." (defvar edebug-outside-debug-on-error) ; the value of debug-on-error outside (defvar edebug-outside-debug-on-quit) ; the value of debug-on-quit outside -(defvar edebug-outside-overriding-local-map) -(defvar edebug-outside-overriding-terminal-local-map) (defvar edebug-outside-pre-command-hook) (defvar edebug-outside-post-command-hook) @@ -2196,7 +2125,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;;; Handling signals -(defun edebug-signal (edebug-signal-name edebug-signal-data) +(defun edebug-signal (signal-name signal-data) "Signal an error. Args are SIGNAL-NAME, and associated DATA. A signal name is a symbol with an `error-conditions' property that is a list of condition names. @@ -2210,19 +2139,18 @@ See `condition-case'. This is the Edebug replacement for the standard `signal'. It should only be active while Edebug is. It checks `debug-on-error' to see whether it should call the debugger. When execution is resumed, the -error is signaled again. -\n(fn SIGNAL-NAME DATA)" - (if (and (listp debug-on-error) (memq edebug-signal-name debug-on-error)) - (edebug 'error (cons edebug-signal-name edebug-signal-data))) +error is signaled again." + (if (and (listp debug-on-error) (memq signal-name debug-on-error)) + (edebug 'error (cons signal-name signal-data))) ;; If we reach here without another non-local exit, then send signal again. ;; i.e. the signal is not continuable, yet. ;; Avoid infinite recursion. (let ((signal-hook-function nil)) - (signal edebug-signal-name edebug-signal-data))) + (signal signal-name signal-data))) ;;; Entering Edebug -(defun edebug-enter (edebug-function edebug-args edebug-body) +(defun edebug-enter (function args body) ;; Entering FUNC. The arguments are ARGS, and the body is BODY. ;; Setup edebug variables and evaluate BODY. This function is called ;; when a function evaluated with edebug-eval-top-level-form is entered. @@ -2231,83 +2159,51 @@ error is signaled again. ;; Is this the first time we are entering edebug since ;; lower-level recursive-edit command? ;; More precisely, this tests whether Edebug is currently active. - (if (not edebug-entered) - (let ((edebug-entered t) - ;; Binding max-lisp-eval-depth here is OK, - ;; but not inside an unwind-protect. - ;; Doing it here also keeps it from growing too large. - (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much?? - (max-specpdl-size (+ 200 max-specpdl-size)) - - (debugger edebug-debugger) ; only while edebug is active. - (edebug-outside-debug-on-error debug-on-error) - (edebug-outside-debug-on-quit debug-on-quit) - ;; Binding these may not be the right thing to do. - ;; We want to allow the global values to be changed. - (debug-on-error (or debug-on-error edebug-on-error)) - (debug-on-quit edebug-on-quit) - - ;; Lexical bindings must be uncompiled for this to work. - (cl-lexical-debug t) - - (edebug-outside-overriding-local-map overriding-local-map) - (edebug-outside-overriding-terminal-local-map - overriding-terminal-local-map) - - ;; Save the outside value of executing macro. (here??) - (edebug-outside-executing-macro executing-kbd-macro) - (edebug-outside-pre-command-hook - (edebug-var-status 'pre-command-hook)) - (edebug-outside-post-command-hook - (edebug-var-status 'post-command-hook))) - (unwind-protect - (let (;; Don't keep reading from an executing kbd macro - ;; within edebug unless edebug-continue-kbd-macro is - ;; non-nil. Again, local binding may not be best. - (executing-kbd-macro - (if edebug-continue-kbd-macro executing-kbd-macro)) - - ;; Don't get confused by the user's keymap changes. - (overriding-local-map nil) - (overriding-terminal-local-map nil) - - (signal-hook-function 'edebug-signal) - - ;; Disable command hooks. This is essential when - ;; a hook function is instrumented - to avoid infinite loop. - ;; This may be more than we need, however. - (pre-command-hook nil) - (post-command-hook nil)) - (setq edebug-execution-mode (or edebug-next-execution-mode - edebug-initial-mode - edebug-execution-mode) - edebug-next-execution-mode nil) - (edebug-enter edebug-function edebug-args edebug-body)) - ;; Reset global variables in case outside value was changed. - (setq executing-kbd-macro edebug-outside-executing-macro) - (edebug-restore-status - 'post-command-hook edebug-outside-post-command-hook) - (edebug-restore-status - 'pre-command-hook edebug-outside-pre-command-hook))) - - (let* ((edebug-data (get edebug-function 'edebug)) - (edebug-def-mark (car edebug-data)) ; mark at def start - (edebug-freq-count (get edebug-function 'edebug-freq-count)) - (edebug-coverage (get edebug-function 'edebug-coverage)) - (edebug-buffer (marker-buffer edebug-def-mark)) - - (edebug-stack (cons edebug-function edebug-stack)) - (edebug-offset-indices (cons 0 edebug-offset-indices)) - ) - (if (get edebug-function 'edebug-on-entry) - (progn - (setq edebug-execution-mode 'step) - (if (eq (get edebug-function 'edebug-on-entry) 'temp) - (put edebug-function 'edebug-on-entry nil)))) - (if edebug-trace - (edebug-enter-trace edebug-body) - (funcall edebug-body)) - ))) + (let ((edebug-function function)) + (if (not edebug-entered) + (let ((edebug-entered t) + ;; Binding max-lisp-eval-depth here is OK, + ;; but not inside an unwind-protect. + ;; Doing it here also keeps it from growing too large. + (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much?? + (max-specpdl-size (+ 200 max-specpdl-size)) + + (debugger edebug-debugger) ; only while edebug is active. + (edebug-outside-debug-on-error debug-on-error) + (edebug-outside-debug-on-quit debug-on-quit) + ;; Binding these may not be the right thing to do. + ;; We want to allow the global values to be changed. + (debug-on-error (or debug-on-error edebug-on-error)) + (debug-on-quit edebug-on-quit) + + ;; Lexical bindings must be uncompiled for this to work. + (cl-lexical-debug t)) + (unwind-protect + (let ((signal-hook-function 'edebug-signal)) + (setq edebug-execution-mode (or edebug-next-execution-mode + edebug-initial-mode + edebug-execution-mode) + edebug-next-execution-mode nil) + (edebug-enter function args body)))) + + (let* ((edebug-data (get function 'edebug)) + (edebug-def-mark (car edebug-data)) ; mark at def start + (edebug-freq-count (get function 'edebug-freq-count)) + (edebug-coverage (get function 'edebug-coverage)) + (edebug-buffer (marker-buffer edebug-def-mark)) + + (edebug-stack (cons function edebug-stack)) + (edebug-offset-indices (cons 0 edebug-offset-indices)) + ) + (if (get function 'edebug-on-entry) + (progn + (setq edebug-execution-mode 'step) + (if (eq (get function 'edebug-on-entry) 'temp) + (put function 'edebug-on-entry nil)))) + (if edebug-trace + (edebug--enter-trace function args body) + (funcall body)) + )))) (defun edebug-var-status (var) "Return a cons cell describing the status of VAR's current binding. @@ -2334,14 +2230,14 @@ STATUS should be a list returned by `edebug-var-status'." (t (set var value))))) -(defun edebug-enter-trace (edebug-body) +(defun edebug--enter-trace (function args body) (let ((edebug-stack-depth (1+ edebug-stack-depth)) edebug-result) (edebug-print-trace-before - (format "%s args: %s" edebug-function edebug-args)) - (prog1 (setq edebug-result (funcall edebug-body)) + (format "%s args: %s" function args)) + (prog1 (setq edebug-result (funcall body)) (edebug-print-trace-after - (format "%s result: %s" edebug-function edebug-result))))) + (format "%s result: %s" function edebug-result))))) (def-edebug-spec edebug-tracing (form body)) @@ -2369,49 +2265,49 @@ MSG is printed after `::::} '." -(defun edebug-slow-before (edebug-before-index) +(defun edebug-slow-before (before-index) (unless edebug-active ;; Debug current function given BEFORE position. ;; Called from functions compiled with edebug-eval-top-level-form. ;; Return the before index. - (setcar edebug-offset-indices edebug-before-index) + (setcar edebug-offset-indices before-index) ;; Increment frequency count - (aset edebug-freq-count edebug-before-index - (1+ (aref edebug-freq-count edebug-before-index))) + (aset edebug-freq-count before-index + (1+ (aref edebug-freq-count before-index))) (if (or (not (memq edebug-execution-mode '(Go-nonstop next))) - (edebug-input-pending-p)) - (edebug-debugger edebug-before-index 'before nil))) - edebug-before-index) + (input-pending-p)) + (edebug-debugger before-index 'before nil))) + before-index) -(defun edebug-fast-before (edebug-before-index) +(defun edebug-fast-before (_before-index) ;; Do nothing. ) -(defun edebug-slow-after (edebug-before-index edebug-after-index edebug-value) +(defun edebug-slow-after (_before-index after-index value) (if edebug-active - edebug-value + value ;; Debug current function given AFTER position and VALUE. ;; Called from functions compiled with edebug-eval-top-level-form. ;; Return VALUE. - (setcar edebug-offset-indices edebug-after-index) + (setcar edebug-offset-indices after-index) ;; Increment frequency count - (aset edebug-freq-count edebug-after-index - (1+ (aref edebug-freq-count edebug-after-index))) - (if edebug-test-coverage (edebug-update-coverage)) + (aset edebug-freq-count after-index + (1+ (aref edebug-freq-count after-index))) + (if edebug-test-coverage (edebug--update-coverage after-index value)) (if (and (eq edebug-execution-mode 'Go-nonstop) - (not (edebug-input-pending-p))) + (not (input-pending-p))) ;; Just return result. - edebug-value - (edebug-debugger edebug-after-index 'after edebug-value) + value + (edebug-debugger after-index 'after value) ))) -(defun edebug-fast-after (edebug-before-index edebug-after-index edebug-value) +(defun edebug-fast-after (_before-index _after-index value) ;; Do nothing but return the value. - edebug-value) + value) (defun edebug-run-slow () (defalias 'edebug-before 'edebug-slow-before) @@ -2425,19 +2321,18 @@ MSG is printed after `::::} '." (edebug-run-slow) -(defun edebug-update-coverage () - (let ((old-result (aref edebug-coverage edebug-after-index))) +(defun edebug--update-coverage (after-index value) + (let ((old-result (aref edebug-coverage after-index))) (cond ((eq 'ok-coverage old-result)) ((eq 'unknown old-result) - (aset edebug-coverage edebug-after-index edebug-value)) + (aset edebug-coverage after-index value)) ;; Test if a different result. - ((not (eq edebug-value old-result)) - (aset edebug-coverage edebug-after-index 'ok-coverage))))) + ((not (eq value old-result)) + (aset edebug-coverage after-index 'ok-coverage))))) ;; Dynamically declared unbound variables. -(defvar edebug-arg-mode) ; the mode, either before, after, or error (defvar edebug-breakpoints) (defvar edebug-break-data) ; break data for current function. (defvar edebug-break) ; whether a break occurred. @@ -2448,16 +2343,16 @@ MSG is printed after `::::} '." (defvar edebug-global-break-result nil) -(defun edebug-debugger (edebug-offset-index edebug-arg-mode edebug-value) +(defun edebug-debugger (offset-index arg-mode value) (if inhibit-redisplay ;; Don't really try to enter edebug within an eval from redisplay. - edebug-value + value ;; Check breakpoints and pending input. - ;; If edebug display should be updated, call edebug-display. - ;; Return edebug-value. + ;; If edebug display should be updated, call edebug--display. + ;; Return value. (let* ( ;; This needs to be here since breakpoints may be changed. (edebug-breakpoints (car (cdr edebug-data))) ; list of breakpoints - (edebug-break-data (assq edebug-offset-index edebug-breakpoints)) + (edebug-break-data (assq offset-index edebug-breakpoints)) (edebug-break-condition (car (cdr edebug-break-data))) (edebug-global-break (if edebug-global-break-condition @@ -2468,7 +2363,7 @@ MSG is printed after `::::} '." (error nil)))) (edebug-break)) -;;; (edebug-trace "exp: %s" edebug-value) + ;;(edebug-trace "exp: %s" value) ;; Test whether we should break. (setq edebug-break (or edebug-global-break @@ -2488,11 +2383,10 @@ MSG is printed after `::::} '." ;; or break, or input is pending, (if (or (not (memq edebug-execution-mode '(go continue Continue-fast))) edebug-break - (edebug-input-pending-p)) - (edebug-display)) ; <--------------- display + (input-pending-p)) + (edebug--display value offset-index arg-mode)) ; <---------- display - edebug-value - ))) + value))) ;; window-start now stored with each function. @@ -2524,8 +2418,9 @@ MSG is printed after `::::} '." ;; Emacs 19 adds an arg to mark and mark-marker. (defalias 'edebug-mark-marker 'mark-marker) +(defvar edebug-outside-unread-command-events) -(defun edebug-display () +(defun edebug--display (value offset-index arg-mode) (unless (marker-position edebug-def-mark) ;; The buffer holding the source has been killed. ;; Let's at least show a backtrace so the user can figure out @@ -2534,11 +2429,11 @@ MSG is printed after `::::} '." ;; Setup windows for edebug, determine mode, maybe enter recursive-edit. ;; Uses local variables of edebug-enter, edebug-before, edebug-after ;; and edebug-debugger. - (let ((edebug-active t) ; for minor mode alist + (let ((edebug-active t) ; For minor mode alist. (edebug-with-timeout-suspend (with-timeout-suspend)) - edebug-stop ; should we enter recursive-edit + edebug-stop ; Should we enter recursive-edit? (edebug-point (+ edebug-def-mark - (aref (nth 2 edebug-data) edebug-offset-index))) + (aref (nth 2 edebug-data) offset-index))) edebug-buffer-outside-point ; current point in edebug-buffer ;; window displaying edebug-buffer (edebug-window-data (nth 3 edebug-data)) @@ -2547,12 +2442,12 @@ MSG is printed after `::::} '." (edebug-outside-point (point)) (edebug-outside-mark (edebug-mark)) (edebug-outside-unread-command-events unread-command-events) - edebug-outside-windows ; window or screen configuration + edebug-outside-windows ; Window or screen configuration. edebug-buffer-points - edebug-eval-buffer ; declared here so we can kill it below - (edebug-eval-result-list (and edebug-eval-list - (edebug-eval-result-list))) + edebug-eval-buffer ; Declared here so we can kill it below. + (eval-result-list (and edebug-eval-list + (edebug-eval-result-list))) edebug-trace-window edebug-trace-window-start @@ -2565,7 +2460,7 @@ MSG is printed after `::::} '." (let ((overlay-arrow-position overlay-arrow-position) (overlay-arrow-string overlay-arrow-string) (cursor-in-echo-area nil) - (unread-command-events unread-command-events) + (unread-command-events nil) ;; any others?? ) (setq-default cursor-in-non-selected-windows t) @@ -2573,9 +2468,9 @@ MSG is printed after `::::} '." (let ((debug-on-error nil)) (error "Buffer defining %s not found" edebug-function))) - (if (eq 'after edebug-arg-mode) + (if (eq 'after arg-mode) ;; Compute result string now before windows are modified. - (edebug-compute-previous-result edebug-value)) + (edebug-compute-previous-result value)) (if edebug-save-windows ;; Save windows now before we modify them. @@ -2599,7 +2494,7 @@ MSG is printed after `::::} '." ;; Now display eval list, if any. ;; This is done after the pop to edebug-buffer ;; so that buffer-window correspondence is correct after quitting. - (edebug-eval-display edebug-eval-result-list) + (edebug-eval-display eval-result-list) ;; The evaluation list better not have deleted edebug-window-data. (select-window (car edebug-window-data)) (set-buffer edebug-buffer) @@ -2607,7 +2502,7 @@ MSG is printed after `::::} '." (setq edebug-buffer-outside-point (point)) (goto-char edebug-point) - (if (eq 'before edebug-arg-mode) + (if (eq 'before arg-mode) ;; Check whether positions are up-to-date. ;; This assumes point is never before symbol. (if (not (memq (following-char) '(?\( ?\# ?\` ))) @@ -2620,7 +2515,7 @@ MSG is printed after `::::} '." (edebug-adjust-window (cdr edebug-window-data))) ;; Test if there is input, not including keyboard macros. - (if (edebug-input-pending-p) + (if (input-pending-p) (progn (setq edebug-execution-mode 'step edebug-stop t) @@ -2631,14 +2526,14 @@ MSG is printed after `::::} '." (edebug-overlay-arrow) (cond - ((eq 'error edebug-arg-mode) + ((eq 'error arg-mode) ;; Display error message (setq edebug-execution-mode 'step) (edebug-overlay-arrow) (beep) - (if (eq 'quit (car edebug-value)) + (if (eq 'quit (car value)) (message "Quit") - (edebug-report-error edebug-value))) + (edebug-report-error value))) (edebug-break (cond (edebug-global-break @@ -2655,41 +2550,40 @@ MSG is printed after `::::} '." (t (message ""))) - (setq unread-command-events nil) - (if (eq 'after edebug-arg-mode) + (if (eq 'after arg-mode) (progn ;; Display result of previous evaluation. (if (and edebug-break (not (eq edebug-execution-mode 'Continue-fast))) - (edebug-sit-for edebug-sit-for-seconds)) ; Show message. + (sit-for edebug-sit-for-seconds)) ; Show message. (edebug-previous-result))) (cond (edebug-break (cond ((eq edebug-execution-mode 'continue) - (edebug-sit-for edebug-sit-for-seconds)) - ((eq edebug-execution-mode 'Continue-fast) (edebug-sit-for 0)) + (sit-for edebug-sit-for-seconds)) + ((eq edebug-execution-mode 'Continue-fast) (sit-for 0)) (t (setq edebug-stop t)))) ;; not edebug-break ((eq edebug-execution-mode 'trace) - (edebug-sit-for edebug-sit-for-seconds)) ; Force update and pause. + (sit-for edebug-sit-for-seconds)) ; Force update and pause. ((eq edebug-execution-mode 'Trace-fast) - (edebug-sit-for 0))) ; Force update and continue. + (sit-for 0))) ; Force update and continue. (unwind-protect (if (or edebug-stop (memq edebug-execution-mode '(step next)) - (eq edebug-arg-mode 'error)) + (eq arg-mode 'error)) (progn ;; (setq edebug-execution-mode 'step) ;; (edebug-overlay-arrow) ; This doesn't always show up. - (edebug-recursive-edit))) ; <---------- Recursive edit + (edebug--recursive-edit arg-mode))) ; <----- Recursive edit ;; Reset the edebug-window-data to whatever it is now. (let ((window (if (eq (window-buffer) edebug-buffer) (selected-window) - (edebug-get-buffer-window edebug-buffer)))) + (get-buffer-window edebug-buffer)))) ;; Remember window-start for edebug-buffer, if still displayed. (if window (progn @@ -2767,6 +2661,8 @@ MSG is printed after `::::} '." (goto-char edebug-buffer-outside-point)) ;; ... nothing more. ) + ;; Could be an option to keep eval display up. + (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) (with-timeout-unsuspend edebug-with-timeout-suspend) ;; Reset global variables to outside values in case they were changed. (setq @@ -2804,31 +2700,19 @@ MSG is printed after `::::} '." ;; in versions where the variable is *not* built-in. ;; Emacs 18 FIXME -(defvar edebug-outside-unread-command-char) ;; Emacs 19. (defvar edebug-outside-last-command-event) -(defvar edebug-outside-unread-command-events) (defvar edebug-outside-last-input-event) (defvar edebug-outside-last-event-frame) (defvar edebug-outside-last-nonmenu-event) (defvar edebug-outside-track-mouse) -;; Disable byte compiler warnings about unread-command-char and -event -;; (maybe works with byte-compile-version 2.22 at least) -(defvar edebug-unread-command-char-warning) -(defvar edebug-unread-command-event-warning) -(eval-when-compile ; FIXME - (setq edebug-unread-command-char-warning - (get 'unread-command-char 'byte-obsolete-variable)) - (put 'unread-command-char 'byte-obsolete-variable nil)) - -(defun edebug-recursive-edit () +(defun edebug--recursive-edit (arg-mode) ;; Start up a recursive edit inside of edebug. ;; The current buffer is the edebug-buffer, which is put into edebug-mode. ;; Assume that none of the variables below are buffer-local. - (let ((edebug-buffer-read-only buffer-read-only) - ;; match-data must be done in the outside buffer + (let (;; match-data must be done in the outside buffer (edebug-outside-match-data (with-current-buffer edebug-outside-buffer ; in case match buffer different (match-data))) @@ -2842,16 +2726,20 @@ MSG is printed after `::::} '." ;; during a recursive-edit edebug-inside-windows - (edebug-outside-map (current-local-map)) + ;; Save the outside value of executing macro. (here??) + (edebug-outside-executing-macro executing-kbd-macro) + (edebug-outside-pre-command-hook + (edebug-var-status 'pre-command-hook)) + (edebug-outside-post-command-hook + (edebug-var-status 'post-command-hook)) - (edebug-outside-standard-output standard-output) + (edebug-outside-standard-output standard-output) (edebug-outside-standard-input standard-input) (edebug-outside-defining-kbd-macro defining-kbd-macro) (edebug-outside-last-command last-command) (edebug-outside-this-command this-command) - (edebug-outside-unread-command-char unread-command-char) ; FIXME (edebug-outside-current-prefix-arg current-prefix-arg) (edebug-outside-last-input-event last-input-event) @@ -2867,9 +2755,6 @@ MSG is printed after `::::} '." ;; We could set these to the values for previous edebug call. (last-command last-command) (this-command this-command) - - ;; Assume no edebug command sets unread-command-char. - (unread-command-char -1) (current-prefix-arg nil) ;; More for Emacs 19 @@ -2879,7 +2764,20 @@ MSG is printed after `::::} '." (last-nonmenu-event nil) (track-mouse nil) - ;; Bind again to outside values. + (standard-output t) + (standard-input t) + + ;; Don't keep reading from an executing kbd macro + ;; within edebug unless edebug-continue-kbd-macro is + ;; non-nil. Again, local binding may not be best. + (executing-kbd-macro + (if edebug-continue-kbd-macro executing-kbd-macro)) + + ;; Don't get confused by the user's keymap changes. + (overriding-local-map nil) + (overriding-terminal-local-map nil) + + ;; Bind again to outside values. (debug-on-error edebug-outside-debug-on-error) (debug-on-quit edebug-outside-debug-on-quit) @@ -2887,17 +2785,22 @@ MSG is printed after `::::} '." (defining-kbd-macro (if edebug-continue-kbd-macro defining-kbd-macro)) + ;; Disable command hooks. This is essential when + ;; a hook function is instrumented - to avoid infinite loop. + ;; This may be more than we need, however. + (pre-command-hook nil) + (post-command-hook nil) + ;; others?? ) (if (and (eq edebug-execution-mode 'go) - (not (memq edebug-arg-mode '(after error)))) + (not (memq arg-mode '(after error)))) (message "Break")) - (setq buffer-read-only t) (setq signal-hook-function nil) - (edebug-mode) + (edebug-mode 1) (unwind-protect (recursive-edit) ; <<<<<<<<<< Recursive edit @@ -2905,8 +2808,6 @@ MSG is printed after `::::} '." (setq signal-hook-function 'edebug-signal) (if edebug-backtrace-buffer (kill-buffer edebug-backtrace-buffer)) - ;; Could be an option to keep eval display up. - (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) ;; Remember selected-window after recursive-edit. ;; (setq edebug-inside-window (selected-window)) @@ -2920,10 +2821,7 @@ MSG is printed after `::::} '." (set-buffer edebug-buffer) (if (memq edebug-execution-mode '(go Go-nonstop)) (edebug-overlay-arrow)) - (setq buffer-read-only edebug-buffer-read-only) - (use-local-map edebug-outside-map) - (remove-hook 'kill-buffer-hook 'edebug-kill-buffer t) - ) + (edebug-mode -1)) ;; gotta have a buffer to let its buffer local variables be set (get-buffer-create " bogus edebug buffer")) ));; inner let @@ -2933,7 +2831,6 @@ MSG is printed after `::::} '." last-command-event edebug-outside-last-command-event last-command edebug-outside-last-command this-command edebug-outside-this-command - unread-command-char edebug-outside-unread-command-char current-prefix-arg edebug-outside-current-prefix-arg last-input-event edebug-outside-last-input-event last-event-frame edebug-outside-last-event-frame @@ -2942,17 +2839,21 @@ MSG is printed after `::::} '." standard-output edebug-outside-standard-output standard-input edebug-outside-standard-input - defining-kbd-macro edebug-outside-defining-kbd-macro - )) - )) + defining-kbd-macro edebug-outside-defining-kbd-macro) + + (setq executing-kbd-macro edebug-outside-executing-macro) + (edebug-restore-status + 'post-command-hook edebug-outside-post-command-hook) + (edebug-restore-status + 'pre-command-hook edebug-outside-pre-command-hook)))) ;;; Display related functions (defun edebug-adjust-window (old-start) ;; If pos is not visible, adjust current window to fit following context. -;;; (message "window: %s old-start: %s window-start: %s pos: %s" -;;; (selected-window) old-start (window-start) (point)) (sit-for 5) + ;; (message "window: %s old-start: %s window-start: %s pos: %s" + ;; (selected-window) old-start (window-start) (point)) (sit-for 5) (if (not (pos-visible-in-window-p)) (progn ;; First try old-start @@ -2960,7 +2861,7 @@ MSG is printed after `::::} '." (set-window-start (selected-window) old-start)) (if (not (pos-visible-in-window-p)) (progn -;; (message "resetting window start") (sit-for 2) + ;; (message "resetting window start") (sit-for 2) (set-window-start (selected-window) (save-excursion @@ -3099,12 +3000,12 @@ before returning. The default is one second." (current-buffer) (point) (if (marker-buffer (edebug-mark-marker)) (marker-position (edebug-mark-marker)) "<not set>")) - (edebug-sit-for arg) + (sit-for arg) (edebug-pop-to-buffer edebug-buffer (car edebug-window-data))))) ;; Joe Wells, here is a start at your idea of adding a buffer to the internal -;; display list. Still need to use this list in edebug-display. +;; display list. Still need to use this list in edebug--display. '(defvar edebug-display-buffer-list nil "List of buffers that edebug will display when it is active.") @@ -3426,7 +3327,7 @@ function or macro is called, Edebug will be called there as well." (save-excursion (down-list 1) (if (looking-at "\(") - (edebug-form-data-name + (edebug--form-data-name (edebug-get-form-data-entry (point))) (edebug-original-read (current-buffer)))))) (edebug-instrument-function func)))) @@ -3539,11 +3440,10 @@ edebug-mode." ;;; Evaluation of expressions -(def-edebug-spec edebug-outside-excursion t) - (defmacro edebug-outside-excursion (&rest body) "Evaluate an expression list in the outside context. Return the result of the last expression." + (declare (debug t)) `(save-excursion ; of current-buffer (if edebug-save-windows (progn @@ -3562,7 +3462,6 @@ Return the result of the last expression." (last-command-event edebug-outside-last-command-event) (last-command edebug-outside-last-command) (this-command edebug-outside-this-command) - (unread-command-char edebug-outside-unread-command-char) (unread-command-events edebug-outside-unread-command-events) (current-prefix-arg edebug-outside-current-prefix-arg) (last-input-event edebug-outside-last-input-event) @@ -3578,7 +3477,7 @@ Return the result of the last expression." (pre-command-hook (cdr edebug-outside-pre-command-hook)) (post-command-hook (cdr edebug-outside-post-command-hook)) - ;; See edebug-display + ;; See edebug-display. (overlay-arrow-position edebug-outside-o-a-p) (overlay-arrow-string edebug-outside-o-a-s) (cursor-in-echo-area edebug-outside-c-i-e-a) @@ -3602,7 +3501,6 @@ Return the result of the last expression." edebug-outside-last-command-event last-command-event edebug-outside-last-command last-command edebug-outside-this-command this-command - edebug-outside-unread-command-char unread-command-char edebug-outside-unread-command-events unread-command-events edebug-outside-current-prefix-arg current-prefix-arg edebug-outside-last-input-event last-input-event @@ -3633,18 +3531,19 @@ Return the result of the last expression." (defvar cl-debug-env) ; defined in cl; non-nil when lexical env used. -(defun edebug-eval (edebug-expr) +(defun edebug-eval (expr) ;; Are there cl lexical variables active? - (eval (if (bound-and-true-p cl-debug-env) - (cl-macroexpand-all edebug-expr cl-debug-env) - edebug-expr) + (eval (if (and (bound-and-true-p cl-debug-env) + (fboundp 'cl-macroexpand-all)) + (cl-macroexpand-all expr cl-debug-env) + expr) lexical-binding)) -(defun edebug-safe-eval (edebug-expr) +(defun edebug-safe-eval (expr) ;; Evaluate EXPR safely. ;; If there is an error, a string is returned describing the error. (condition-case edebug-err - (edebug-eval edebug-expr) + (edebug-eval expr) (error (edebug-format "%s: %s" ;; could (get (car edebug-err) 'error-message) (car (cdr edebug-err)))))) @@ -3652,17 +3551,17 @@ Return the result of the last expression." ;;; Printing -(defun edebug-report-error (edebug-value) +(defun edebug-report-error (value) ;; Print an error message like command level does. ;; This also prints the error name if it has no error-message. (message "%s: %s" - (or (get (car edebug-value) 'error-message) - (format "peculiar error (%s)" (car edebug-value))) + (or (get (car value) 'error-message) + (format "peculiar error (%s)" (car value))) (mapconcat (function (lambda (edebug-arg) ;; continuing after an error may ;; complain about edebug-arg. why?? (prin1-to-string edebug-arg))) - (cdr edebug-value) ", "))) + (cdr value) ", "))) (defvar print-readably) ; defined by lemacs ;; Alternatively, we could change the definition of @@ -3678,14 +3577,14 @@ Return the result of the last expression." (edebug-prin1-to-string value) (error "#Apparently circular structure#")))) -(defun edebug-compute-previous-result (edebug-previous-value) +(defun edebug-compute-previous-result (previous-value) (if edebug-unwrap-results - (setq edebug-previous-value - (edebug-unwrap* edebug-previous-value))) + (setq previous-value + (edebug-unwrap* previous-value))) (setq edebug-previous-result (concat "Result: " - (edebug-safe-prin1-to-string edebug-previous-value) - (eval-expression-print-format edebug-previous-value)))) + (edebug-safe-prin1-to-string previous-value) + (eval-expression-print-format previous-value)))) (defun edebug-previous-result () "Print the previous result." @@ -3700,7 +3599,7 @@ Return the result of the last expression." (defalias 'edebug-format 'format) (defalias 'edebug-message 'message) -(defun edebug-eval-expression (edebug-expr) +(defun edebug-eval-expression (expr) "Evaluate an expression in the outside environment. If interactive, prompt for the expression. Print result in minibuffer." @@ -3709,7 +3608,7 @@ Print result in minibuffer." 'read-expression-history))) (princ (edebug-outside-excursion - (setq values (cons (edebug-eval edebug-expr) values)) + (setq values (cons (edebug-eval expr) values)) (concat (edebug-safe-prin1-to-string (car values)) (eval-expression-print-format (car values)))))) @@ -3723,14 +3622,14 @@ Print value in minibuffer." "Evaluate sexp before point in outside environment; insert value. This prints the value into current buffer." (interactive) - (let* ((edebug-form (edebug-last-sexp)) - (edebug-result-string + (let* ((form (edebug-last-sexp)) + (result-string (edebug-outside-excursion - (edebug-safe-prin1-to-string (edebug-safe-eval edebug-form)))) + (edebug-safe-prin1-to-string (edebug-safe-eval form)))) (standard-output (current-buffer))) (princ "\n") ;; princ the string to get rid of quotes. - (princ edebug-result-string) + (princ result-string) (princ "\n") )) @@ -3864,7 +3763,9 @@ be installed in `emacs-lisp-mode-map'.") (interactive) (describe-function 'edebug-mode)) -(defun edebug-mode () +(defvar edebug--mode-saved-vars nil) + +(define-minor-mode edebug-mode "Mode for Emacs Lisp buffers while in Edebug. In addition to all Emacs Lisp commands (except those that modify the @@ -3898,17 +3799,32 @@ Options: `edebug-on-signal' `edebug-unwrap-results' `edebug-global-break-condition'" + :lighter " *Debugging*" + :keymap edebug-mode-map ;; If the user kills the buffer in which edebug is currently active, ;; exit to top level, because the edebug command loop can't usefully ;; continue running in such a case. - (add-hook 'kill-buffer-hook 'edebug-kill-buffer nil t) - (use-local-map edebug-mode-map)) + ;; + (if (not edebug-mode) + (progn + (while edebug--mode-saved-vars + (let ((setting (pop edebug--mode-saved-vars))) + (if (consp setting) + (set (car setting) (cdr setting)) + (kill-local-variable setting)))) + (remove-hook 'kill-buffer-hook 'edebug-kill-buffer t)) + (pcase-dolist (`(,var . ,val) '((buffer-read-only . t))) + (push + (if (local-variable-p var) (cons var (symbol-value var)) var) + edebug--mode-saved-vars) + (set (make-local-variable var) val)) + ;; Append `edebug-kill-buffer' to the hook to avoid interfering with + ;; other entries that are unguarded against deleted buffer. + (add-hook 'kill-buffer-hook 'edebug-kill-buffer t t))) (defun edebug-kill-buffer () "Used on `kill-buffer-hook' when Edebug is operating in a buffer of Lisp code." - (let (kill-buffer-hook) - (kill-buffer (current-buffer))) - (top-level)) + (run-with-timer 0 nil #'top-level)) ;;; edebug eval list mode @@ -3922,44 +3838,38 @@ Options: (edebug-trace nil)) (mapcar 'edebug-safe-eval edebug-eval-list))) -(defun edebug-eval-display-list (edebug-eval-result-list) +(defun edebug-eval-display-list (eval-result-list) ;; Assumes edebug-eval-buffer exists. - (let ((edebug-eval-list-temp edebug-eval-list) - (standard-output edebug-eval-buffer) + (let ((standard-output edebug-eval-buffer) (edebug-comment-line (format ";%s\n" (make-string (- (window-width) 2) ?-)))) (set-buffer edebug-eval-buffer) (erase-buffer) - (while edebug-eval-list-temp - (prin1 (car edebug-eval-list-temp)) (terpri) - (prin1 (car edebug-eval-result-list)) (terpri) - (princ edebug-comment-line) - (setq edebug-eval-list-temp (cdr edebug-eval-list-temp)) - (setq edebug-eval-result-list (cdr edebug-eval-result-list))) + (dolist (exp edebug-eval-list) + (prin1 exp) (terpri) + (prin1 (pop eval-result-list)) (terpri) + (princ edebug-comment-line)) (edebug-pop-to-buffer edebug-eval-buffer) )) (defun edebug-create-eval-buffer () - (if (not (and edebug-eval-buffer (buffer-name edebug-eval-buffer))) - (progn - (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*"))) - (edebug-eval-mode)))) + (unless (and edebug-eval-buffer (buffer-name edebug-eval-buffer)) + (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*"))) + (edebug-eval-mode))) ;; Should generalize this to be callable outside of edebug ;; with calls in user functions, e.g. (edebug-eval-display) -(defun edebug-eval-display (edebug-eval-result-list) - "Display expressions and evaluations in EDEBUG-EVAL-RESULT-LIST. +(defun edebug-eval-display (eval-result-list) + "Display expressions and evaluations in EVAL-RESULT-LIST. It modifies the context by popping up the eval display." - (if edebug-eval-result-list - (progn - (edebug-create-eval-buffer) - (edebug-eval-display-list edebug-eval-result-list) - ))) + (when eval-result-list + (edebug-create-eval-buffer) + (edebug-eval-display-list eval-result-list))) (defun edebug-eval-redisplay () "Redisplay eval list in outside environment. -May only be called from within `edebug-recursive-edit'." +May only be called from within `edebug--recursive-edit'." (edebug-create-eval-buffer) (edebug-outside-excursion (edebug-eval-display-list (edebug-eval-result-list)) @@ -3983,7 +3893,7 @@ May only be called from within `edebug-recursive-edit'." (if (not (eobp)) (progn (forward-sexp 1) - (setq new-list (cons (edebug-last-sexp) new-list)))) + (push (edebug-last-sexp) new-list))) (while (re-search-forward "^;" nil t) (forward-line 1) @@ -3992,7 +3902,7 @@ May only be called from within `edebug-recursive-edit'." (not (eobp))) (progn (forward-sexp 1) - (setq new-list (cons (edebug-last-sexp) new-list))))) + (push (edebug-last-sexp) new-list)))) (setq edebug-eval-list (nreverse new-list)) (edebug-eval-redisplay) @@ -4021,8 +3931,8 @@ May only be called from within `edebug-recursive-edit'." (define-key map "\C-c\C-u" 'edebug-update-eval-list) (define-key map "\C-x\C-e" 'edebug-eval-last-sexp) (define-key map "\C-j" 'edebug-eval-print-last-sexp) - map) -"Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.") + map) + "Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.") (put 'edebug-eval-mode 'mode-class 'special) @@ -4049,32 +3959,32 @@ Global commands prefixed by `global-edebug-prefix': ;; since they depend on the backtrace looking a certain way. But ;; edebug is not dependent on this, yet. -(defun edebug (&optional edebug-arg-mode &rest debugger-args) +(defun edebug (&optional arg-mode &rest args) "Replacement for `debug'. If we are running an edebugged function, show where we last were. Otherwise call `debug' normally." -;; (message "entered: %s depth: %s edebug-recursion-depth: %s" -;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1) + ;;(message "entered: %s depth: %s edebug-recursion-depth: %s" + ;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1) (if (and edebug-entered ; anything active? (eq (recursion-depth) edebug-recursion-depth)) (let (;; Where were we before the error occurred? - (edebug-offset-index (car edebug-offset-indices)) - ;; Bind variables required by edebug-display - (edebug-value (car debugger-args)) + (offset-index (car edebug-offset-indices)) + (value (car args)) + ;; Bind variables required by edebug--display. edebug-breakpoints edebug-break-data edebug-break-condition edebug-global-break - (edebug-break (null edebug-arg-mode)) ;; if called explicitly + (edebug-break (null arg-mode)) ;; If called explicitly. ) - (edebug-display) - (if (eq edebug-arg-mode 'error) + (edebug--display value offset-index arg-mode) + (if (eq arg-mode 'error) nil - edebug-value)) + value)) ;; Otherwise call debug normally. ;; Still need to remove extraneous edebug calls from stack. - (apply 'debug edebug-arg-mode debugger-args) + (apply 'debug arg-mode args) )) @@ -4085,7 +3995,7 @@ Otherwise call `debug' normally." (null (buffer-name edebug-backtrace-buffer))) (setq edebug-backtrace-buffer (generate-new-buffer "*Backtrace*")) - ;; else, could just display edebug-backtrace-buffer + ;; Else, could just display edebug-backtrace-buffer. ) (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer) (setq edebug-backtrace-buffer standard-output) @@ -4107,7 +4017,7 @@ Otherwise call `debug' normally." (beginning-of-line) (cond ((looking-at "^ \(edebug-after") - ;; Previous lines may contain code, so just delete this line + ;; Previous lines may contain code, so just delete this line. (setq last-ok-point (point)) (forward-line 1) (delete-region last-ok-point (point))) @@ -4125,15 +4035,15 @@ Otherwise call `debug' normally." "In buffer BUF-NAME, display FMT and ARGS at the end and make it visible. The buffer is created if it does not exist. You must include newlines in FMT to break lines, but one newline is appended." -;; e.g. -;; (edebug-trace-display "*trace-point*" -;; "saving: point = %s window-start = %s" -;; (point) (window-start)) + ;; e.g. + ;; (edebug-trace-display "*trace-point*" + ;; "saving: point = %s window-start = %s" + ;; (point) (window-start)) (let* ((oldbuf (current-buffer)) (selected-window (selected-window)) (buffer (get-buffer-create buf-name)) buf-window) -;; (message "before pop-to-buffer") (sit-for 1) + ;; (message "before pop-to-buffer") (sit-for 1) (edebug-pop-to-buffer buffer) (setq truncate-lines t) (setq buf-window (selected-window)) @@ -4143,8 +4053,8 @@ You must include newlines in FMT to break lines, but one newline is appended." (vertical-motion (- 1 (window-height))) (set-window-start buf-window (point)) (goto-char (point-max)) -;; (set-window-point buf-window (point)) -;; (edebug-sit-for 0) + ;; (set-window-point buf-window (point)) + ;; (sit-for 0) (bury-buffer buffer) (select-window selected-window) (set-buffer oldbuf)) @@ -4207,8 +4117,8 @@ reinstrument it." ;; Insert all the indices for this line. (forward-line 1) (setq start-of-count-line (point) - first-index i ; really last index for line above this one. - last-count -1) ; cause first count to always appear. + first-index i ; Really, last index for line above this one. + last-count -1) ; Cause first count to always appear. (insert ";#") ;; i == first-index still (while (<= (setq i (1+ i)) last-index) @@ -4237,10 +4147,11 @@ reinstrument it." It is removed when you hit any char." ;; This seems not to work with Emacs 18.59. It undoes too far. (interactive) - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (undo-boundary) (edebug-display-freq-count) - (setq unread-command-char (read-char)) + (setq unread-command-events + (append unread-command-events (list (read-event)))) ;; Yuck! This doesn't seem to work at all for me. (undo))) @@ -4352,106 +4263,56 @@ With prefix argument, make it a temporary breakpoint." (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus) -;;; Byte-compiler - -;; Extension for bytecomp to resolve undefined function references. -;; Requires new byte compiler. - -;; Reenable byte compiler warnings about unread-command-char and -event. -;; Disabled before edebug-recursive-edit. -(eval-when-compile - (if edebug-unread-command-char-warning - (put 'unread-command-char 'byte-obsolete-variable - edebug-unread-command-char-warning))) - -(eval-when-compile - ;; The body of eval-when-compile seems to get evaluated with eval-defun. - ;; We only want to evaluate when actually byte compiling. - ;; But it is OK to evaluate as long as byte-compiler has been loaded. - (if (featurep 'byte-compile) (progn - - (defun byte-compile-resolve-functions (funcs) - "Say it is OK for the named functions to be unresolved." - (mapc - (function - (lambda (func) - (setq byte-compile-unresolved-functions - (delq (assq func byte-compile-unresolved-functions) - byte-compile-unresolved-functions)))) - funcs) - nil) - - '(defun byte-compile-resolve-free-references (vars) - "Say it is OK for the named variables to be referenced." - (mapcar - (function - (lambda (var) - (setq byte-compile-free-references - (delq var byte-compile-free-references)))) - vars) - nil) - - '(defun byte-compile-resolve-free-assignments (vars) - "Say it is OK for the named variables to be assigned." - (mapcar - (function - (lambda (var) - (setq byte-compile-free-assignments - (delq var byte-compile-free-assignments)))) - vars) - nil) - - (byte-compile-resolve-functions - '(reporter-submit-bug-report - edebug-gensym ;; also in cl.el - ;; Interfaces to standard functions. - edebug-original-eval-defun - edebug-original-read - edebug-get-buffer-window - edebug-mark - edebug-mark-marker - edebug-input-pending-p - edebug-sit-for - edebug-prin1-to-string - edebug-format - ;; lemacs - zmacs-deactivate-region - popup-menu - ;; CL - cl-macroexpand-all - ;; And believe it or not, the byte compiler doesn't know about: - byte-compile-resolve-functions - )) - - '(byte-compile-resolve-free-references - '(read-expression-history - read-expression-map)) - - '(byte-compile-resolve-free-assignments - '(read-expression-history)) - - ))) - - ;;; 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-base.el b/lisp/emacs-lisp/eieio-base.el index b5600560cdd..21190446624 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -1,10 +1,9 @@ ;;; eieio-base.el --- Base classes for EIEIO. -;;; Copyright (C) 2000-2002, 2004-2005, 2007-2012 -;;; Free Software Foundation, Inc. +;;; Copyright (C) 2000-2002, 2004-2005, 2007-2013 Free Software +;;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 ;; Keywords: OO, lisp ;; Package: eieio @@ -32,6 +31,7 @@ ;;; Code: (require 'eieio) +(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! ;;; eieio-instance-inheritor ;; @@ -66,19 +66,19 @@ SLOT-NAME is the offending slot. FN is the function signaling the error." "Clone OBJ, initializing `:parent' to OBJ. All slots are unbound, except those initialized with PARAMS." (let ((nobj (make-vector (length obj) eieio-unbound)) - (nm (aref obj object-name)) + (nm (eieio--object-name obj)) (passname (and params (stringp (car params)))) (num 1)) (aset nobj 0 'object) - (aset nobj object-class (aref obj object-class)) + (setf (eieio--object-class nobj) (eieio--object-class obj)) ;; The following was copied from the default clone. (if (not passname) (save-match-data (if (string-match "-\\([0-9]+\\)" nm) (setq num (1+ (string-to-number (match-string 1 nm))) nm (substring nm 0 (match-beginning 0)))) - (aset nobj object-name (concat nm "-" (int-to-string num)))) - (aset nobj object-name (car params))) + (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num)))) + (setf (eieio--object-name nobj) (car params))) ;; Now initialize from params. (if params (shared-initialize nobj (if passname (cdr params) params))) (oset nobj parent-instance obj) @@ -225,8 +225,15 @@ a file. Optional argument NAME specifies a default file name." )))) (oref this file)) -(defun eieio-persistent-read (filename) - "Read a persistent object from FILENAME, and return it." +(defun eieio-persistent-read (filename &optional class allow-subclass) + "Read a persistent object from FILENAME, and return it. +Signal an error if the object in FILENAME is not a constructor +for CLASS. Optional ALLOW-SUBCLASS says that it is ok for +`eieio-persistent-read' to load in subclasses of class instead of +being pedantic." + (unless class + (message "Unsafe call to `eieio-persistent-read'.")) + (when class (eieio--check-type class-p class)) (let ((ret nil) (buffstr nil)) (unwind-protect @@ -239,13 +246,171 @@ a file. Optional argument NAME specifies a default file name." ;; so that any initialize-instance calls that depend on ;; the current buffer will work. (setq ret (read buffstr)) - (if (not (child-of-class-p (car ret) 'eieio-persistent)) - (error "Corrupt object on disk")) - (setq ret (eval ret)) + (when (not (child-of-class-p (car ret) 'eieio-persistent)) + (error "Corrupt object on disk: Unknown saved object")) + (when (and class + (not (or (eq (car ret) class ) ; same class + (and allow-subclass + (child-of-class-p (car ret) class)) ; subclasses + ))) + (error "Corrupt object on disk: Invalid saved class")) + (setq ret (eieio-persistent-convert-list-to-object ret)) (oset ret file filename)) (kill-buffer " *tmp eieio read*")) ret)) +(defun eieio-persistent-convert-list-to-object (inputlist) + "Convert the INPUTLIST, representing object creation to an object. +While it is possible to just `eval' the INPUTLIST, this code instead +validates the existing list, and explicitly creates objects instead of +calling eval. This avoids the possibility of accidentally running +malicious code. + +Note: This function recurses when a slot of :type of some object is +identified, and needing more object creation." + (let ((objclass (nth 0 inputlist)) + (objname (nth 1 inputlist)) + (slots (nthcdr 2 inputlist)) + (createslots nil)) + + ;; If OBJCLASS is an eieio autoload object, then we need to load it. + (eieio-class-un-autoload objclass) + + (while slots + (let ((name (car slots)) + (value (car (cdr slots)))) + + ;; Make sure that the value proposed for SLOT is valid. + ;; In addition, strip out quotes, list functions, and update + ;; object constructors as needed. + (setq value (eieio-persistent-validate/fix-slot-value + objclass name value)) + + (push name createslots) + (push value createslots) + ) + + (setq slots (cdr (cdr slots)))) + + (apply 'make-instance objclass objname (nreverse createslots)) + + ;;(eval inputlist) + )) + +(defun eieio-persistent-validate/fix-slot-value (class slot proposed-value) + "Validate that in CLASS, the SLOT with PROPOSED-VALUE is good, then fix. +A limited number of functions, such as quote, list, and valid object +constructor functions are considered valid. +Second, any text properties will be stripped from strings." + (cond ((consp proposed-value) + ;; Lists with something in them need special treatment. + (let ((slot-idx (eieio-slot-name-index class nil slot)) + (type nil) + (classtype nil)) + (setq slot-idx (- slot-idx 3)) + (setq type (aref (eieio--class-public-type (class-v class)) + slot-idx)) + + (setq classtype (eieio-persistent-slot-type-is-class-p + type)) + + (cond ((eq (car proposed-value) 'quote) + (car (cdr proposed-value))) + + ;; An empty list sometimes shows up as (list), which is dumb, but + ;; we need to support it for backward compat. + ((and (eq (car proposed-value) 'list) + (= (length proposed-value) 1)) + nil) + + ;; We have a slot with a single object that can be + ;; saved here. Recurse and evaluate that + ;; sub-object. + ((and classtype (class-p classtype) + (child-of-class-p (car proposed-value) classtype)) + (eieio-persistent-convert-list-to-object + proposed-value)) + + ;; List of object constructors. + ((and (eq (car proposed-value) 'list) + ;; 2nd item is a list. + (consp (car (cdr proposed-value))) + ;; 1st elt of 2nd item is a class name. + (class-p (car (car (cdr proposed-value)))) + ) + + ;; Check the value against the input class type. + ;; If something goes wrong, issue a smart warning + ;; about how a :type is needed for this to work. + (unless (and + ;; Do we have a type? + (consp classtype) (class-p (car classtype))) + (error "In save file, list of object constructors found, but no :type specified for slot %S" + slot)) + + ;; We have a predicate, but it doesn't satisfy the predicate? + (dolist (PV (cdr proposed-value)) + (unless (child-of-class-p (car PV) (car classtype)) + (error "Corrupt object on disk"))) + + ;; We have a list of objects here. Lets load them + ;; in. + (let ((objlist nil)) + (dolist (subobj (cdr proposed-value)) + (push (eieio-persistent-convert-list-to-object subobj) + objlist)) + ;; return the list of objects ... reversed. + (nreverse objlist))) + (t + proposed-value)))) + + ((stringp proposed-value) + ;; Else, check for strings, remove properties. + (substring-no-properties proposed-value)) + + (t + ;; Else, just return whatever the constant was. + proposed-value)) + ) + +(defun eieio-persistent-slot-type-is-class-p (type) + "Return the class refered to in TYPE. +If no class is referenced there, then return nil." + (cond ((class-p type) + ;; If the type is a class, then return it. + type) + + ((and (symbolp type) (string-match "-child$" (symbol-name type)) + (class-p (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))))) + ;; If it is the predicate ending with -child, then return + ;; that class. Unfortunately, in EIEIO, typep of just the + ;; class is the same as if we used -child, so no further work needed. + (intern-soft (substring (symbol-name type) 0 + (match-beginning 0)))) + + ((and (symbolp type) (string-match "-list$" (symbol-name type)) + (class-p (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))))) + ;; If it is the predicate ending with -list, then return + ;; that class and the predicate to use. + (cons (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))) + type)) + + ((and (consp type) (eq (car type) 'or)) + ;; If type is a list, and is an or, it is possibly something + ;; like (or null myclass), so check for that. + (let ((ans nil)) + (dolist (subtype (cdr type)) + (setq ans (eieio-persistent-slot-type-is-class-p + subtype))) + ans)) + + (t + ;; No match, not a class. + nil))) + (defmethod object-write ((this eieio-persistent) &optional comment) "Write persistent object THIS out to the current stream. Optional argument COMMENT is a header line comment." @@ -317,14 +482,13 @@ Argument SLOT-NAME is the slot that was attempted to be accessed. OPERATION is the type of access, such as `oref' or `oset'. NEW-VALUE is the value that was being set into SLOT if OPERATION were a set type." - (if (or (eq slot-name 'object-name) - (eq slot-name :object-name)) + (if (memq slot-name '(object-name :object-name)) (cond ((eq operation 'oset) (if (not (stringp new-value)) (signal 'invalid-slot-type (list obj slot-name 'string new-value))) - (object-set-name-string obj new-value)) - (t (object-name-string obj))) + (eieio-object-set-name-string obj new-value)) + (t (eieio-object-name-string obj))) (call-next-method))) (provide 'eieio-base) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el new file mode 100644 index 00000000000..da475638bb7 --- /dev/null +++ b/lisp/emacs-lisp/eieio-core.el @@ -0,0 +1,2264 @@ +;;; eieio-core.el --- Core implementation for eieio + +;; Copyright (C) 1995-1996, 1998-2013 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 1.4 +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; The "core" part of EIEIO is the implementation for the object +;; system (such as eieio-defclass, or eieio-defmethod) but not the +;; base classes for the object system, which are defined in EIEIO. +;; +;; See the commentary for eieio.el for more about EIEIO itself. + +;;; Code: + +(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! + +;; Compatibility +(if (fboundp 'compiled-function-arglist) + + ;; XEmacs can only access a compiled functions arglist like this: + (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist) + + ;; Emacs doesn't have this function, but since FUNC is a vector, we can just + ;; grab the appropriate element. + (defun eieio-compiled-function-arglist (func) + "Return the argument list for the compiled function FUNC." + (aref func 0)) + + ) + +(put 'eieio--defalias 'byte-hunk-handler + #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) +(defun eieio--defalias (name body) + "Like `defalias', but with less side-effects. +More specifically, it has no side-effects at all when the new function +definition is the same (`eq') as the old one." + (unless (and (fboundp name) + (eq (symbol-function name) body)) + (defalias name body))) + +;;; +;; A few functions that are better in the official EIEIO src, but +;; used from the core. +(declare-function slot-unbound "eieio") +(declare-function slot-missing "eieio") +(declare-function child-of-class-p "eieio") + + +;;; +;; Variable declarations. +;; +(defvar eieio-hook nil + "This hook is executed, then cleared each time `defclass' is called.") + +(defvar eieio-error-unsupported-class-tags nil + "Non-nil to throw an error if an encountered tag is unsupported. +This may prevent classes from CLOS applications from being used with EIEIO +since EIEIO does not support all CLOS tags.") + +(defvar eieio-skip-typecheck nil + "If non-nil, skip all slot typechecking. +Set this to t permanently if a program is functioning well to get a +small speed increase. This variable is also used internally to handle +default setting for optimization purposes.") + +(defvar eieio-optimize-primary-methods-flag t + "Non-nil means to optimize the method dispatch on primary methods.") + +(defvar eieio-initializing-object nil + "Set to non-nil while initializing an object.") + +(defconst eieio-unbound + (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) + eieio-unbound + (make-symbol "unbound")) + "Uninterned symbol representing an unbound slot in an object.") + +;; This is a bootstrap for eieio-default-superclass so it has a value +;; while it is being built itself. +(defvar eieio-default-superclass nil) + +;;; +;; Class currently in scope. +;; +;; When invoking methods, the running method needs to know which class +;; is currently in scope. Generally this is the class of the method +;; being called, but 'call-next-method' needs to query this state, +;; and change it to be then next super class up. +;; +;; Thus, the scoped class is a stack that needs to be managed. + +(defvar eieio--scoped-class-stack nil + "A stack of the classes currently in scope during method invocation.") + +(defun eieio--scoped-class () + "Return the class currently in scope, or nil." + (car-safe eieio--scoped-class-stack)) + +(defmacro eieio--with-scoped-class (class &rest forms) + "Set CLASS as the currently scoped class while executing FORMS." + `(unwind-protect + (progn + (push ,class eieio--scoped-class-stack) + ,@forms) + (pop eieio--scoped-class-stack))) +(put 'eieio--with-scoped-class 'lisp-indent-function 1) + +;;; +;; Field Accessors +;; +(defmacro eieio--define-field-accessors (prefix fields) + (declare (indent 1)) + (let ((index 0) + (defs '())) + (dolist (field fields) + (let ((doc (if (listp field) + (prog1 (cadr field) (setq field (car field)))))) + (push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x) + ,@(if doc (list (format (if (string-match "\n" doc) + "Return %s" "Return %s of a %s.") + doc prefix))) + (list 'aref x ,index)) + defs) + (setq index (1+ index)))) + `(eval-and-compile + ,@(nreverse defs) + (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index)))) + +(eieio--define-field-accessors class + (-unused-0 ;;FIXME: not sure, but at least there was no accessor! + (symbol "symbol (self-referencing)") + parent children + (symbol-obarray "obarray permitting fast access to variable position indexes") + ;; @todo + ;; the word "public" here is leftovers from the very first version. + ;; Get rid of it! + (public-a "class attribute index") + (public-d "class attribute defaults index") + (public-doc "class documentation strings for attributes") + (public-type "class type for a slot") + (public-custom "class custom type for a slot") + (public-custom-label "class custom group for a slot") + (public-custom-group "class custom group for a slot") + (public-printer "printer for a slot") + (protection "protection for a slot") + (initarg-tuples "initarg tuples list") + (class-allocation-a "class allocated attributes") + (class-allocation-doc "class allocated documentation") + (class-allocation-type "class allocated value type") + (class-allocation-custom "class allocated custom descriptor") + (class-allocation-custom-label "class allocated custom descriptor") + (class-allocation-custom-group "class allocated custom group") + (class-allocation-printer "class allocated printer for a slot") + (class-allocation-protection "class allocated protection list") + (class-allocation-values "class allocated value vector") + (default-object-cache "what a newly created object would look like. +This will speed up instantiation time as only a `copy-sequence' will +be needed, instead of looping over all the values and setting them +from the default.") + (options "storage location of tagged class options. +Stored outright without modifications or stripping."))) + +(eieio--define-field-accessors object + (-unused-0 ;;FIXME: not sure, but at least there was no accessor! + (class "class struct defining OBJ") + name)) + +;; FIXME: The constants below should have an `eieio-' prefix added!! + +(defconst method-static 0 "Index into :static tag on a method.") +(defconst method-before 1 "Index into :before tag on a method.") +(defconst method-primary 2 "Index into :primary tag on a method.") +(defconst method-after 3 "Index into :after tag on a method.") +(defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") +(defconst method-generic-before 4 "Index into generic :before tag on a method.") +(defconst method-generic-primary 5 "Index into generic :primary tag on a method.") +(defconst method-generic-after 6 "Index into generic :after tag on a method.") +(defconst method-num-slots 7 "Number of indexes into a method's vector.") + +(defsubst eieio-specialized-key-to-generic-key (key) + "Convert a specialized KEY into a generic method key." + (cond ((eq key method-static) 0) ;; don't convert + ((< key method-num-lists) (+ key 3)) ;; The conversion + (t key) ;; already generic.. maybe. + )) + + +;;; Important macros used internally in eieio. +;; +(defmacro eieio--check-type (type obj) + (unless (symbolp obj) + (error "eieio--check-type wants OBJ to be a variable")) + `(if (not ,(cond + ((eq 'or (car-safe type)) + `(or ,@(mapcar (lambda (type) `(,type ,obj)) (cdr type)))) + (t `(,type ,obj)))) + (signal 'wrong-type-argument (list ',type ,obj)))) + +(defmacro class-v (class) + "Internal: Return the class vector from the CLASS symbol." + ;; No check: If eieio gets this far, it has probably been checked already. + `(get ,class 'eieio-class-definition)) + +(defmacro class-p (class) + "Return t if CLASS is a valid class vector. +CLASS is a symbol." + ;; this new method is faster since it doesn't waste time checking lots of + ;; things. + `(condition-case nil + (eq (aref (class-v ,class) 0) 'defclass) + (error nil))) + +(defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." + (eieio--check-type class-p class) + ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, + ;; and I wanted a string. Arg! + (format "#<class %s>" (symbol-name class))) +(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") + +(defmacro eieio-class-parents-fast (class) + "Return parent classes to CLASS with no check." + `(eieio--class-parent (class-v ,class))) + +(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." + `(eieio--class-children (class-v ,class))) + +(defmacro same-class-fast-p (obj class) + "Return t if OBJ is of class-type CLASS with no error checking." + `(eq (eieio--object-class ,obj) ,class)) + +(defmacro class-constructor (class) + "Return the symbol representing the constructor of CLASS." + `(eieio--class-symbol (class-v ,class))) + +(defmacro generic-p (method) + "Return t if symbol METHOD is a generic function. +Only methods have the symbol `eieio-method-obarray' as a property +\(which contains a list of all bindings to that method type.)" + `(and (fboundp ,method) (get ,method 'eieio-method-obarray))) + +(defun generic-primary-only-p (method) + "Return t if symbol METHOD is a generic function with only primary methods. +Only methods have the symbol `eieio-method-obarray' as a property (which +contains a list of all bindings to that method type.) +Methods with only primary implementations are executed in an optimized way." + (and (generic-p method) + (let ((M (get method 'eieio-method-tree))) + (and (< 0 (length (aref M method-primary))) + (not (aref M method-static)) + (not (aref M method-before)) + (not (aref M method-after)) + (not (aref M method-generic-before)) + (not (aref M method-generic-primary)) + (not (aref M method-generic-after)))) + )) + +(defun generic-primary-only-one-p (method) + "Return t if symbol METHOD is a generic function with only primary methods. +Only methods have the symbol `eieio-method-obarray' as a property (which +contains a list of all bindings to that method type.) +Methods with only primary implementations are executed in an optimized way." + (and (generic-p method) + (let ((M (get method 'eieio-method-tree))) + (and (= 1 (length (aref M method-primary))) + (not (aref M method-static)) + (not (aref M method-before)) + (not (aref M method-after)) + (not (aref M method-generic-before)) + (not (aref M method-generic-primary)) + (not (aref M method-generic-after)))) + )) + +(defmacro class-option-assoc (list option) + "Return from LIST the found OPTION, or nil if it doesn't exist." + `(car-safe (cdr (memq ,option ,list)))) + +(defmacro class-option (class option) + "Return the value stored for CLASS' OPTION. +Return nil if that option doesn't exist." + `(class-option-assoc (eieio--class-options (class-v ,class)) ',option)) + +(defmacro eieio-object-p (obj) + "Return non-nil if OBJ is an EIEIO object." + `(condition-case nil + (let ((tobj ,obj)) + (and (eq (aref tobj 0) 'object) + (class-p (eieio--object-class tobj)))) + (error nil))) +(defalias 'object-p 'eieio-object-p) + +(defmacro class-abstract-p (class) + "Return non-nil if CLASS is abstract. +Abstract classes cannot be instantiated." + `(class-option ,class :abstract)) + +(defmacro class-method-invocation-order (class) + "Return the invocation order of CLASS. +Abstract classes cannot be instantiated." + `(or (class-option ,class :method-invocation-order) + :breadth-first)) + + + +;;; +;; Class Creation + +(defvar eieio-defclass-autoload-map (make-vector 7 nil) + "Symbol map of superclasses we find in autoloads.") + +;; We autoload this because it's used in `make-autoload'. +;;;###autoload +(defun eieio-defclass-autoload (cname superclasses filename doc) + "Create autoload symbols for the EIEIO class CNAME. +SUPERCLASSES are the superclasses that CNAME inherits from. +DOC is the docstring for CNAME. +This function creates a mock-class for CNAME and adds it into +SUPERCLASSES as children. +It creates an autoload function for CNAME's constructor." + ;; Assume we've already debugged inputs. + + (let* ((oldc (when (class-p cname) (class-v cname))) + (newc (make-vector eieio--class-num-slots nil)) + ) + (if oldc + nil ;; Do nothing if we already have this class. + + ;; Create the class in NEWC, but don't fill anything else in. + (aset newc 0 'defclass) + (setf (eieio--class-symbol newc) cname) + + (let ((clear-parent nil)) + ;; No parents? + (when (not superclasses) + (setq superclasses '(eieio-default-superclass) + clear-parent t) + ) + + ;; Hook our new class into the existing structures so we can + ;; autoload it later. + (dolist (SC superclasses) + + + ;; TODO - If we create an autoload that is in the map, that + ;; map needs to be cleared! + + + ;; Does our parent exist? + (if (not (class-p SC)) + + ;; Create a symbol for this parent, and then store this + ;; parent on that symbol. + (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) + (if (not (boundp sym)) + (set sym (list cname)) + (add-to-list sym cname)) + ) + + ;; We have a parent, save the child in there. + (when (not (member cname (eieio--class-children (class-v SC)))) + (setf (eieio--class-children (class-v SC)) + (cons cname (eieio--class-children (class-v SC)))))) + + ;; save parent in child + (setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc))) + ) + + ;; turn this into a usable self-pointing symbol + (set cname cname) + + ;; Store the new class vector definition into the symbol. We need to + ;; do this first so that we can call defmethod for the accessor. + ;; The vector will be updated by the following while loop and will not + ;; need to be stored a second time. + (put cname 'eieio-class-definition newc) + + ;; Clear the parent + (if clear-parent (setf (eieio--class-parent newc) nil)) + + ;; Create an autoload on top of our constructor function. + (autoload cname filename doc nil nil) + (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) + (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) + (autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil) + + )))) + +(defsubst eieio-class-un-autoload (cname) + "If class CNAME is in an autoload state, load its file." + (when (eq (car-safe (symbol-function cname)) 'autoload) + (load-library (car (cdr (symbol-function cname)))))) + +(defun eieio-defclass (cname superclasses slots options-and-doc) + ;; FIXME: Most of this should be moved to the `defclass' macro. + "Define CNAME as a new subclass of SUPERCLASSES. +SLOTS are the slots residing in that class definition, and options or +documentation OPTIONS-AND-DOC is the toplevel documentation for this class. +See `defclass' for more information." + ;; Run our eieio-hook each time, and clear it when we are done. + ;; This way people can add hooks safely if they want to modify eieio + ;; or add definitions when eieio is loaded or something like that. + (run-hooks 'eieio-hook) + (setq eieio-hook nil) + + (eieio--check-type listp superclasses) + + (let* ((pname superclasses) + (newc (make-vector eieio--class-num-slots nil)) + (oldc (when (class-p cname) (class-v cname))) + (groups nil) ;; list of groups id'd from slots + (options nil) + (clearparent nil)) + + (aset newc 0 'defclass) + (setf (eieio--class-symbol newc) cname) + + ;; If this class already existed, and we are updating its structure, + ;; make sure we keep the old child list. This can cause bugs, but + ;; if no new slots are created, it also saves time, and prevents + ;; method table breakage, particularly when the users is only + ;; byte compiling an EIEIO file. + (if oldc + (setf (eieio--class-children newc) (eieio--class-children oldc)) + ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. + ;; This is like the above, but deals with autoloads nicely. + (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) + (when sym + (condition-case nil + (setf (eieio--class-children newc) (symbol-value sym)) + (error nil)) + (unintern (symbol-name cname) eieio-defclass-autoload-map) + )) + ) + + (cond ((and (stringp (car options-and-doc)) + (/= 1 (% (length options-and-doc) 2))) + (error "Too many arguments to `defclass'")) + ((and (symbolp (car options-and-doc)) + (/= 0 (% (length options-and-doc) 2))) + (error "Too many arguments to `defclass'")) + ) + + (setq options + (if (stringp (car options-and-doc)) + (cons :documentation options-and-doc) + options-and-doc)) + + (if pname + (progn + (while pname + (if (and (car pname) (symbolp (car pname))) + (if (not (class-p (car pname))) + ;; bad class + (error "Given parent class %s is not a class" (car pname)) + ;; good parent class... + ;; save new child in parent + (when (not (member cname (eieio--class-children (class-v (car pname))))) + (setf (eieio--class-children (class-v (car pname))) + (cons cname (eieio--class-children (class-v (car pname)))))) + ;; Get custom groups, and store them into our local copy. + (mapc (lambda (g) (pushnew g groups :test #'equal)) + (class-option (car pname) :custom-groups)) + ;; save parent in child + (setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc)))) + (error "Invalid parent class %s" pname)) + (setq pname (cdr pname))) + ;; Reverse the list of our parents so that they are prioritized in + ;; the same order as specified in the code. + (setf (eieio--class-parent newc) (nreverse (eieio--class-parent newc))) ) + ;; If there is nothing to loop over, then inherit from the + ;; default superclass. + (unless (eq cname 'eieio-default-superclass) + ;; adopt the default parent here, but clear it later... + (setq clearparent t) + ;; save new child in parent + (if (not (member cname (eieio--class-children (class-v 'eieio-default-superclass)))) + (setf (eieio--class-children (class-v 'eieio-default-superclass)) + (cons cname (eieio--class-children (class-v 'eieio-default-superclass))))) + ;; save parent in child + (setf (eieio--class-parent newc) (list eieio-default-superclass)))) + + ;; turn this into a usable self-pointing symbol + (set cname cname) + + ;; These two tests must be created right away so we can have self- + ;; referencing classes. ei, a class whose slot can contain only + ;; pointers to itself. + + ;; Create the test function + (let ((csym (intern (concat (symbol-name cname) "-p")))) + (fset csym + (list 'lambda (list 'obj) + (format "Test OBJ to see if it an object of type %s" cname) + (list 'and '(eieio-object-p obj) + (list 'same-class-p 'obj cname))))) + + ;; Make sure the method invocation order is a valid value. + (let ((io (class-option-assoc options :method-invocation-order))) + (when (and io (not (member io '(:depth-first :breadth-first :c3)))) + (error "Method invocation order %s is not allowed" io) + )) + + ;; Create a handy child test too + (let ((csym (intern (concat (symbol-name cname) "-child-p")))) + (fset csym + `(lambda (obj) + ,(format + "Test OBJ to see if it an object is a child of type %s" + cname) + (and (eieio-object-p obj) + (object-of-class-p obj ,cname)))) + + ;; Create a handy list of the class test too + (let ((csym (intern (concat (symbol-name cname) "-list-p")))) + (fset csym + `(lambda (obj) + ,(format + "Test OBJ to see if it a list of objects which are a child of type %s" + cname) + (when (listp obj) + (let ((ans t)) ;; nil is valid + ;; Loop over all the elements of the input list, test + ;; each to make sure it is a child of the desired object class. + (while (and obj ans) + (setq ans (and (eieio-object-p (car obj)) + (object-of-class-p (car obj) ,cname))) + (setq obj (cdr obj))) + ans))))) + + ;; When using typep, (typep OBJ 'myclass) returns t for objects which + ;; are subclasses of myclass. For our predicates, however, it is + ;; important for EIEIO to be backwards compatible, where + ;; myobject-p, and myobject-child-p are different. + ;; "cl" uses this technique to specify symbols with specific typep + ;; test, so we can let typep have the CLOS documented behavior + ;; while keeping our above predicate clean. + + ;; It would be cleaner to use `defsetf' here, but that requires cl + ;; at runtime. + (put cname 'cl-deftype-handler + (list 'lambda () `(list 'satisfies (quote ,csym))))) + + ;; Before adding new slots, let's add all the methods and classes + ;; in from the parent class. + (eieio-copy-parents-into-subclass newc superclasses) + + ;; Store the new class vector definition into the symbol. We need to + ;; do this first so that we can call defmethod for the accessor. + ;; The vector will be updated by the following while loop and will not + ;; need to be stored a second time. + (put cname 'eieio-class-definition newc) + + ;; Query each slot in the declaration list and mangle into the + ;; class structure I have defined. + (while slots + (let* ((slot1 (car slots)) + (name (car slot1)) + (slot (cdr slot1)) + (acces (plist-get slot ':accessor)) + (init (or (plist-get slot ':initform) + (if (member ':initform slot) nil + eieio-unbound))) + (initarg (plist-get slot ':initarg)) + (docstr (plist-get slot ':documentation)) + (prot (plist-get slot ':protection)) + (reader (plist-get slot ':reader)) + (writer (plist-get slot ':writer)) + (alloc (plist-get slot ':allocation)) + (type (plist-get slot ':type)) + (custom (plist-get slot ':custom)) + (label (plist-get slot ':label)) + (customg (plist-get slot ':group)) + (printer (plist-get slot ':printer)) + + (skip-nil (class-option-assoc options :allow-nil-initform)) + ) + + (if eieio-error-unsupported-class-tags + (let ((tmp slot)) + (while tmp + (if (not (member (car tmp) '(:accessor + :initform + :initarg + :documentation + :protection + :reader + :writer + :allocation + :type + :custom + :label + :group + :printer + :allow-nil-initform + :custom-groups))) + (signal 'invalid-slot-type (list (car tmp)))) + (setq tmp (cdr (cdr tmp)))))) + + ;; Clean up the meaning of protection. + (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) + ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) + ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) + ((eq prot nil) nil) + (t (signal 'invalid-slot-type (list ':protection prot)))) + + ;; Make sure the :allocation parameter has a valid value. + (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) + (signal 'invalid-slot-type (list ':allocation alloc))) + + ;; The default type specifier is supposed to be t, meaning anything. + (if (not type) (setq type t)) + + ;; Label is nil, or a string + (if (not (or (null label) (stringp label))) + (signal 'invalid-slot-type (list ':label label))) + + ;; Is there an initarg, but allocation of class? + (if (and initarg (eq alloc :class)) + (message "Class allocated slots do not need :initarg")) + + ;; intern the symbol so we can use it blankly + (if initarg (set initarg initarg)) + + ;; The customgroup should be a list of symbols + (cond ((null customg) + (setq customg '(default))) + ((not (listp customg)) + (setq customg (list customg)))) + ;; The customgroup better be a symbol, or list of symbols. + (mapc (lambda (cg) + (if (not (symbolp cg)) + (signal 'invalid-slot-type (list ':group cg)))) + customg) + + ;; First up, add this slot into our new class. + (eieio-add-new-slot newc name init docstr type custom label customg printer + prot initarg alloc 'defaultoverride skip-nil) + + ;; We need to id the group, and store them in a group list attribute. + (mapc (lambda (cg) (pushnew cg groups :test 'equal)) customg) + + ;; Anyone can have an accessor function. This creates a function + ;; of the specified name, and also performs a `defsetf' if applicable + ;; so that users can `setf' the space returned by this function. + (if acces + (progn + (eieio--defmethod + acces (if (eq alloc :class) :static :primary) cname + `(lambda (this) + ,(format + "Retrieves the slot `%s' from an object of class `%s'" + name cname) + (if (slot-boundp this ',name) + (eieio-oref this ',name) + ;; Else - Some error? nil? + nil))) + + (if (fboundp 'gv-define-setter) + ;; FIXME: We should move more of eieio-defclass into the + ;; defclass macro so we don't have to use `eval' and require + ;; `gv' at run-time. + (eval `(gv-define-setter ,acces (eieio--store eieio--object) + (list 'eieio-oset eieio--object '',name + eieio--store))) + ;; Provide a setf method. It would be cleaner to use + ;; defsetf, but that would require CL at runtime. + (put acces 'setf-method + `(lambda (widget) + (let* ((--widget-sym-- (make-symbol "--widget--")) + (--store-sym-- (make-symbol "--store--"))) + (list + (list --widget-sym--) + (list widget) + (list --store-sym--) + (list 'eieio-oset --widget-sym-- '',name + --store-sym--) + (list 'getfoo --widget-sym--)))))))) + + ;; If a writer is defined, then create a generic method of that + ;; name whose purpose is to set the value of the slot. + (if writer + (eieio--defmethod + writer nil cname + `(lambda (this value) + ,(format "Set the slot `%s' of an object of class `%s'" + name cname) + (setf (slot-value this ',name) value)))) + ;; If a reader is defined, then create a generic method + ;; of that name whose purpose is to access this slot value. + (if reader + (eieio--defmethod + reader nil cname + `(lambda (this) + ,(format "Access the slot `%s' from object of class `%s'" + name cname) + (slot-value this ',name)))) + ) + (setq slots (cdr slots))) + + ;; Now that everything has been loaded up, all our lists are backwards! + ;; Fix that up now. + (setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc))) + (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc))) + (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc))) + (setf (eieio--class-public-type newc) + (apply 'vector (nreverse (eieio--class-public-type newc)))) + (setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc))) + (setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc))) + (setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc))) + (setf (eieio--class-public-printer newc) (nreverse (eieio--class-public-printer newc))) + (setf (eieio--class-protection newc) (nreverse (eieio--class-protection newc))) + (setf (eieio--class-initarg-tuples newc) (nreverse (eieio--class-initarg-tuples newc))) + + ;; The storage for class-class-allocation-type needs to be turned into + ;; a vector now. + (setf (eieio--class-class-allocation-type newc) + (apply 'vector (eieio--class-class-allocation-type newc))) + + ;; Also, take class allocated values, and vectorize them for speed. + (setf (eieio--class-class-allocation-values newc) + (apply 'vector (eieio--class-class-allocation-values newc))) + + ;; Attach slot symbols into an obarray, and store the index of + ;; this slot as the variable slot in this new symbol. We need to + ;; know about primes, because obarrays are best set in vectors of + ;; prime number length, and we also need to make our vector small + ;; to save space, and also optimal for the number of items we have. + (let* ((cnt 0) + (pubsyms (eieio--class-public-a newc)) + (prots (eieio--class-protection newc)) + (l (length pubsyms)) + (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 + 53 59 61 67 71 73 79 83 89 97 101 ))) + (while (and primes (< (car primes) l)) + (setq primes (cdr primes))) + (car primes))) + (oa (make-vector vl 0)) + (newsym)) + (while pubsyms + (setq newsym (intern (symbol-name (car pubsyms)) oa)) + (set newsym cnt) + (setq cnt (1+ cnt)) + (if (car prots) (put newsym 'protection (car prots))) + (setq pubsyms (cdr pubsyms) + prots (cdr prots))) + (setf (eieio--class-symbol-obarray newc) oa) + ) + + ;; Create the constructor function + (if (class-option-assoc options :abstract) + ;; Abstract classes cannot be instantiated. Say so. + (let ((abs (class-option-assoc options :abstract))) + (if (not (stringp abs)) + (setq abs (format "Class %s is abstract" cname))) + (fset cname + `(lambda (&rest stuff) + ,(format "You cannot create a new object of type %s" cname) + (error ,abs)))) + + ;; Non-abstract classes need a constructor. + (fset cname + `(lambda (newname &rest slots) + ,(format "Create a new object with name NAME of class type %s" cname) + (apply 'constructor ,cname newname slots))) + ) + + ;; Set up a specialized doc string. + ;; Use stored value since it is calculated in a non-trivial way + (put cname 'variable-documentation + (class-option-assoc options :documentation)) + + ;; Save the file location where this class is defined. + (let ((fname (if load-in-progress + load-file-name + buffer-file-name))) + (when fname + (when (string-match "\\.elc\\'" fname) + (setq fname (substring fname 0 (1- (length fname))))) + (put cname 'class-location fname))) + + ;; We have a list of custom groups. Store them into the options. + (let ((g (class-option-assoc options :custom-groups))) + (mapc (lambda (cg) (pushnew cg g :test 'equal)) groups) + (if (memq :custom-groups options) + (setcar (cdr (memq :custom-groups options)) g) + (setq options (cons :custom-groups (cons g options))))) + + ;; Set up the options we have collected. + (setf (eieio--class-options newc) options) + + ;; if this is a superclass, clear out parent (which was set to the + ;; default superclass eieio-default-superclass) + (if clearparent (setf (eieio--class-parent newc) nil)) + + ;; Create the cached default object. + (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3) + nil))) + (aset cache 0 'object) + (setf (eieio--object-class cache) cname) + (setf (eieio--object-name cache) 'default-cache-object) + (let ((eieio-skip-typecheck t)) + ;; All type-checking has been done to our satisfaction + ;; before this call. Don't waste our time in this call.. + (eieio-set-defaults cache t)) + (setf (eieio--class-default-object-cache newc) cache)) + + ;; Return our new class object + ;; newc + cname + )) + +(defsubst eieio-eval-default-p (val) + "Whether the default value VAL should be evaluated for use." + (and (consp val) (symbolp (car val)) (fboundp (car val)))) + +(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) + "For SLOT, signal if SPEC does not match VALUE. +If SKIPNIL is non-nil, then if VALUE is nil return t instead." + (if (and (not (eieio-eval-default-p value)) + (not eieio-skip-typecheck) + (not (and skipnil (null value))) + (not (eieio-perform-slot-validation spec value))) + (signal 'invalid-slot-type (list slot spec value)))) + +(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc + &optional defaultoverride skipnil) + "Add into NEWC attribute A. +If A already exists in NEWC, then do nothing. If it doesn't exist, +then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. +Argument ALLOC specifies if the slot is allocated per instance, or per class. +If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, +we must override its value for a default. +Optional argument SKIPNIL indicates if type checking should be skipped +if default value is nil." + ;; Make sure we duplicate those items that are sequences. + (condition-case nil + (if (sequencep d) (setq d (copy-sequence d))) + ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. + (error nil)) + (if (sequencep type) (setq type (copy-sequence type))) + (if (sequencep cust) (setq cust (copy-sequence cust))) + (if (sequencep custg) (setq custg (copy-sequence custg))) + + ;; To prevent override information w/out specification of storage, + ;; we need to do this little hack. + (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) + + (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) + ;; In this case, we modify the INSTANCE version of a given slot. + + (progn + + ;; Only add this element if it is so-far unique + (if (not (member a (eieio--class-public-a newc))) + (progn + (eieio-perform-slot-validation-for-default a type d skipnil) + (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) + (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) + (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) + (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) + (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) + (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) + (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) + (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) + (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) + (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) + ) + ;; When defaultoverride is true, we are usually adding new local + ;; attributes which must override the default value of any slot + ;; passed in by one of the parent classes. + (when defaultoverride + ;; There is a match, and we must override the old value. + (let* ((ca (eieio--class-public-a newc)) + (np (member a ca)) + (num (- (length ca) (length np))) + (dp (if np (nthcdr num (eieio--class-public-d newc)) + nil)) + (tp (if np (nth num (eieio--class-public-type newc)))) + ) + (if (not np) + (error "EIEIO internal error overriding default value for %s" + a) + ;; If type is passed in, is it the same? + (if (not (eq type t)) + (if (not (equal type tp)) + (error + "Child slot type `%s' does not match inherited type `%s' for `%s'" + type tp a))) + ;; If we have a repeat, only update the initarg... + (unless (eq d eieio-unbound) + (eieio-perform-slot-validation-for-default a tp d skipnil) + (setcar dp d)) + ;; If we have a new initarg, check for it. + (when init + (let* ((inits (eieio--class-initarg-tuples newc)) + (inita (rassq a inits))) + ;; Replace the CAR of the associate INITA. + ;;(message "Initarg: %S replace %s" inita init) + (setcar inita init) + )) + + ;; PLN Tue Jun 26 11:57:06 2007 : The protection is + ;; checked and SHOULD match the superclass + ;; protection. Otherwise an error is thrown. However + ;; I wonder if a more flexible schedule might be + ;; implemented. + ;; + ;; EML - We used to have (if prot... here, + ;; but a prot of 'nil means public. + ;; + (let ((super-prot (nth num (eieio--class-protection newc))) + ) + (if (not (eq prot super-prot)) + (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" + prot super-prot a))) + ;; End original PLN + + ;; PLN Tue Jun 26 11:57:06 2007 : + ;; Do a non redundant combination of ancient custom + ;; groups and new ones. + (when custg + (let* ((groups + (nthcdr num (eieio--class-public-custom-group newc))) + (list1 (car groups)) + (list2 (if (listp custg) custg (list custg)))) + (if (< (length list1) (length list2)) + (setq list1 (prog1 list2 (setq list2 list1)))) + (dolist (elt list2) + (unless (memq elt list1) + (push elt list1))) + (setcar groups list1))) + ;; End PLN + + ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is + ;; set, simply replaces the old one. + (when cust + ;; (message "Custom type redefined to %s" cust) + (setcar (nthcdr num (eieio--class-public-custom newc)) cust)) + + ;; If a new label is specified, it simply replaces + ;; the old one. + (when label + ;; (message "Custom label redefined to %s" label) + (setcar (nthcdr num (eieio--class-public-custom-label newc)) label)) + ;; End PLN + + ;; PLN Sat Jun 30 17:24:42 2007 : when a new + ;; doc is specified, simply replaces the old one. + (when doc + ;;(message "Documentation redefined to %s" doc) + (setcar (nthcdr num (eieio--class-public-doc newc)) + doc)) + ;; End PLN + + ;; If a new printer is specified, it simply replaces + ;; the old one. + (when print + ;; (message "printer redefined to %s" print) + (setcar (nthcdr num (eieio--class-public-printer newc)) print)) + + ))) + )) + + ;; CLASS ALLOCATED SLOTS + (let ((value (eieio-default-eval-maybe d))) + (if (not (member a (eieio--class-class-allocation-a newc))) + (progn + (eieio-perform-slot-validation-for-default a type value skipnil) + ;; Here we have found a :class version of a slot. This + ;; requires a very different approach. + (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) + (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) + (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) + (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) + (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) + (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) + (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) + ;; Default value is stored in the 'values section, since new objects + ;; can't initialize from this element. + (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) + (when defaultoverride + ;; There is a match, and we must override the old value. + (let* ((ca (eieio--class-class-allocation-a newc)) + (np (member a ca)) + (num (- (length ca) (length np))) + (dp (if np + (nthcdr num + (eieio--class-class-allocation-values newc)) + nil)) + (tp (if np (nth num (eieio--class-class-allocation-type newc)) + nil))) + (if (not np) + (error "EIEIO internal error overriding default value for %s" + a) + ;; If type is passed in, is it the same? + (if (not (eq type t)) + (if (not (equal type tp)) + (error + "Child slot type `%s' does not match inherited type `%s' for `%s'" + type tp a))) + ;; EML - Note: the only reason to override a class bound slot + ;; is to change the default, so allow unbound in. + + ;; If we have a repeat, only update the value... + (eieio-perform-slot-validation-for-default a tp value skipnil) + (setcar dp value)) + + ;; PLN Tue Jun 26 11:57:06 2007 : The protection is + ;; checked and SHOULD match the superclass + ;; protection. Otherwise an error is thrown. However + ;; I wonder if a more flexible schedule might be + ;; implemented. + (let ((super-prot + (car (nthcdr num (eieio--class-class-allocation-protection newc))))) + (if (not (eq prot super-prot)) + (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" + prot super-prot a))) + ;; Do a non redundant combination of ancient custom groups + ;; and new ones. + (when custg + (let* ((groups + (nthcdr num (eieio--class-class-allocation-custom-group newc))) + (list1 (car groups)) + (list2 (if (listp custg) custg (list custg)))) + (if (< (length list1) (length list2)) + (setq list1 (prog1 list2 (setq list2 list1)))) + (dolist (elt list2) + (unless (memq elt list1) + (push elt list1))) + (setcar groups list1))) + + ;; PLN Sat Jun 30 17:24:42 2007 : when a new + ;; doc is specified, simply replaces the old one. + (when doc + ;;(message "Documentation redefined to %s" doc) + (setcar (nthcdr num (eieio--class-class-allocation-doc newc)) + doc)) + ;; End PLN + + ;; If a new printer is specified, it simply replaces + ;; the old one. + (when print + ;; (message "printer redefined to %s" print) + (setcar (nthcdr num (eieio--class-class-allocation-printer newc)) print)) + + )) + )) + )) + +(defun eieio-copy-parents-into-subclass (newc parents) + "Copy into NEWC the slots of PARENTS. +Follow the rules of not overwriting early parents when applying to +the new child class." + (let ((ps (eieio--class-parent newc)) + (sn (class-option-assoc (eieio--class-options newc) + ':allow-nil-initform))) + (while ps + ;; First, duplicate all the slots of the parent. + (let ((pcv (class-v (car ps)))) + (let ((pa (eieio--class-public-a pcv)) + (pd (eieio--class-public-d pcv)) + (pdoc (eieio--class-public-doc pcv)) + (ptype (eieio--class-public-type pcv)) + (pcust (eieio--class-public-custom pcv)) + (plabel (eieio--class-public-custom-label pcv)) + (pcustg (eieio--class-public-custom-group pcv)) + (printer (eieio--class-public-printer pcv)) + (pprot (eieio--class-protection pcv)) + (pinit (eieio--class-initarg-tuples pcv)) + (i 0)) + (while pa + (eieio-add-new-slot newc + (car pa) (car pd) (car pdoc) (aref ptype i) + (car pcust) (car plabel) (car pcustg) + (car printer) + (car pprot) (car-safe (car pinit)) nil nil sn) + ;; Increment each value. + (setq pa (cdr pa) + pd (cdr pd) + pdoc (cdr pdoc) + i (1+ i) + pcust (cdr pcust) + plabel (cdr plabel) + pcustg (cdr pcustg) + printer (cdr printer) + pprot (cdr pprot) + pinit (cdr pinit)) + )) ;; while/let + ;; Now duplicate all the class alloc slots. + (let ((pa (eieio--class-class-allocation-a pcv)) + (pdoc (eieio--class-class-allocation-doc pcv)) + (ptype (eieio--class-class-allocation-type pcv)) + (pcust (eieio--class-class-allocation-custom pcv)) + (plabel (eieio--class-class-allocation-custom-label pcv)) + (pcustg (eieio--class-class-allocation-custom-group pcv)) + (printer (eieio--class-class-allocation-printer pcv)) + (pprot (eieio--class-class-allocation-protection pcv)) + (pval (eieio--class-class-allocation-values pcv)) + (i 0)) + (while pa + (eieio-add-new-slot newc + (car pa) (aref pval i) (car pdoc) (aref ptype i) + (car pcust) (car plabel) (car pcustg) + (car printer) + (car pprot) nil ':class sn) + ;; Increment each value. + (setq pa (cdr pa) + pdoc (cdr pdoc) + pcust (cdr pcust) + plabel (cdr plabel) + pcustg (cdr pcustg) + printer (cdr printer) + pprot (cdr pprot) + i (1+ i)) + ))) ;; while/let + ;; Loop over each parent class + (setq ps (cdr ps))) + )) + + +;;; CLOS methods and generics +;; + +(defun eieio--defgeneric-init-form (method doc-string) + "Form to use for the initial definition of a generic." + (cond + ((or (not (fboundp method)) + (eq 'autoload (car-safe (symbol-function method)))) + ;; Make sure the method tables are installed. + (eieiomt-install method) + ;; Construct the actual body of this function. + (eieio-defgeneric-form method doc-string)) + ((generic-p method) (symbol-function method)) ;Leave it as-is. + (t (error "You cannot create a generic/method over an existing symbol: %s" + method)))) + +(defun eieio-defgeneric-form (method doc-string) + "The lambda form that would be used as the function defined on METHOD. +All methods should call the same EIEIO function for dispatch. +DOC-STRING is the documentation attached to METHOD." + `(lambda (&rest local-args) + ,doc-string + (eieio-generic-call (quote ,method) local-args))) + +(defsubst eieio-defgeneric-reset-generic-form (method) + "Setup METHOD to call the generic form." + (let ((doc-string (documentation method))) + (fset method (eieio-defgeneric-form method doc-string)))) + +(defun eieio-defgeneric-form-primary-only (method doc-string) + "The lambda form that would be used as the function defined on METHOD. +All methods should call the same EIEIO function for dispatch. +DOC-STRING is the documentation attached to METHOD." + `(lambda (&rest local-args) + ,doc-string + (eieio-generic-call-primary-only (quote ,method) local-args))) + +(defsubst eieio-defgeneric-reset-generic-form-primary-only (method) + "Setup METHOD to call the generic form." + (let ((doc-string (documentation method))) + (fset method (eieio-defgeneric-form-primary-only method doc-string)))) + +(defun eieio-defgeneric-form-primary-only-one (method doc-string + class + impl + ) + "The lambda form that would be used as the function defined on METHOD. +All methods should call the same EIEIO function for dispatch. +DOC-STRING is the documentation attached to METHOD. +CLASS is the class symbol needed for private method access. +IMPL is the symbol holding the method implementation." + ;; NOTE: I tried out byte compiling this little fcn. Turns out it + ;; is faster to execute this for not byte-compiled. ie, install this, + ;; then measure calls going through here. I wonder why. + (require 'bytecomp) + (let ((byte-compile-warnings nil)) + (byte-compile + `(lambda (&rest local-args) + ,doc-string + ;; This is a cool cheat. Usually we need to look up in the + ;; method table to find out if there is a method or not. We can + ;; instead make that determination at load time when there is + ;; only one method. If the first arg is not a child of the class + ;; of that one implementation, then clearly, there is no method def. + (if (not (eieio-object-p (car local-args))) + ;; Not an object. Just signal. + (signal 'no-method-definition + (list ',method local-args)) + + ;; We do have an object. Make sure it is the right type. + (if ,(if (eq class eieio-default-superclass) + nil ; default superclass means just an obj. Already asked. + `(not (child-of-class-p (eieio--object-class (car local-args)) + ',class))) + + ;; If not the right kind of object, call no applicable + (apply 'no-applicable-method (car local-args) + ',method local-args) + + ;; It is ok, do the call. + ;; Fill in inter-call variables then evaluate the method. + (let ((eieio-generic-call-next-method-list nil) + (eieio-generic-call-key method-primary) + (eieio-generic-call-methodname ',method) + (eieio-generic-call-arglst local-args) + ) + (eieio--with-scoped-class ',class + ,(if (< emacs-major-version 24) + `(apply ,(list 'quote impl) local-args) + `(apply #',impl local-args))) + ;(,impl local-args) + ))))))) + +(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) + "Setup METHOD to call the generic form." + (let* ((doc-string (documentation method)) + (M (get method 'eieio-method-tree)) + (entry (car (aref M method-primary))) + ) + (fset method (eieio-defgeneric-form-primary-only-one + method doc-string + (car entry) + (cdr entry) + )))) + +(defun eieio-unbind-method-implementations (method) + "Make the generic method METHOD have no implementations. +It will leave the original generic function in place, +but remove reference to all implementations of METHOD." + (put method 'eieio-method-tree nil) + (put method 'eieio-method-obarray nil)) + +(defun eieio--defmethod (method kind argclass code) + "Work part of the `defmethod' macro defining METHOD with ARGS." + (let ((key + ;; Find optional keys. + (cond ((memq kind '(:BEFORE :before)) method-before) + ((memq kind '(:AFTER :after)) method-after) + ((memq kind '(:STATIC :static)) method-static) + ((memq kind '(:PRIMARY :primary nil)) method-primary) + ;; Primary key. + ;; (t method-primary) + (t (error "Unknown method kind %S" kind))))) + ;; Make sure there is a generic (when called from defclass). + (eieio--defalias + method (eieio--defgeneric-init-form + method (or (documentation code) + (format "Generically created method `%s'." method)))) + ;; Create symbol for property to bind to. If the first arg is of + ;; the form (varname vartype) and `vartype' is a class, then + ;; that class will be the type symbol. If not, then it will fall + ;; under the type `primary' which is a non-specific calling of the + ;; function. + (if argclass + (if (not (class-p argclass)) + (error "Unknown class type %s in method parameters" + argclass)) + ;; Generics are higher. + (setq key (eieio-specialized-key-to-generic-key key))) + ;; Put this lambda into the symbol so we can find it. + (eieiomt-add method code key argclass) + ) + + (when eieio-optimize-primary-methods-flag + ;; Optimizing step: + ;; + ;; If this method, after this setup, only has primary methods, then + ;; we can setup the generic that way. + (if (generic-primary-only-p method) + ;; If there is only one primary method, then we can go one more + ;; optimization step. + (if (generic-primary-only-one-p method) + (eieio-defgeneric-reset-generic-form-primary-only-one method) + (eieio-defgeneric-reset-generic-form-primary-only method)) + (eieio-defgeneric-reset-generic-form method))) + + method) + +;;; Slot type validation + +;; This is a hideous hack for replacing `typep' from cl-macs, to avoid +;; requiring the CL library at run-time. It can be eliminated if/when +;; `typep' is merged into Emacs core. +(defun eieio--typep (val type) + (if (symbolp type) + (cond ((get type 'cl-deftype-handler) + (eieio--typep val (funcall (get type 'cl-deftype-handler)))) + ((eq type t) t) + ((eq type 'null) (null val)) + ((eq type 'atom) (atom val)) + ((eq type 'float) (and (numberp val) (not (integerp val)))) + ((eq type 'real) (numberp val)) + ((eq type 'fixnum) (integerp val)) + ((memq type '(character string-char)) (characterp val)) + (t + (let* ((name (symbol-name type)) + (namep (intern (concat name "p")))) + (if (fboundp namep) + (funcall `(lambda () (,namep val))) + (funcall `(lambda () + (,(intern (concat name "-p")) val))))))) + (cond ((get (car type) 'cl-deftype-handler) + (eieio--typep val (apply (get (car type) 'cl-deftype-handler) + (cdr type)))) + ((memq (car type) '(integer float real number)) + (and (eieio--typep val (car type)) + (or (memq (cadr type) '(* nil)) + (if (consp (cadr type)) + (> val (car (cadr type))) + (>= val (cadr type)))) + (or (memq (caddr type) '(* nil)) + (if (consp (car (cddr type))) + (< val (caar (cddr type))) + (<= val (car (cddr type))))))) + ((memq (car type) '(and or not)) + (eval (cons (car type) + (mapcar (lambda (x) + `(eieio--typep (quote ,val) (quote ,x))) + (cdr type))))) + ((memq (car type) '(member member*)) + (memql val (cdr type))) + ((eq (car type) 'satisfies) + (funcall `(lambda () (,(cadr type) val)))) + (t (error "Bad type spec: %s" type))))) + +(defun eieio-perform-slot-validation (spec value) + "Return non-nil if SPEC does not match VALUE." + (or (eq spec t) ; t always passes + (eq value eieio-unbound) ; unbound always passes + (eieio--typep value spec))) + +(defun eieio-validate-slot-value (class slot-idx value slot) + "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. +Checks the :type specifier. +SLOT is the slot that is being checked, and is only used when throwing +an error." + (if eieio-skip-typecheck + nil + ;; Trim off object IDX junk added in for the object index. + (setq slot-idx (- slot-idx 3)) + (let ((st (aref (eieio--class-public-type (class-v class)) slot-idx))) + (if (not (eieio-perform-slot-validation st value)) + (signal 'invalid-slot-type (list class slot st value)))))) + +(defun eieio-validate-class-slot-value (class slot-idx value slot) + "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. +Checks the :type specifier. +SLOT is the slot that is being checked, and is only used when throwing +an error." + (if eieio-skip-typecheck + nil + (let ((st (aref (eieio--class-class-allocation-type (class-v class)) + slot-idx))) + (if (not (eieio-perform-slot-validation st value)) + (signal 'invalid-slot-type (list class slot st value)))))) + +(defun eieio-barf-if-slot-unbound (value instance slotname fn) + "Throw a signal if VALUE is a representation of an UNBOUND slot. +INSTANCE is the object being referenced. SLOTNAME is the offending +slot. If the slot is ok, return VALUE. +Argument FN is the function calling this verifier." + (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) + (slot-unbound instance (eieio--object-class instance) slotname fn) + value)) + + +;;; Get/Set slots in an object. +;; +(defun eieio-oref (obj slot) + "Return the value in OBJ at SLOT in the object vector." + (eieio--check-type (or eieio-object-p class-p) obj) + (eieio--check-type symbolp slot) + (if (class-p obj) (eieio-class-un-autoload obj)) + (let* ((class (if (class-p obj) obj (eieio--object-class obj))) + (c (eieio-slot-name-index class obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio-class-slot-name-index class slot)) + ;; Oref that slot. + (aref (eieio--class-class-allocation-values (class-v class)) c) + ;; The slot-missing method is a cool way of allowing an object author + ;; to intercept missing slot definitions. Since it is also the LAST + ;; thing called in this fn, its return value would be retrieved. + (slot-missing obj slot 'oref) + ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) + ) + (eieio--check-type eieio-object-p obj) + (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + + +(defun eieio-oref-default (obj slot) + "Do the work for the macro `oref-default' with similar parameters. +Fills in OBJ's SLOT with its default value." + (eieio--check-type (or eieio-object-p class-p) obj) + (eieio--check-type symbolp slot) + (let* ((cl (if (eieio-object-p obj) (eieio--object-class obj) obj)) + (c (eieio-slot-name-index cl obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio-class-slot-name-index cl slot)) + ;; Oref that slot. + (aref (eieio--class-class-allocation-values (class-v cl)) + c) + (slot-missing obj slot 'oref-default) + ;;(signal 'invalid-slot-name (list (class-name cl) slot)) + ) + (eieio-barf-if-slot-unbound + (let ((val (nth (- c 3) (eieio--class-public-d (class-v cl))))) + (eieio-default-eval-maybe val)) + obj cl 'oref-default)))) + +(defun eieio-default-eval-maybe (val) + "Check VAL, and return what `oref-default' would provide." + (cond + ;; Is it a function call? If so, evaluate it. + ((eieio-eval-default-p val) + (eval val)) + ;;;; check for quoted things, and unquote them + ;;((and (consp val) (eq (car val) 'quote)) + ;; (car (cdr val))) + ;; return it verbatim + (t val))) + +(defun eieio-oset (obj slot value) + "Do the work for the macro `oset'. +Fills in OBJ's SLOT with VALUE." + (eieio--check-type eieio-object-p obj) + (eieio--check-type symbolp slot) + (let ((c (eieio-slot-name-index (eieio--object-class obj) obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio-class-slot-name-index (eieio--object-class obj) slot)) + ;; Oset that slot. + (progn + (eieio-validate-class-slot-value (eieio--object-class obj) c value slot) + (aset (eieio--class-class-allocation-values (class-v (eieio--object-class obj))) + c value)) + ;; See oref for comment on `slot-missing' + (slot-missing obj slot 'oset value) + ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) + ) + (eieio-validate-slot-value (eieio--object-class obj) c value slot) + (aset obj c value)))) + +(defun eieio-oset-default (class slot value) + "Do the work for the macro `oset-default'. +Fills in the default value in CLASS' in SLOT with VALUE." + (eieio--check-type class-p class) + (eieio--check-type symbolp slot) + (eieio--with-scoped-class class + (let* ((c (eieio-slot-name-index class nil slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio-class-slot-name-index class slot)) + (progn + ;; Oref that slot. + (eieio-validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values (class-v class)) c + value)) + (signal 'invalid-slot-name (list (eieio-class-name class) slot))) + (eieio-validate-slot-value class c value slot) + ;; Set this into the storage for defaults. + (setcar (nthcdr (- c 3) (eieio--class-public-d (class-v class))) + value) + ;; Take the value, and put it into our cache object. + (eieio-oset (eieio--class-default-object-cache (class-v class)) + slot value) + )))) + + +;;; EIEIO internal search functions +;; +(defun eieio-slot-originating-class-p (start-class slot) + "Return non-nil if START-CLASS is the first class to define SLOT. +This is for testing if the class currently in scope is the class that defines SLOT +so that we can protect private slots." + (let ((par (eieio-class-parents-fast start-class)) + (ret t)) + (if (not par) + t + (while (and par ret) + (if (intern-soft (symbol-name slot) + (eieio--class-symbol-obarray (class-v (car par)))) + (setq ret nil)) + (setq par (cdr par))) + ret))) + +(defun eieio-slot-name-index (class obj slot) + "In CLASS for OBJ find the index of the named SLOT. +The slot is a symbol which is installed in CLASS by the `defclass' +call. OBJ can be nil, but if it is an object, and the slot in question +is protected, access will be allowed if OBJ is a child of the currently +scoped class. +If SLOT is the value created with :initarg instead, +reverse-lookup that name, and recurse with the associated slot value." + ;; Removed checks to outside this call + (let* ((fsym (intern-soft (symbol-name slot) + (eieio--class-symbol-obarray (class-v class)))) + (fsi (if (symbolp fsym) (symbol-value fsym) nil))) + (if (integerp fsi) + (cond + ((not (get fsym 'protection)) + (+ 3 fsi)) + ((and (eq (get fsym 'protection) 'protected) + (eieio--scoped-class) + (or (child-of-class-p class (eieio--scoped-class)) + (and (eieio-object-p obj) + (child-of-class-p class (eieio--object-class obj))))) + (+ 3 fsi)) + ((and (eq (get fsym 'protection) 'private) + (or (and (eieio--scoped-class) + (eieio-slot-originating-class-p (eieio--scoped-class) slot)) + eieio-initializing-object)) + (+ 3 fsi)) + (t nil)) + (let ((fn (eieio-initarg-to-attribute class slot))) + (if fn (eieio-slot-name-index class obj fn) nil))))) + +(defun eieio-class-slot-name-index (class slot) + "In CLASS find the index of the named SLOT. +The slot is a symbol which is installed in CLASS by the `defclass' +call. If SLOT is the value created with :initarg instead, +reverse-lookup that name, and recurse with the associated slot value." + ;; This will happen less often, and with fewer slots. Do this the + ;; storage cheap way. + (let* ((a (eieio--class-class-allocation-a (class-v class))) + (l1 (length a)) + (af (memq slot a)) + (l2 (length af))) + ;; Slot # is length of the total list, minus the remaining list of + ;; the found slot. + (if af (- l1 l2)))) + +;;; +;; Way to assign slots based on a list. Used for constructors, or +;; even resetting an object at run-time +;; +(defun eieio-set-defaults (obj &optional set-all) + "Take object OBJ, and reset all slots to their defaults. +If SET-ALL is non-nil, then when a default is nil, that value is +reset. If SET-ALL is nil, the slots are only reset if the default is +not nil." + (eieio--with-scoped-class (eieio--object-class obj) + (let ((eieio-initializing-object t) + (pub (eieio--class-public-a (class-v (eieio--object-class obj))))) + (while pub + (let ((df (eieio-oref-default obj (car pub)))) + (if (or df set-all) + (eieio-oset obj (car pub) df))) + (setq pub (cdr pub)))))) + +(defun eieio-initarg-to-attribute (class initarg) + "For CLASS, convert INITARG to the actual attribute name. +If there is no translation, pass it in directly (so we can cheat if +need be... May remove that later...)" + (let ((tuple (assoc initarg (eieio--class-initarg-tuples (class-v class))))) + (if tuple + (cdr tuple) + nil))) + +(defun eieio-attribute-to-initarg (class attribute) + "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. +This is usually a symbol that starts with `:'." + (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (class-v class))))) + (if tuple + (car tuple) + nil))) + +;;; +;; Method Invocation order: C3 +(defun eieio-c3-candidate (class remaining-inputs) + "Return CLASS if it can go in the result now, otherwise nil" + ;; Ensure CLASS is not in any position but the first in any of the + ;; element lists of REMAINING-INPUTS. + (and (not (let ((found nil)) + (while (and remaining-inputs (not found)) + (setq found (member class (cdr (car remaining-inputs))) + remaining-inputs (cdr remaining-inputs))) + found)) + class)) + +(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) + "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. +If a consistent order does not exist, signal an error." + (if (let ((tail remaining-inputs) + (found nil)) + (while (and tail (not found)) + (setq found (car tail) tail (cdr tail))) + (not found)) + ;; If all remaining inputs are empty lists, we are done. + (nreverse reversed-partial-result) + ;; Otherwise, we try to find the next element of the result. This + ;; is achieved by considering the first element of each + ;; (non-empty) input list and accepting a candidate if it is + ;; consistent with the rests of the input lists. + (let* ((found nil) + (tail remaining-inputs) + (next (progn + (while (and tail (not found)) + (setq found (and (car tail) + (eieio-c3-candidate (caar tail) + remaining-inputs)) + tail (cdr tail))) + found))) + (if next + ;; The graph is consistent so far, add NEXT to result and + ;; merge input lists, dropping NEXT from their heads where + ;; applicable. + (eieio-c3-merge-lists + (cons next reversed-partial-result) + (mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) + remaining-inputs)) + ;; The graph is inconsistent, give up + (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) + +(defun eieio-class-precedence-c3 (class) + "Return all parents of CLASS in c3 order." + (let ((parents (eieio-class-parents-fast class))) + (eieio-c3-merge-lists + (list class) + (append + (or + (mapcar + (lambda (x) + (eieio-class-precedence-c3 x)) + parents) + '((eieio-default-superclass))) + (list parents)))) + ) +;;; +;; Method Invocation Order: Depth First + +(defun eieio-class-precedence-dfs (class) + "Return all parents of CLASS in depth-first order." + (let* ((parents (eieio-class-parents-fast class)) + (classes (copy-sequence + (apply #'append + (list class) + (or + (mapcar + (lambda (parent) + (cons parent + (eieio-class-precedence-dfs parent))) + parents) + '((eieio-default-superclass)))))) + (tail classes)) + ;; Remove duplicates. + (while tail + (setcdr tail (delq (car tail) (cdr tail))) + (setq tail (cdr tail))) + classes)) + +;;; +;; Method Invocation Order: Breadth First +(defun eieio-class-precedence-bfs (class) + "Return all parents of CLASS in breadth-first order." + (let ((result) + (queue (or (eieio-class-parents-fast class) + '(eieio-default-superclass)))) + (while queue + (let ((head (pop queue))) + (unless (member head result) + (push head result) + (unless (eq head 'eieio-default-superclass) + (setq queue (append queue (or (eieio-class-parents-fast head) + '(eieio-default-superclass)))))))) + (cons class (nreverse result))) + ) + +;;; +;; Method Invocation Order + +(defun eieio-class-precedence-list (class) + "Return (transitively closed) list of parents of CLASS. +The order, in which the parents are returned depends on the +method invocation orders of the involved classes." + (if (or (null class) (eq class 'eieio-default-superclass)) + nil + (case (class-method-invocation-order class) + (:depth-first + (eieio-class-precedence-dfs class)) + (:breadth-first + (eieio-class-precedence-bfs class)) + (:c3 + (eieio-class-precedence-c3 class)))) + ) +(define-obsolete-function-alias + 'class-precedence-list 'eieio-class-precedence-list "24.4") + + +;;; CLOS generics internal function handling +;; +(defvar eieio-generic-call-methodname nil + "When using `call-next-method', provides a context on how to do it.") +(defvar eieio-generic-call-arglst nil + "When using `call-next-method', provides a context for parameters.") +(defvar eieio-generic-call-key nil + "When using `call-next-method', provides a context for the current key. +Keys are a number representing :before, :primary, and :after methods.") +(defvar eieio-generic-call-next-method-list nil + "When executing a PRIMARY or STATIC method, track the 'next-method'. +During executions, the list is first generated, then as each next method +is called, the next method is popped off the stack.") + +(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks + 'eieio-pre-method-execution-functions "24.3") +(defvar eieio-pre-method-execution-functions nil + "Abnormal hook run just before an EIEIO method is executed. +The hook function must accept one argument, the list of forms +about to be executed.") + +(defun eieio-generic-call (method args) + "Call METHOD with ARGS. +ARGS provides the context on which implementation to use. +This should only be called from a generic function." + ;; We must expand our arguments first as they are always + ;; passed in as quoted symbols + (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) + (eieio-generic-call-methodname method) + (eieio-generic-call-arglst args) + (firstarg nil) + (primarymethodlist nil)) + ;; get a copy + (setq newargs args + firstarg (car newargs)) + ;; Is the class passed in autoloaded? + ;; Since class names are also constructors, they can be autoloaded + ;; via the autoload command. Check for this, and load them in. + ;; It is ok if it doesn't turn out to be a class. Probably want that + ;; function loaded anyway. + (if (and (symbolp firstarg) + (fboundp firstarg) + (listp (symbol-function firstarg)) + (eq 'autoload (car (symbol-function firstarg)))) + (load (nth 1 (symbol-function firstarg)))) + ;; Determine the class to use. + (cond ((eieio-object-p firstarg) + (setq mclass (eieio--object-class firstarg))) + ((class-p firstarg) + (setq mclass firstarg)) + ) + ;; Make sure the class is a valid class + ;; mclass can be nil (meaning a generic for should be used. + ;; mclass cannot have a value that is not a class, however. + (when (and (not (null mclass)) (not (class-p mclass))) + (error "Cannot dispatch method %S on class %S" + method mclass) + ) + ;; Now create a list in reverse order of all the calls we have + ;; make in order to successfully do this right. Rules: + ;; 1) Only call generics if scoped-class is not defined + ;; This prevents multiple calls in the case of recursion + ;; 2) Only call static if this is a static method. + ;; 3) Only call specifics if the definition allows for them. + ;; 4) Call in order based on :before, :primary, and :after + (when (eieio-object-p firstarg) + ;; Non-static calls do all this stuff. + + ;; :after methods + (setq tlambdas + (if mclass + (eieiomt-method-list method method-after mclass) + (list (eieio-generic-form method method-after nil))) + ;;(or (and mclass (eieio-generic-form method method-after mclass)) + ;; (eieio-generic-form method method-after nil)) + ) + (setq lambdas (append tlambdas lambdas) + keys (append (make-list (length tlambdas) method-after) keys)) + + ;; :primary methods + (setq tlambdas + (or (and mclass (eieio-generic-form method method-primary mclass)) + (eieio-generic-form method method-primary nil))) + (when tlambdas + (setq lambdas (cons tlambdas lambdas) + keys (cons method-primary keys) + primarymethodlist + (eieiomt-method-list method method-primary mclass))) + + ;; :before methods + (setq tlambdas + (if mclass + (eieiomt-method-list method method-before mclass) + (list (eieio-generic-form method method-before nil))) + ;;(or (and mclass (eieio-generic-form method method-before mclass)) + ;; (eieio-generic-form method method-before nil)) + ) + (setq lambdas (append tlambdas lambdas) + keys (append (make-list (length tlambdas) method-before) keys)) + ) + + (if mclass + ;; For the case of a class, + ;; if there were no methods found, then there could be :static methods. + (when (not lambdas) + (setq tlambdas + (eieio-generic-form method method-static mclass)) + (setq lambdas (cons tlambdas lambdas) + keys (cons method-static keys) + primarymethodlist ;; Re-use even with bad name here + (eieiomt-method-list method method-static mclass))) + ;; For the case of no class (ie - mclass == nil) then there may + ;; be a primary method. + (setq tlambdas + (eieio-generic-form method method-primary nil)) + (when tlambdas + (setq lambdas (cons tlambdas lambdas) + keys (cons method-primary keys) + primarymethodlist + (eieiomt-method-list method method-primary nil))) + ) + + (run-hook-with-args 'eieio-pre-method-execution-functions + primarymethodlist) + + ;; Now loop through all occurrences forms which we must execute + ;; (which are happily sorted now) and execute them all! + (let ((rval nil) (lastval nil) (rvalever nil) (found nil)) + (while lambdas + (if (car lambdas) + (eieio--with-scoped-class (cdr (car lambdas)) + (let* ((eieio-generic-call-key (car keys)) + (has-return-val + (or (= eieio-generic-call-key method-primary) + (= eieio-generic-call-key method-static))) + (eieio-generic-call-next-method-list + ;; Use the cdr, as the first element is the fcn + ;; we are calling right now. + (when has-return-val (cdr primarymethodlist))) + ) + (setq found t) + ;;(setq rval (apply (car (car lambdas)) newargs)) + (setq lastval (apply (car (car lambdas)) newargs)) + (when has-return-val + (setq rval lastval + rvalever t)) + ))) + (setq lambdas (cdr lambdas) + keys (cdr keys))) + (if (not found) + (if (eieio-object-p (car args)) + (setq rval (apply 'no-applicable-method (car args) method args) + rvalever t) + (signal + 'no-method-definition + (list method args)))) + ;; Right Here... it could be that lastval is returned when + ;; rvalever is nil. Is that right? + rval))) + +(defun eieio-generic-call-primary-only (method args) + "Call METHOD with ARGS for methods with only :PRIMARY implementations. +ARGS provides the context on which implementation to use. +This should only be called from a generic function. + +This method is like `eieio-generic-call', but only +implementations in the :PRIMARY slot are queried. After many +years of use, it appears that over 90% of methods in use +have :PRIMARY implementations only. We can therefore optimize +for this common case to improve performance." + ;; We must expand our arguments first as they are always + ;; passed in as quoted symbols + (let ((newargs nil) (mclass nil) (lambdas nil) + (eieio-generic-call-methodname method) + (eieio-generic-call-arglst args) + (firstarg nil) + (primarymethodlist nil) + ) + ;; get a copy + (setq newargs args + firstarg (car newargs)) + + ;; Determine the class to use. + (cond ((eieio-object-p firstarg) + (setq mclass (eieio--object-class firstarg))) + ((not firstarg) + (error "Method %s called on nil" method)) + ((not (eieio-object-p firstarg)) + (error "Primary-only method %s called on something not an object" method)) + (t + (error "EIEIO Error: Improperly classified method %s as primary only" + method) + )) + ;; Make sure the class is a valid class + ;; mclass can be nil (meaning a generic for should be used. + ;; mclass cannot have a value that is not a class, however. + (when (null mclass) + (error "Cannot dispatch method %S on class %S" method mclass) + ) + + ;; :primary methods + (setq lambdas (eieio-generic-form method method-primary mclass)) + (setq primarymethodlist ;; Re-use even with bad name here + (eieiomt-method-list method method-primary mclass)) + + ;; Now loop through all occurrences forms which we must execute + ;; (which are happily sorted now) and execute them all! + (eieio--with-scoped-class (cdr lambdas) + (let* ((rval nil) (lastval nil) (rvalever nil) + (eieio-generic-call-key method-primary) + ;; Use the cdr, as the first element is the fcn + ;; we are calling right now. + (eieio-generic-call-next-method-list (cdr primarymethodlist)) + ) + + (if (or (not lambdas) (not (car lambdas))) + + ;; No methods found for this impl... + (if (eieio-object-p (car args)) + (setq rval (apply 'no-applicable-method (car args) method args) + rvalever t) + (signal + 'no-method-definition + (list method args))) + + ;; Do the regular implementation here. + + (run-hook-with-args 'eieio-pre-method-execution-functions + lambdas) + + (setq lastval (apply (car lambdas) newargs)) + (setq rval lastval + rvalever t) + ) + + ;; Right Here... it could be that lastval is returned when + ;; rvalever is nil. Is that right? + rval)))) + +(defun eieiomt-method-list (method key class) + "Return an alist list of methods lambdas. +METHOD is the method name. +KEY represents either :before, or :after methods. +CLASS is the starting class to search from in the method tree. +If CLASS is nil, then an empty list of methods should be returned." + ;; Note: eieiomt - the MT means MethodTree. See more comments below + ;; for the rest of the eieiomt methods. + + ;; Collect lambda expressions stored for the class and its parent + ;; classes. + (let (lambdas) + (dolist (ancestor (eieio-class-precedence-list class)) + ;; Lookup the form to use for the PRIMARY object for the next level + (let ((tmpl (eieio-generic-form method key ancestor))) + (when (and tmpl + (or (not lambdas) + ;; This prevents duplicates coming out of the + ;; class method optimizer. Perhaps we should + ;; just not optimize before/afters? + (not (member tmpl lambdas)))) + (push tmpl lambdas)))) + + ;; Return collected lambda. For :after methods, return in current + ;; order (most general class last); Otherwise, reverse order. + (if (eq key method-after) + lambdas + (nreverse lambdas)))) + + +;;; +;; eieio-method-tree : eieiomt- +;; +;; Stored as eieio-method-tree in property list of a generic method +;; +;; (eieio-method-tree . [BEFORE PRIMARY AFTER +;; genericBEFORE genericPRIMARY genericAFTER]) +;; and +;; (eieio-method-obarray . [BEFORE PRIMARY AFTER +;; genericBEFORE genericPRIMARY genericAFTER]) +;; where the association is a vector. +;; (aref 0 -- all static methods. +;; (aref 1 -- all methods classified as :before +;; (aref 2 -- all methods classified as :primary +;; (aref 3 -- all methods classified as :after +;; (aref 4 -- a generic classified as :before +;; (aref 5 -- a generic classified as :primary +;; (aref 6 -- a generic classified as :after +;; +(defvar eieiomt-optimizing-obarray nil + "While mapping atoms, this contain the obarray being optimized.") + +(defun eieiomt-install (method-name) + "Install the method tree, and obarray onto METHOD-NAME. +Do not do the work if they already exist." + (let ((emtv (get method-name 'eieio-method-tree)) + (emto (get method-name 'eieio-method-obarray))) + (if (or (not emtv) (not emto)) + (progn + (setq emtv (put method-name 'eieio-method-tree + (make-vector method-num-slots nil)) + emto (put method-name 'eieio-method-obarray + (make-vector method-num-slots nil))) + (aset emto 0 (make-vector 11 0)) + (aset emto 1 (make-vector 11 0)) + (aset emto 2 (make-vector 41 0)) + (aset emto 3 (make-vector 11 0)) + )))) + +(defun eieiomt-add (method-name method key class) + "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. +METHOD-NAME is the name created by a call to `defgeneric'. +METHOD are the forms for a given implementation. +KEY is an integer (see comment in eieio.el near this function) which +is associated with the :static :before :primary and :after tags. +It also indicates if CLASS is defined or not. +CLASS is the class this method is associated with." + (if (or (> key method-num-slots) (< key 0)) + (error "eieiomt-add: method key error!")) + (let ((emtv (get method-name 'eieio-method-tree)) + (emto (get method-name 'eieio-method-obarray))) + ;; Make sure the method tables are available. + (if (or (not emtv) (not emto)) + (error "Programmer error: eieiomt-add")) + ;; only add new cells on if it doesn't already exist! + (if (assq class (aref emtv key)) + (setcdr (assq class (aref emtv key)) method) + (aset emtv key (cons (cons class method) (aref emtv key)))) + ;; Add function definition into newly created symbol, and store + ;; said symbol in the correct obarray, otherwise use the + ;; other array to keep this stuff + (if (< key method-num-lists) + (let ((nsym (intern (symbol-name class) (aref emto key)))) + (fset nsym method))) + ;; Save the defmethod file location in a symbol property. + (let ((fname (if load-in-progress + load-file-name + buffer-file-name)) + loc) + (when fname + (when (string-match "\\.elc$" fname) + (setq fname (substring fname 0 (1- (length fname))))) + (setq loc (get method-name 'method-locations)) + (pushnew (list class fname) loc :test 'equal) + (put method-name 'method-locations loc))) + ;; Now optimize the entire obarray + (if (< key method-num-lists) + (let ((eieiomt-optimizing-obarray (aref emto key))) + ;; @todo - Is this overkill? Should we just clear the symbol? + (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) + )) + +(defun eieiomt-next (class) + "Return the next parent class for CLASS. +If CLASS is a superclass, return variable `eieio-default-superclass'. +If CLASS is variable `eieio-default-superclass' then return nil. +This is different from function `class-parent' as class parent returns +nil for superclasses. This function performs no type checking!" + ;; No type-checking because all calls are made from functions which + ;; are safe and do checking for us. + (or (eieio-class-parents-fast class) + (if (eq class 'eieio-default-superclass) + nil + '(eieio-default-superclass)))) + +(defun eieiomt-sym-optimize (s) + "Find the next class above S which has a function body for the optimizer." + ;; Set the value to nil in case there is no nearest cell. + (set s nil) + ;; Find the nearest cell that has a function body. If we find one, + ;; we replace the nil from above. + (let ((external-symbol (intern-soft (symbol-name s)))) + (catch 'done + (dolist (ancestor (rest (eieio-class-precedence-list external-symbol))) + (let ((ov (intern-soft (symbol-name ancestor) + eieiomt-optimizing-obarray))) + (when (fboundp ov) + (set s ov) ;; store ov as our next symbol + (throw 'done ancestor))))))) + +(defun eieio-generic-form (method key class) + "Return the lambda form belonging to METHOD using KEY based upon CLASS. +If CLASS is not a class then use `generic' instead. If class has +no form, but has a parent class, then trace to that parent class. +The first time a form is requested from a symbol, an optimized path +is memorized for faster future use." + (let ((emto (aref (get method 'eieio-method-obarray) + (if class key (eieio-specialized-key-to-generic-key key))))) + (if (class-p class) + ;; 1) find our symbol + (let ((cs (intern-soft (symbol-name class) emto))) + (if (not cs) + ;; 2) If there isn't one, then make one. + ;; This can be slow since it only occurs once + (progn + (setq cs (intern (symbol-name class) emto)) + ;; 2.1) Cache its nearest neighbor with a quick optimize + ;; which should only occur once for this call ever + (let ((eieiomt-optimizing-obarray emto)) + (eieiomt-sym-optimize cs)))) + ;; 3) If it's bound return this one. + (if (fboundp cs) + (cons cs (eieio--class-symbol (class-v class))) + ;; 4) If it's not bound then this variable knows something + (if (symbol-value cs) + (progn + ;; 4.1) This symbol holds the next class in its value + (setq class (symbol-value cs) + cs (intern-soft (symbol-name class) emto)) + ;; 4.2) The optimizer should always have chosen a + ;; function-symbol + ;;(if (fboundp cs) + (cons cs (eieio--class-symbol (class-v (intern (symbol-name class))))) + ;;(error "EIEIO optimizer: erratic data loss!")) + ) + ;; There never will be a funcall... + nil))) + ;; for a generic call, what is a list, is the function body we want. + (let ((emtl (aref (get method 'eieio-method-tree) + (if class key (eieio-specialized-key-to-generic-key key))))) + (if emtl + ;; The car of EMTL is supposed to be a class, which in this + ;; case is nil, so skip it. + (cons (cdr (car emtl)) nil) + nil))))) + + +;;; Here are some special types of errors +;; +(intern "no-method-definition") +(put 'no-method-definition 'error-conditions '(no-method-definition error)) +(put 'no-method-definition 'error-message "No method definition") + +(intern "no-next-method") +(put 'no-next-method 'error-conditions '(no-next-method error)) +(put 'no-next-method 'error-message "No next method") + +(intern "invalid-slot-name") +(put 'invalid-slot-name 'error-conditions '(invalid-slot-name error)) +(put 'invalid-slot-name 'error-message "Invalid slot name") + +(intern "invalid-slot-type") +(put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil)) +(put 'invalid-slot-type 'error-message "Invalid slot type") + +(intern "unbound-slot") +(put 'unbound-slot 'error-conditions '(unbound-slot error nil)) +(put 'unbound-slot 'error-message "Unbound slot") + +(intern "inconsistent-class-hierarchy") +(put 'inconsistent-class-hierarchy 'error-conditions + '(inconsistent-class-hierarchy error nil)) +(put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy") + +;;; Obsolete backward compatibility functions. +;; Needed to run byte-code compiled with the EIEIO of Emacs-23. + +(defun eieio-defmethod (method args) + "Obsolete work part of an old version of the `defmethod' macro." + (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) + ;; find optional keys + (setq key + (cond ((memq (car args) '(:BEFORE :before)) + (setq args (cdr args)) + method-before) + ((memq (car args) '(:AFTER :after)) + (setq args (cdr args)) + method-after) + ((memq (car args) '(:STATIC :static)) + (setq args (cdr args)) + method-static) + ((memq (car args) '(:PRIMARY :primary)) + (setq args (cdr args)) + method-primary) + ;; Primary key. + (t method-primary))) + ;; Get body, and fix contents of args to be the arguments of the fn. + (setq body (cdr args) + args (car args)) + (setq loopa args) + ;; Create a fixed version of the arguments. + (while loopa + (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) + argfix)) + (setq loopa (cdr loopa))) + ;; Make sure there is a generic. + (eieio-defgeneric + method + (if (stringp (car body)) + (car body) (format "Generically created method `%s'." method))) + ;; create symbol for property to bind to. If the first arg is of + ;; the form (varname vartype) and `vartype' is a class, then + ;; that class will be the type symbol. If not, then it will fall + ;; under the type `primary' which is a non-specific calling of the + ;; function. + (setq firstarg (car args)) + (if (listp firstarg) + (progn + (setq argclass (nth 1 firstarg)) + (if (not (class-p argclass)) + (error "Unknown class type %s in method parameters" + (nth 1 firstarg)))) + ;; Generics are higher. + (setq key (eieio-specialized-key-to-generic-key key))) + ;; Put this lambda into the symbol so we can find it. + (if (byte-code-function-p (car-safe body)) + (eieiomt-add method (car-safe body) key argclass) + (eieiomt-add method (append (list 'lambda (reverse argfix)) body) + key argclass)) + ) + + (when eieio-optimize-primary-methods-flag + ;; Optimizing step: + ;; + ;; If this method, after this setup, only has primary methods, then + ;; we can setup the generic that way. + (if (generic-primary-only-p method) + ;; If there is only one primary method, then we can go one more + ;; optimization step. + (if (generic-primary-only-one-p method) + (eieio-defgeneric-reset-generic-form-primary-only-one method) + (eieio-defgeneric-reset-generic-form-primary-only method)) + (eieio-defgeneric-reset-generic-form method))) + + method) +(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") + +(defun eieio-defgeneric (method doc-string) + "Obsolete work part of an old version of the `defgeneric' macro." + (if (and (fboundp method) (not (generic-p method)) + (or (byte-code-function-p (symbol-function method)) + (not (eq 'autoload (car (symbol-function method))))) + ) + (error "You cannot create a generic/method over an existing symbol: %s" + method)) + ;; Don't do this over and over. + (unless (fboundp 'method) + ;; This defun tells emacs where the first definition of this + ;; method is defined. + `(defun ,method nil) + ;; Make sure the method tables are installed. + (eieiomt-install method) + ;; Apply the actual body of this function. + (fset method (eieio-defgeneric-form method doc-string)) + ;; Return the method + 'method)) +(make-obsolete 'eieio-defgeneric nil "24.1") + +(provide 'eieio-core) + +;;; eieio-core.el ends here diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 59aeb161d8e..f9917bddd42 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -1,6 +1,7 @@ ;;; eieio-custom.el -- eieio object customization -;; Copyright (C) 1999-2001, 2005, 2007-2012 Free Software Foundation, Inc. +;; Copyright (C) 1999-2001, 2005, 2007-2013 Free Software Foundation, +;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 @@ -191,22 +192,22 @@ Optional argument IGNORE is an extraneous parameter." (let* ((chil nil) (obj (widget-get widget :value)) (master-group (widget-get widget :eieio-group)) - (cv (class-v (object-class-fast obj))) - (slots (aref cv class-public-a)) - (flabel (aref cv class-public-custom-label)) - (fgroup (aref cv class-public-custom-group)) - (fdoc (aref cv class-public-doc)) - (fcust (aref cv class-public-custom))) + (cv (class-v (eieio--object-class obj))) + (slots (eieio--class-public-a cv)) + (flabel (eieio--class-public-custom-label cv)) + (fgroup (eieio--class-public-custom-group cv)) + (fdoc (eieio--class-public-doc cv)) + (fcust (eieio--class-public-custom cv))) ;; First line describes the object, but may not editable. (if (widget-get widget :eieio-show-name) (setq chil (cons (widget-create-child-and-convert widget 'string :tag "Object " :sample-face 'bold - (object-name-string obj)) + (eieio-object-name-string obj)) chil))) ;; Display information about the group being shown (when master-group - (let ((groups (class-option (object-class-fast obj) :custom-groups))) + (let ((groups (class-option (eieio--object-class obj) :custom-groups))) (widget-insert "Groups:") (while groups (widget-insert " ") @@ -259,7 +260,7 @@ Optional argument IGNORE is an extraneous parameter." (let ((s (symbol-name (or (class-slot-initarg - (object-class-fast obj) + (eieio--object-class obj) (car slots)) (car slots))))) (capitalize @@ -286,17 +287,17 @@ Optional argument IGNORE is an extraneous parameter." "Get the value of WIDGET." (let* ((obj (widget-get widget :value)) (master-group eieio-cog) - (cv (class-v (object-class-fast obj))) - (fgroup (aref cv class-public-custom-group)) + (cv (class-v (eieio--object-class obj))) + (fgroup (eieio--class-public-custom-group cv)) (wids (widget-get widget :children)) (name (if (widget-get widget :eieio-show-name) (car (widget-apply (car wids) :value-inline)) nil)) (chil (if (widget-get widget :eieio-show-name) (nthcdr 1 wids) wids)) - (cv (class-v (object-class-fast obj))) - (slots (aref cv class-public-a)) - (fcust (aref cv class-public-custom))) + (cv (class-v (eieio--object-class obj))) + (slots (eieio--class-public-a cv)) + (fcust (eieio--class-public-custom cv))) ;; If there are any prefix widgets, clear them. ;; -- None yet ;; Create a batch of initargs for each slot. @@ -315,7 +316,7 @@ Optional argument IGNORE is an extraneous parameter." fgroup (cdr fgroup) fcust (cdr fcust))) ;; Set any name updates on it. - (if name (aset obj object-name name)) + (if name (setf (eieio--object-name obj) name)) ;; This is the same object we had before. obj)) @@ -332,6 +333,16 @@ Argument OBJ is the object that has been customized." Optional argument GROUP is the sub-group of slots to display." (eieio-customize-object obj group)) +(defvar eieio-custom-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map widget-keymap) + map) + "Keymap for EIEIO Custom mode") + +(define-derived-mode eieio-custom-mode fundamental-mode "EIEIO Custom" + "Major mode for customizing EIEIO objects. +\\{eieio-custom-mode-map}") + (defmethod eieio-customize-object ((obj eieio-default-superclass) &optional group) "Customize OBJ in a specialized custom buffer. @@ -343,10 +354,11 @@ These groups are specified with the `:group' slot flag." (let* ((g (or group 'default))) (switch-to-buffer (get-buffer-create (concat "*CUSTOMIZE " - (object-name obj) " " + (eieio-object-name obj) " " (symbol-name g) "*"))) (setq buffer-read-only nil) (kill-all-local-variables) + (eieio-custom-mode) (erase-buffer) (let ((all (overlay-lists))) ;; Delete all the overlays. @@ -355,7 +367,7 @@ These groups are specified with the `:group' slot flag." ;; Add an apply reset option at the top of the buffer. (eieio-custom-object-apply-reset obj) (widget-insert "\n\n") - (widget-insert "Edit object " (object-name obj) "\n\n") + (widget-insert "Edit object " (eieio-object-name obj) "\n\n") ;; Create the widget editing the object. (make-local-variable 'eieio-wo) (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g)) @@ -363,7 +375,6 @@ These groups are specified with the `:group' slot flag." (widget-insert "\n") (eieio-custom-object-apply-reset obj) ;; Now initialize the buffer - (use-local-map widget-keymap) (widget-setup) ;;(widget-minor-mode) (goto-char (point-min)) @@ -441,7 +452,7 @@ Must return the created widget." (vector (concat "Group " (symbol-name group)) (list 'customize-object obj (list 'quote group)) t)) - (class-option (object-class-fast obj) :custom-groups))) + (class-option (eieio--object-class obj) :custom-groups))) (defvar eieio-read-custom-group-history nil "History for the custom group reader.") @@ -449,7 +460,7 @@ Must return the created widget." (defmethod eieio-read-customization-group ((obj eieio-default-superclass)) "Do a completing read on the name of a customization group in OBJ. Return the symbol for the group, or nil" - (let ((g (class-option (object-class-fast obj) :custom-groups))) + (let ((g (class-option (eieio--object-class obj) :custom-groups))) (if (= (length g) 1) (car g) ;; Make the association list @@ -461,8 +472,4 @@ Return the symbol for the group, or nil" (provide 'eieio-custom) -;; Local variables: -;; generated-autoload-file: "eieio.el" -;; End: - ;;; eieio-custom.el ends here diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index b7f0deb0ee2..d3ae8b191e1 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -1,6 +1,6 @@ ;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -;; Copyright (C) 2007-2012 Free Software Foundation, Inc. +;; Copyright (C) 2007-2013 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp @@ -58,9 +58,9 @@ PREBUTTONTEXT is some text between PREFIX and the object button." (end nil) (str (object-print object)) (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" - (object-name-string object) - (object-class object) - (class-parents (object-class object)) + (eieio-object-name-string object) + (eieio-object-class object) + (eieio-class-parents (eieio-object-class object)) (length (object-slots object)) )) ) @@ -80,39 +80,39 @@ PREBUTTONTEXT is some text between PREFIX and the object button." ;; Each object should have an opportunity to show stuff about itself. (defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) - prefix) + prefix) "Insert the slots of OBJ into the current DDEBUG buffer." - (data-debug-insert-thing (object-name-string obj) - prefix - "Name: ") - (let* ((cl (object-class obj)) - (cv (class-v cl))) - (data-debug-insert-thing (class-constructor cl) - prefix - "Class: ") - ;; Loop over all the public slots - (let ((publa (aref cv class-public-a)) - (publd (aref cv class-public-d)) - ) - (while publa - (if (slot-boundp obj (car publa)) - (let ((i (class-slot-initarg cl (car publa))) - (v (eieio-oref obj (car publa)))) - (data-debug-insert-thing - v prefix (concat - (if i (symbol-name i) - (symbol-name (car publa))) - " "))) - ;; Unbound case - (let ((i (class-slot-initarg cl (car publa)))) - (data-debug-insert-custom - "#unbound" prefix - (concat (if i (symbol-name i) - (symbol-name (car publa))) - " ") - 'font-lock-keyword-face)) - ) - (setq publa (cdr publa) publd (cdr publd)))))) + (let ((inhibit-read-only t)) + (data-debug-insert-thing (eieio-object-name-string obj) + prefix + "Name: ") + (let* ((cl (eieio-object-class obj)) + (cv (class-v cl))) + (data-debug-insert-thing (class-constructor cl) + prefix + "Class: ") + ;; Loop over all the public slots + (let ((publa (eieio--class-public-a cv)) + ) + (while publa + (if (slot-boundp obj (car publa)) + (let* ((i (class-slot-initarg cl (car publa))) + (v (eieio-oref obj (car publa)))) + (data-debug-insert-thing + v prefix (concat + (if i (symbol-name i) + (symbol-name (car publa))) + " "))) + ;; Unbound case + (let ((i (class-slot-initarg cl (car publa)))) + (data-debug-insert-custom + "#unbound" prefix + (concat (if i (symbol-name i) + (symbol-name (car publa))) + " ") + 'font-lock-keyword-face)) + ) + (setq publa (cdr publa))))))) ;;; Augment the Data debug thing display list. (data-debug-add-specialized-thing (lambda (thing) (object-p thing)) @@ -124,7 +124,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." ;; (defmethod data-debug-show ((obj eieio-default-superclass)) "Run ddebug against any EIEIO object OBJ." - (data-debug-new-buffer (format "*%s DDEBUG*" (object-name obj))) + (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj))) (data-debug-insert-object-slots obj "]")) ;;; DEBUG FUNCTIONS @@ -132,7 +132,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." (defun eieio-debug-methodinvoke (method class) "Show the method invocation order for METHOD with CLASS object." (interactive "aMethod: \nXClass Expression: ") - (let* ((eieio-pre-method-execution-hooks + (let* ((eieio-pre-method-execution-functions (lambda (l) (throw 'moose l) )) (data (catch 'moose (eieio-generic-call diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index a899839f68a..27f97b31ebe 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -1,10 +1,9 @@ ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -;; Copyright (C) 1996, 1998-2003, 2005, 2008-2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1996, 1998-2003, 2005, 2008-2013 Free Software +;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 ;; Keywords: OO, lisp ;; Package: eieio @@ -30,6 +29,9 @@ ;; (require 'eieio) +(require 'find-func) +(require 'speedbar) +(require 'help-mode) ;;; Code: ;;;###autoload @@ -43,7 +45,7 @@ variable `eieio-default-superclass'." nil t))) nil)) (if (not root-class) (setq root-class 'eieio-default-superclass)) - (if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p root-class))) + (eieio--check-type class-p root-class) (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") (erase-buffer) @@ -56,9 +58,9 @@ variable `eieio-default-superclass'." Argument THIS-ROOT is the local root of the tree. Argument PREFIX is the character prefix to use. Argument CH-PREFIX is another character prefix to display." - (if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root))) + (eieio--check-type class-p this-root) (let ((myname (symbol-name this-root)) - (chl (aref (class-v this-root) class-children)) + (chl (eieio--class-children (class-v this-root))) (fprefix (concat ch-prefix " +--")) (mprefix (concat ch-prefix " | ")) (lprefix (concat ch-prefix " "))) @@ -85,14 +87,19 @@ Optional HEADERFCN should be called to insert a few bits of info first." (called-interactively-p 'interactive)) (when headerfcn (funcall headerfcn)) - - (if (class-option class :abstract) - (princ "Abstract ")) - (princ "Class ") (prin1 class) + (princ " is a") + (if (class-option class :abstract) + (princ "n abstract")) + (princ " class") + ;; Print file location + (when (get class 'class-location) + (princ " in `") + (princ (file-name-nondirectory (get class 'class-location))) + (princ "'")) (terpri) ;; Inheritance tree information - (let ((pl (class-parents class))) + (let ((pl (eieio-class-parents class))) (when pl (princ " Inherits from ") (while pl @@ -100,7 +107,7 @@ Optional HEADERFCN should be called to insert a few bits of info first." (setq pl (cdr pl)) (if pl (princ ", "))) (terpri))) - (let ((ch (class-children class))) + (let ((ch (eieio-class-children class))) (when ch (princ " Children ") (while ch @@ -170,13 +177,13 @@ Optional HEADERFCN should be called to insert a few bits of info first." "Describe the slots in CLASS. Outputs to the standard output." (let* ((cv (class-v class)) - (docs (aref cv class-public-doc)) - (names (aref cv class-public-a)) - (deflt (aref cv class-public-d)) - (types (aref cv class-public-type)) - (publp (aref cv class-public-printer)) + (docs (eieio--class-public-doc cv)) + (names (eieio--class-public-a cv)) + (deflt (eieio--class-public-d cv)) + (types (eieio--class-public-type cv)) + (publp (eieio--class-public-printer cv)) (i 0) - (prot (aref cv class-protection)) + (prot (eieio--class-protection cv)) ) (princ "Instance Allocated Slots:") (terpri) @@ -206,11 +213,11 @@ Outputs to the standard output." publp (cdr publp) prot (cdr prot) i (1+ i))) - (setq docs (aref cv class-class-allocation-doc) - names (aref cv class-class-allocation-a) - types (aref cv class-class-allocation-type) + (setq docs (eieio--class-class-allocation-doc cv) + names (eieio--class-class-allocation-a cv) + types (eieio--class-class-allocation-type cv) i 0 - prot (aref cv class-class-allocation-protection)) + prot (eieio--class-class-allocation-protection cv)) (when names (terpri) (princ "Class Allocated Slots:")) @@ -251,8 +258,13 @@ Uses `eieio-describe-class' to describe the class being constructed." (eieio-describe-class fcn (lambda () ;; Describe the constructor part. - (princ "Object Constructor Function: ") (prin1 fcn) + (princ " is an object constructor function") + ;; Print file location + (when (get fcn 'class-location) + (princ " in `") + (princ (file-name-nondirectory (get fcn 'class-location))) + (princ "'")) (terpri) (princ "Creates an object of class ") (prin1 fcn) @@ -262,6 +274,16 @@ Uses `eieio-describe-class' to describe the class being constructed." )) ) +(defun eieio-build-class-list (class) + "Return a list of all classes that inherit from CLASS." + (if (class-p class) + (apply #'append + (mapcar + (lambda (c) + (append (list c) (eieio-build-class-list c))) + (eieio-class-children-fast class))) + (list class))) + (defun eieio-build-class-alist (&optional class instantiable-only buildlist) "Return an alist of all currently active classes for completion purposes. Optional argument CLASS is the class to start with. @@ -269,9 +291,10 @@ If INSTANTIABLE-ONLY is non nil, only allow names of classes which are not abstract, otherwise allow all classes. Optional argument BUILDLIST is more list to attach and is used internally." (let* ((cc (or class eieio-default-superclass)) - (sublst (aref (class-v cc) class-children))) - (if (or (not instantiable-only) (not (class-abstract-p cc))) - (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))) + (sublst (eieio--class-children (class-v cc)))) + (unless (assoc (symbol-name cc) buildlist) + (when (or (not instantiable-only) (not (class-abstract-p cc))) + (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) (while sublst (setq buildlist (eieio-build-class-alist (car sublst) instantiable-only buildlist)) @@ -312,8 +335,7 @@ are not abstract." "Describe the generic function GENERIC. Also extracts information about all methods specific to this generic." (interactive (list (eieio-read-generic "Generic Method: "))) - (if (not (generic-p generic)) - (signal 'wrong-type-argument '(generic-p generic))) + (eieio--check-type generic-p generic) (with-output-to-temp-buffer (help-buffer) ; "*Help*" (help-setup-xref (list #'eieio-describe-generic generic) (called-interactively-p 'interactive)) @@ -342,10 +364,10 @@ Also extracts information about all methods specific to this generic." (princ "Implementations:") (terpri) (terpri) - (let ((i 3) + (let ((i 4) (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) ;; Loop over fanciful generics - (while (< i 6) + (while (< i 7) (let ((gm (aref (get generic 'eieio-method-tree) i))) (when gm (princ "Generic ") @@ -357,8 +379,9 @@ Also extracts information about all methods specific to this generic." (setq i (1+ i))) (setq i 0) ;; Loop over defined class-specific methods - (while (< i 3) - (let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))) + (while (< i 4) + (let ((gm (reverse (aref (get generic 'eieio-method-tree) i))) + location) (while gm (princ "`") (prin1 (car (car gm))) @@ -375,6 +398,13 @@ Also extracts information about all methods specific to this generic." ;; 3 because of cdr (princ (or (documentation (cdr (car gm))) "Undocumented")) + ;; Print file location if available + (when (and (setq location (get generic 'method-locations)) + (setq location (assoc (caar gm) location))) + (setq location (cadr location)) + (princ "\n\nDefined in `") + (princ (file-name-nondirectory location)) + (princ "'\n")) (setq gm (cdr gm)) (terpri) (terpri))) @@ -554,7 +584,65 @@ Optional argument HISTORYVAR is the variable to use as history." ;;; HELP AUGMENTATION ;; -;;;###autoload +(define-button-type 'eieio-method-def + :supertype 'help-xref + 'help-function (lambda (class method file) + (eieio-help-find-method-definition class method file)) + 'help-echo (purecopy "mouse-2, RET: find method's definition")) + +(define-button-type 'eieio-class-def + :supertype 'help-xref + 'help-function (lambda (class file) + (eieio-help-find-class-definition class file)) + 'help-echo (purecopy "mouse-2, RET: find class definition")) + +(defun eieio-help-find-method-definition (class method file) + (let ((filename (find-library-name file)) + location buf) + (when (null filename) + (error "Cannot find library %s" file)) + (setq buf (find-file-noselect filename)) + (with-current-buffer buf + (goto-char (point-min)) + (when + (re-search-forward + ;; Regexp for searching methods. + (concat "(defmethod[ \t\r\n]+" method + "\\([ \t\r\n]+:[a-zA-Z]+\\)?" + "[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+" + class + "\\s-*)") + nil t) + (setq location (match-beginning 0)))) + (if (null location) + (message "Unable to find location in file") + (pop-to-buffer buf) + (goto-char location) + (recenter) + (beginning-of-line)))) + +(defun eieio-help-find-class-definition (class file) + (let ((filename (find-library-name file)) + location buf) + (when (null filename) + (error "Cannot find library %s" file)) + (setq buf (find-file-noselect filename)) + (with-current-buffer buf + (goto-char (point-min)) + (when + (re-search-forward + ;; Regexp for searching a class. + (concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+") + nil t) + (setq location (match-beginning 0)))) + (if (null location) + (message "Unable to find location in file") + (pop-to-buffer buf) + (goto-char location) + (recenter) + (beginning-of-line)))) + + (defun eieio-help-mode-augmentation-maybee (&rest unused) "For buffers thrown into help mode, augment for EIEIO. Arguments UNUSED are not used." @@ -597,14 +685,30 @@ Arguments UNUSED are not used." (goto-char (point-min)) (while (re-search-forward "^\\(Private \\)?Slot:" nil t) (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + (goto-char (point-min)) + (cond + ((looking-at "\\(.+\\) is a generic function") + (let ((mname (match-string 1)) + cname) + (while (re-search-forward "^`\\(.+\\)'[^\0]+?Defined in `\\(.+\\)'" nil t) + (setq cname (match-string-no-properties 1)) + (help-xref-button 2 'eieio-method-def cname + mname + (cadr (assoc (intern cname) + (get (intern mname) + 'method-locations))))))) + ((looking-at "\\(.+\\) is an object constructor function in `\\(.+\\)'") + (let ((cname (match-string-no-properties 1))) + (help-xref-button 2 'eieio-class-def cname + (get (intern cname) 'class-location)))) + ((looking-at "\\(.+\\) is a\\(n abstract\\)? class in `\\(.+\\)'") + (let ((cname (match-string-no-properties 1))) + (help-xref-button 3 'eieio-class-def cname + (get (intern cname) 'class-location))))) )))) ;;; SPEEDBAR SUPPORT ;; -(eval-when-compile - (condition-case nil - (require 'speedbar) - (error (message "Error loading speedbar... ignored")))) (defvar eieio-class-speedbar-key-map nil "Keymap used when working with a project in speedbar.") @@ -652,9 +756,8 @@ current expansion depth." (defun eieio-class-button (class depth) "Draw a speedbar button at the current point for CLASS at DEPTH." - (if (not (class-p class)) - (signal 'wrong-type-argument (list 'class-p class))) - (let ((subclasses (aref (class-v class) class-children))) + (eieio--check-type class-p class) + (let ((subclasses (eieio--class-children (class-v class)))) (if subclasses (speedbar-make-tag-line 'angle ?+ 'eieio-sb-expand @@ -679,7 +782,7 @@ Argument INDENT is the depth of indentation." (speedbar-with-writable (save-excursion (end-of-line) (forward-char 1) - (let ((subclasses (aref (class-v class) class-children))) + (let ((subclasses (eieio--class-children (class-v class)))) (while subclasses (eieio-class-button (car subclasses) (1+ indent)) (setq subclasses (cdr subclasses))))))) @@ -692,14 +795,10 @@ Argument INDENT is the depth of indentation." (defun eieio-describe-class-sb (text token indent) "Describe the class TEXT in TOKEN. INDENT is the current indentation level." - (speedbar-with-attached-buffer + (dframe-with-attached-buffer (eieio-describe-class token)) - (speedbar-maybee-jump-to-attached-frame)) + (dframe-maybee-jump-to-attached-frame)) (provide 'eieio-opt) -;; Local variables: -;; generated-autoload-file: "eieio.el" -;; End: - ;;; eieio-opt.el ends here diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index f169e3f0cd2..e964263754f 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -1,9 +1,9 @@ ;;; eieio-speedbar.el -- Classes for managing speedbar displays. -;; Copyright (C) 1999-2002, 2005, 2007-2012 Free Software Foundation, Inc. +;; Copyright (C) 1999-2002, 2005, 2007-2013 Free Software Foundation, +;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 ;; Keywords: OO, tools ;; Package: eieio @@ -191,23 +191,24 @@ that path." ;;; DEFAULT SUPERCLASS baseline methods ;; -;; First, define methods onto the superclass so all classes -;; will have some minor support. +;; First, define methods with no class defined. These will work as if +;; on the default superclass. Specifying no class will allow these to be used +;; when no other methods are found, allowing multiple inheritance to work +;; reliably with eieio-speedbar. -(defmethod eieio-speedbar-description ((object eieio-default-superclass)) +(defmethod eieio-speedbar-description (object) "Return a string describing OBJECT." - (object-name-string object)) + (eieio-object-name-string object)) -(defmethod eieio-speedbar-derive-line-path ((object eieio-default-superclass)) +(defmethod eieio-speedbar-derive-line-path (object) "Return the path which OBJECT has something to do with." nil) -(defmethod eieio-speedbar-object-buttonname ((object eieio-default-superclass)) +(defmethod eieio-speedbar-object-buttonname (object) "Return a string to use as a speedbar button for OBJECT." - (object-name-string object)) + (eieio-object-name-string object)) -(defmethod eieio-speedbar-make-tag-line ((object eieio-default-superclass) - depth) +(defmethod eieio-speedbar-make-tag-line (object depth) "Insert a tag line into speedbar at point for OBJECT. By default, all objects appear as simple TAGS with no need to inherit from the special `eieio-speedbar' classes. Child classes should redefine this @@ -220,7 +221,7 @@ Argument DEPTH is the depth at which the tag line is inserted." 'speedbar-tag-face depth)) -(defmethod eieio-speedbar-handle-click ((object eieio-default-superclass)) +(defmethod eieio-speedbar-handle-click (object) "Handle a click action on OBJECT in speedbar. Any object can be represented as a tag in SPEEDBAR without special attributes. These default objects will be pulled up in a custom @@ -229,9 +230,9 @@ object edit buffer doing an in-place edit. If your object represents some other item, override this method and take the appropriate action." (require 'eieio-custom) - (speedbar-with-attached-buffer + (dframe-with-attached-buffer (eieio-customize-object object)) - (speedbar-maybee-jump-to-attached-frame)) + (dframe-maybee-jump-to-attached-frame)) ;;; Class definitions @@ -323,7 +324,7 @@ Argument DEPTH is the depth at which the tag line is inserted." (defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth) "Base method for creating tag lines for non-object children." (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" - (object-name object))) + (eieio-object-name object))) (defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) "Expand OBJECT at indentation DEPTH. @@ -364,7 +365,7 @@ TOKEN is the object. INDENT is the current indentation level." (defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) "Return a description for a child of OBJ which is not an object." (error "You must implement `eieio-speedbar-child-description' for %s" - (object-name obj))) + (eieio-object-name obj))) (defun eieio-speedbar-item-info () "Display info for the current line when in EDE display mode." diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 9304f0e3918..3cdf1f078bd 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -1,10 +1,10 @@ ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects ;;; or maybe Eric's Implementation of Emacs Interpreted Objects -;; Copyright (C) 1995-1996, 1998-2012 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2013 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 1.3 +;; Version: 1.4 ;; Keywords: OO, lisp ;; This file is part of GNU Emacs. @@ -46,7 +46,7 @@ (eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! -(defvar eieio-version "1.3" +(defvar eieio-version "1.4" "Current version of EIEIO.") (defun eieio-version () @@ -54,220 +54,7 @@ (interactive) (message eieio-version)) -(eval-and-compile -;; About the above. EIEIO must process its own code when it compiles -;; itself, thus, by eval-and-compiling ourselves, we solve the problem. - -;; Compatibility -(if (fboundp 'compiled-function-arglist) - - ;; XEmacs can only access a compiled functions arglist like this: - (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist) - - ;; Emacs doesn't have this function, but since FUNC is a vector, we can just - ;; grab the appropriate element. - (defun eieio-compiled-function-arglist (func) - "Return the argument list for the compiled function FUNC." - (aref func 0)) - - ) - - -;;; -;; Variable declarations. -;; - -(defvar eieio-hook nil - "This hook is executed, then cleared each time `defclass' is called.") - -(defvar eieio-error-unsupported-class-tags nil - "Non-nil to throw an error if an encountered tag is unsupported. -This may prevent classes from CLOS applications from being used with EIEIO -since EIEIO does not support all CLOS tags.") - -(defvar eieio-skip-typecheck nil - "If non-nil, skip all slot typechecking. -Set this to t permanently if a program is functioning well to get a -small speed increase. This variable is also used internally to handle -default setting for optimization purposes.") - -(defvar eieio-optimize-primary-methods-flag t - "Non-nil means to optimize the method dispatch on primary methods.") - -;; State Variables -;; FIXME: These two constants below should have an `eieio-' prefix added!! -(defvar this nil - "Inside a method, this variable is the object in question. -DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. - -Note: Embedded methods are no longer supported. The variable THIS is -still set for CLOS methods for the sake of routines like -`call-next-method'.") - -(defvar scoped-class nil - "This is set to a class when a method is running. -This is so we know we are allowed to check private parts or how to -execute a `call-next-method'. DO NOT SET THIS YOURSELF!") - -(defvar eieio-initializing-object nil - "Set to non-nil while initializing an object.") - -(defconst eieio-unbound - (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) - eieio-unbound - (make-symbol "unbound")) - "Uninterned symbol representing an unbound slot in an object.") - -;; This is a bootstrap for eieio-default-superclass so it has a value -;; while it is being built itself. -(defvar eieio-default-superclass nil) - -;; FIXME: The constants below should have an `eieio-' prefix added!! -(defconst class-symbol 1 "Class's symbol (self-referencing.).") -(defconst class-parent 2 "Class parent slot.") -(defconst class-children 3 "Class children class slot.") -(defconst class-symbol-obarray 4 "Obarray permitting fast access to variable position indexes.") -;; @todo -;; the word "public" here is leftovers from the very first version. -;; Get rid of it! -(defconst class-public-a 5 "Class attribute index.") -(defconst class-public-d 6 "Class attribute defaults index.") -(defconst class-public-doc 7 "Class documentation strings for attributes.") -(defconst class-public-type 8 "Class type for a slot.") -(defconst class-public-custom 9 "Class custom type for a slot.") -(defconst class-public-custom-label 10 "Class custom group for a slot.") -(defconst class-public-custom-group 11 "Class custom group for a slot.") -(defconst class-public-printer 12 "Printer for a slot.") -(defconst class-protection 13 "Class protection for a slot.") -(defconst class-initarg-tuples 14 "Class initarg tuples list.") -(defconst class-class-allocation-a 15 "Class allocated attributes.") -(defconst class-class-allocation-doc 16 "Class allocated documentation.") -(defconst class-class-allocation-type 17 "Class allocated value type.") -(defconst class-class-allocation-custom 18 "Class allocated custom descriptor.") -(defconst class-class-allocation-custom-label 19 "Class allocated custom descriptor.") -(defconst class-class-allocation-custom-group 20 "Class allocated custom group.") -(defconst class-class-allocation-printer 21 "Class allocated printer for a slot.") -(defconst class-class-allocation-protection 22 "Class allocated protection list.") -(defconst class-class-allocation-values 23 "Class allocated value vector.") -(defconst class-default-object-cache 24 - "Cache index of what a newly created object would look like. -This will speed up instantiation time as only a `copy-sequence' will -be needed, instead of looping over all the values and setting them -from the default.") -(defconst class-options 25 - "Storage location of tagged class options. -Stored outright without modifications or stripping.") - -(defconst class-num-slots 26 - "Number of slots in the class definition object.") - -(defconst object-class 1 "Index in an object vector where the class is stored.") -(defconst object-name 2 "Index in an object where the name is stored.") - -(defconst method-static 0 "Index into :static tag on a method.") -(defconst method-before 1 "Index into :before tag on a method.") -(defconst method-primary 2 "Index into :primary tag on a method.") -(defconst method-after 3 "Index into :after tag on a method.") -(defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") -(defconst method-generic-before 4 "Index into generic :before tag on a method.") -(defconst method-generic-primary 5 "Index into generic :primary tag on a method.") -(defconst method-generic-after 6 "Index into generic :after tag on a method.") -(defconst method-num-slots 7 "Number of indexes into a method's vector.") - -(defsubst eieio-specialized-key-to-generic-key (key) - "Convert a specialized KEY into a generic method key." - (cond ((eq key method-static) 0) ;; don't convert - ((< key method-num-lists) (+ key 3)) ;; The conversion - (t key) ;; already generic.. maybe. - )) - - -;;; Important macros used in eieio. -;; -(defmacro class-v (class) - "Internal: Return the class vector from the CLASS symbol." - ;; No check: If eieio gets this far, it's probably been checked already. - `(get ,class 'eieio-class-definition)) - -(defmacro class-p (class) - "Return t if CLASS is a valid class vector. -CLASS is a symbol." - ;; this new method is faster since it doesn't waste time checking lots of - ;; things. - `(condition-case nil - (eq (aref (class-v ,class) 0) 'defclass) - (error nil))) - -(defmacro eieio-object-p (obj) - "Return non-nil if OBJ is an EIEIO object." - `(condition-case nil - (let ((tobj ,obj)) - (and (eq (aref tobj 0) 'object) - (class-p (aref tobj object-class)))) - (error nil))) -(defalias 'object-p 'eieio-object-p) - -(defmacro class-constructor (class) - "Return the symbol representing the constructor of CLASS." - `(aref (class-v ,class) class-symbol)) - -(defmacro generic-p (method) - "Return t if symbol METHOD is a generic function. -Only methods have the symbol `eieio-method-obarray' as a property -\(which contains a list of all bindings to that method type.)" - `(and (fboundp ,method) (get ,method 'eieio-method-obarray))) - -(defun generic-primary-only-p (method) - "Return t if symbol METHOD is a generic function with only primary methods. -Only methods have the symbol `eieio-method-obarray' as a property (which -contains a list of all bindings to that method type.) -Methods with only primary implementations are executed in an optimized way." - (and (generic-p method) - (let ((M (get method 'eieio-method-tree))) - (and (< 0 (length (aref M method-primary))) - (not (aref M method-static)) - (not (aref M method-before)) - (not (aref M method-after)) - (not (aref M method-generic-before)) - (not (aref M method-generic-primary)) - (not (aref M method-generic-after)))) - )) - -(defun generic-primary-only-one-p (method) - "Return t if symbol METHOD is a generic function with only primary methods. -Only methods have the symbol `eieio-method-obarray' as a property (which -contains a list of all bindings to that method type.) -Methods with only primary implementations are executed in an optimized way." - (and (generic-p method) - (let ((M (get method 'eieio-method-tree))) - (and (= 1 (length (aref M method-primary))) - (not (aref M method-static)) - (not (aref M method-before)) - (not (aref M method-after)) - (not (aref M method-generic-before)) - (not (aref M method-generic-primary)) - (not (aref M method-generic-after)))) - )) - -(defmacro class-option-assoc (list option) - "Return from LIST the found OPTION, or nil if it doesn't exist." - `(car-safe (cdr (memq ,option ,list)))) - -(defmacro class-option (class option) - "Return the value stored for CLASS' OPTION. -Return nil if that option doesn't exist." - `(class-option-assoc (aref (class-v ,class) class-options) ',option)) - -(defmacro class-abstract-p (class) - "Return non-nil if CLASS is abstract. -Abstract classes cannot be instantiated." - `(class-option ,class :abstract)) - -(defmacro class-method-invocation-order (class) - "Return the invocation order of CLASS. -Abstract classes cannot be instantiated." - `(or (class-option ,class :method-invocation-order) - :breadth-first)) +(require 'eieio-core) ;;; Defining a new class @@ -328,793 +115,8 @@ Options in CLOS not supported in EIEIO: Due to the way class options are set up, you can add any tags you wish, and reference them using the function `class-option'." - ;; We must `eval-and-compile' this so that when we byte compile - ;; an eieio program, there is no need to load it ahead of time. - ;; It also provides lots of nice debugging errors at compile time. - `(eval-and-compile - (eieio-defclass ',name ',superclass ',slots ',options-and-doc))) - -(defvar eieio-defclass-autoload-map (make-vector 7 nil) - "Symbol map of superclasses we find in autoloads.") - -;; We autoload this because it's used in `make-autoload'. -;;;###autoload -(defun eieio-defclass-autoload (cname superclasses filename doc) - "Create autoload symbols for the EIEIO class CNAME. -SUPERCLASSES are the superclasses that CNAME inherits from. -DOC is the docstring for CNAME. -This function creates a mock-class for CNAME and adds it into -SUPERCLASSES as children. -It creates an autoload function for CNAME's constructor." - ;; Assume we've already debugged inputs. - - (let* ((oldc (when (class-p cname) (class-v cname))) - (newc (make-vector class-num-slots nil)) - ) - (if oldc - nil ;; Do nothing if we already have this class. - - ;; Create the class in NEWC, but don't fill anything else in. - (aset newc 0 'defclass) - (aset newc class-symbol cname) - - (let ((clear-parent nil)) - ;; No parents? - (when (not superclasses) - (setq superclasses '(eieio-default-superclass) - clear-parent t) - ) - - ;; Hook our new class into the existing structures so we can - ;; autoload it later. - (dolist (SC superclasses) - - - ;; TODO - If we create an autoload that is in the map, that - ;; map needs to be cleared! - - - ;; Does our parent exist? - (if (not (class-p SC)) - - ;; Create a symbol for this parent, and then store this - ;; parent on that symbol. - (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) - (if (not (boundp sym)) - (set sym (list cname)) - (add-to-list sym cname)) - ) - - ;; We have a parent, save the child in there. - (when (not (member cname (aref (class-v SC) class-children))) - (aset (class-v SC) class-children - (cons cname (aref (class-v SC) class-children))))) - - ;; save parent in child - (aset newc class-parent (cons SC (aref newc class-parent))) - ) - - ;; turn this into a usable self-pointing symbol - (set cname cname) - - ;; Store the new class vector definition into the symbol. We need to - ;; do this first so that we can call defmethod for the accessor. - ;; The vector will be updated by the following while loop and will not - ;; need to be stored a second time. - (put cname 'eieio-class-definition newc) - - ;; Clear the parent - (if clear-parent (aset newc class-parent nil)) - - ;; Create an autoload on top of our constructor function. - (autoload cname filename doc nil nil) - (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) - (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) - - )))) - -(defsubst eieio-class-un-autoload (cname) - "If class CNAME is in an autoload state, load its file." - (when (eq (car-safe (symbol-function cname)) 'autoload) - (load-library (car (cdr (symbol-function cname)))))) - -(defun eieio-defclass (cname superclasses slots options-and-doc) - ;; FIXME: Most of this should be moved to the `defclass' macro. - "Define CNAME as a new subclass of SUPERCLASSES. -SLOTS are the slots residing in that class definition, and options or -documentation OPTIONS-AND-DOC is the toplevel documentation for this class. -See `defclass' for more information." - ;; Run our eieio-hook each time, and clear it when we are done. - ;; This way people can add hooks safely if they want to modify eieio - ;; or add definitions when eieio is loaded or something like that. - (run-hooks 'eieio-hook) - (setq eieio-hook nil) - - (if (not (listp superclasses)) - (signal 'wrong-type-argument '(listp superclasses))) - - (let* ((pname superclasses) - (newc (make-vector class-num-slots nil)) - (oldc (when (class-p cname) (class-v cname))) - (groups nil) ;; list of groups id'd from slots - (options nil) - (clearparent nil)) - - (aset newc 0 'defclass) - (aset newc class-symbol cname) - - ;; If this class already existed, and we are updating its structure, - ;; make sure we keep the old child list. This can cause bugs, but - ;; if no new slots are created, it also saves time, and prevents - ;; method table breakage, particularly when the users is only - ;; byte compiling an EIEIO file. - (if oldc - (aset newc class-children (aref oldc class-children)) - ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. - ;; This is like the above, but deals with autoloads nicely. - (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) - (when sym - (condition-case nil - (aset newc class-children (symbol-value sym)) - (error nil)) - (unintern (symbol-name cname) eieio-defclass-autoload-map) - )) - ) - - (cond ((and (stringp (car options-and-doc)) - (/= 1 (% (length options-and-doc) 2))) - (error "Too many arguments to `defclass'")) - ((and (symbolp (car options-and-doc)) - (/= 0 (% (length options-and-doc) 2))) - (error "Too many arguments to `defclass'")) - ) - - (setq options - (if (stringp (car options-and-doc)) - (cons :documentation options-and-doc) - options-and-doc)) - - (if pname - (progn - (while pname - (if (and (car pname) (symbolp (car pname))) - (if (not (class-p (car pname))) - ;; bad class - (error "Given parent class %s is not a class" (car pname)) - ;; good parent class... - ;; save new child in parent - (when (not (member cname (aref (class-v (car pname)) class-children))) - (aset (class-v (car pname)) class-children - (cons cname (aref (class-v (car pname)) class-children)))) - ;; Get custom groups, and store them into our local copy. - (mapc (lambda (g) (add-to-list 'groups g)) - (class-option (car pname) :custom-groups)) - ;; save parent in child - (aset newc class-parent (cons (car pname) (aref newc class-parent)))) - (error "Invalid parent class %s" pname)) - (setq pname (cdr pname))) - ;; Reverse the list of our parents so that they are prioritized in - ;; the same order as specified in the code. - (aset newc class-parent (nreverse (aref newc class-parent))) ) - ;; If there is nothing to loop over, then inherit from the - ;; default superclass. - (unless (eq cname 'eieio-default-superclass) - ;; adopt the default parent here, but clear it later... - (setq clearparent t) - ;; save new child in parent - (if (not (member cname (aref (class-v 'eieio-default-superclass) class-children))) - (aset (class-v 'eieio-default-superclass) class-children - (cons cname (aref (class-v 'eieio-default-superclass) class-children)))) - ;; save parent in child - (aset newc class-parent (list eieio-default-superclass)))) - - ;; turn this into a usable self-pointing symbol - (set cname cname) - - ;; These two tests must be created right away so we can have self- - ;; referencing classes. ei, a class whose slot can contain only - ;; pointers to itself. - - ;; Create the test function - (let ((csym (intern (concat (symbol-name cname) "-p")))) - (fset csym - (list 'lambda (list 'obj) - (format "Test OBJ to see if it an object of type %s" cname) - (list 'and '(eieio-object-p obj) - (list 'same-class-p 'obj cname))))) - - ;; Make sure the method invocation order is a valid value. - (let ((io (class-option-assoc options :method-invocation-order))) - (when (and io (not (member io '(:depth-first :breadth-first :c3)))) - (error "Method invocation order %s is not allowed" io) - )) - - ;; Create a handy child test too - (let ((csym (intern (concat (symbol-name cname) "-child-p")))) - (fset csym - `(lambda (obj) - ,(format - "Test OBJ to see if it an object is a child of type %s" - cname) - (and (eieio-object-p obj) - (object-of-class-p obj ,cname)))) - - ;; When using typep, (typep OBJ 'myclass) returns t for objects which - ;; are subclasses of myclass. For our predicates, however, it is - ;; important for EIEIO to be backwards compatible, where - ;; myobject-p, and myobject-child-p are different. - ;; "cl" uses this technique to specify symbols with specific typep - ;; test, so we can let typep have the CLOS documented behavior - ;; while keeping our above predicate clean. - - ;; It would be cleaner to use `defsetf' here, but that requires cl - ;; at runtime. - (put cname 'cl-deftype-handler - (list 'lambda () `(list 'satisfies (quote ,csym))))) - - ;; Before adding new slots, let's add all the methods and classes - ;; in from the parent class. - (eieio-copy-parents-into-subclass newc superclasses) - - ;; Store the new class vector definition into the symbol. We need to - ;; do this first so that we can call defmethod for the accessor. - ;; The vector will be updated by the following while loop and will not - ;; need to be stored a second time. - (put cname 'eieio-class-definition newc) - - ;; Query each slot in the declaration list and mangle into the - ;; class structure I have defined. - (while slots - (let* ((slot1 (car slots)) - (name (car slot1)) - (slot (cdr slot1)) - (acces (plist-get slot ':accessor)) - (init (or (plist-get slot ':initform) - (if (member ':initform slot) nil - eieio-unbound))) - (initarg (plist-get slot ':initarg)) - (docstr (plist-get slot ':documentation)) - (prot (plist-get slot ':protection)) - (reader (plist-get slot ':reader)) - (writer (plist-get slot ':writer)) - (alloc (plist-get slot ':allocation)) - (type (plist-get slot ':type)) - (custom (plist-get slot ':custom)) - (label (plist-get slot ':label)) - (customg (plist-get slot ':group)) - (printer (plist-get slot ':printer)) - - (skip-nil (class-option-assoc options :allow-nil-initform)) - ) - - (if eieio-error-unsupported-class-tags - (let ((tmp slot)) - (while tmp - (if (not (member (car tmp) '(:accessor - :initform - :initarg - :documentation - :protection - :reader - :writer - :allocation - :type - :custom - :label - :group - :printer - :allow-nil-initform - :custom-groups))) - (signal 'invalid-slot-type (list (car tmp)))) - (setq tmp (cdr (cdr tmp)))))) - - ;; Clean up the meaning of protection. - (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) - ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) - ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) - ((eq prot nil) nil) - (t (signal 'invalid-slot-type (list ':protection prot)))) - - ;; Make sure the :allocation parameter has a valid value. - (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) - (signal 'invalid-slot-type (list ':allocation alloc))) - - ;; The default type specifier is supposed to be t, meaning anything. - (if (not type) (setq type t)) - - ;; Label is nil, or a string - (if (not (or (null label) (stringp label))) - (signal 'invalid-slot-type (list ':label label))) - - ;; Is there an initarg, but allocation of class? - (if (and initarg (eq alloc :class)) - (message "Class allocated slots do not need :initarg")) - - ;; intern the symbol so we can use it blankly - (if initarg (set initarg initarg)) - - ;; The customgroup should be a list of symbols - (cond ((null customg) - (setq customg '(default))) - ((not (listp customg)) - (setq customg (list customg)))) - ;; The customgroup better be a symbol, or list of symbols. - (mapc (lambda (cg) - (if (not (symbolp cg)) - (signal 'invalid-slot-type (list ':group cg)))) - customg) - - ;; First up, add this slot into our new class. - (eieio-add-new-slot newc name init docstr type custom label customg printer - prot initarg alloc 'defaultoverride skip-nil) - - ;; We need to id the group, and store them in a group list attribute. - (mapc (lambda (cg) (add-to-list 'groups cg)) customg) - - ;; Anyone can have an accessor function. This creates a function - ;; of the specified name, and also performs a `defsetf' if applicable - ;; so that users can `setf' the space returned by this function. - (if acces - (progn - (eieio--defmethod - acces (if (eq alloc :class) :static :primary) cname - `(lambda (this) - ,(format - "Retrieves the slot `%s' from an object of class `%s'" - name cname) - (if (slot-boundp this ',name) - (eieio-oref this ',name) - ;; Else - Some error? nil? - nil))) - - (if (fboundp 'gv-define-setter) - ;; FIXME: We should move more of eieio-defclass into the - ;; defclass macro so we don't have to use `eval' and require - ;; `gv' at run-time. - (eval `(gv-define-setter ,acces (eieio--store eieio--object) - (list 'eieio-oset eieio--object '',name - eieio--store))) - ;; Provide a setf method. It would be cleaner to use - ;; defsetf, but that would require CL at runtime. - (put acces 'setf-method - `(lambda (widget) - (let* ((--widget-sym-- (make-symbol "--widget--")) - (--store-sym-- (make-symbol "--store--"))) - (list - (list --widget-sym--) - (list widget) - (list --store-sym--) - (list 'eieio-oset --widget-sym-- '',name - --store-sym--) - (list 'getfoo --widget-sym--)))))))) - - ;; If a writer is defined, then create a generic method of that - ;; name whose purpose is to set the value of the slot. - (if writer - (eieio--defmethod - writer nil cname - `(lambda (this value) - ,(format "Set the slot `%s' of an object of class `%s'" - name cname) - (setf (slot-value this ',name) value)))) - ;; If a reader is defined, then create a generic method - ;; of that name whose purpose is to access this slot value. - (if reader - (eieio--defmethod - reader nil cname - `(lambda (this) - ,(format "Access the slot `%s' from object of class `%s'" - name cname) - (slot-value this ',name)))) - ) - (setq slots (cdr slots))) - - ;; Now that everything has been loaded up, all our lists are backwards! - ;; Fix that up now. - (aset newc class-public-a (nreverse (aref newc class-public-a))) - (aset newc class-public-d (nreverse (aref newc class-public-d))) - (aset newc class-public-doc (nreverse (aref newc class-public-doc))) - (aset newc class-public-type - (apply 'vector (nreverse (aref newc class-public-type)))) - (aset newc class-public-custom (nreverse (aref newc class-public-custom))) - (aset newc class-public-custom-label (nreverse (aref newc class-public-custom-label))) - (aset newc class-public-custom-group (nreverse (aref newc class-public-custom-group))) - (aset newc class-public-printer (nreverse (aref newc class-public-printer))) - (aset newc class-protection (nreverse (aref newc class-protection))) - (aset newc class-initarg-tuples (nreverse (aref newc class-initarg-tuples))) - - ;; The storage for class-class-allocation-type needs to be turned into - ;; a vector now. - (aset newc class-class-allocation-type - (apply 'vector (aref newc class-class-allocation-type))) - - ;; Also, take class allocated values, and vectorize them for speed. - (aset newc class-class-allocation-values - (apply 'vector (aref newc class-class-allocation-values))) - - ;; Attach slot symbols into an obarray, and store the index of - ;; this slot as the variable slot in this new symbol. We need to - ;; know about primes, because obarrays are best set in vectors of - ;; prime number length, and we also need to make our vector small - ;; to save space, and also optimal for the number of items we have. - (let* ((cnt 0) - (pubsyms (aref newc class-public-a)) - (prots (aref newc class-protection)) - (l (length pubsyms)) - (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 - 53 59 61 67 71 73 79 83 89 97 101 ))) - (while (and primes (< (car primes) l)) - (setq primes (cdr primes))) - (car primes))) - (oa (make-vector vl 0)) - (newsym)) - (while pubsyms - (setq newsym (intern (symbol-name (car pubsyms)) oa)) - (set newsym cnt) - (setq cnt (1+ cnt)) - (if (car prots) (put newsym 'protection (car prots))) - (setq pubsyms (cdr pubsyms) - prots (cdr prots))) - (aset newc class-symbol-obarray oa) - ) - - ;; Create the constructor function - (if (class-option-assoc options :abstract) - ;; Abstract classes cannot be instantiated. Say so. - (let ((abs (class-option-assoc options :abstract))) - (if (not (stringp abs)) - (setq abs (format "Class %s is abstract" cname))) - (fset cname - `(lambda (&rest stuff) - ,(format "You cannot create a new object of type %s" cname) - (error ,abs)))) - - ;; Non-abstract classes need a constructor. - (fset cname - `(lambda (newname &rest slots) - ,(format "Create a new object with name NAME of class type %s" cname) - (apply 'constructor ,cname newname slots))) - ) - - ;; Set up a specialized doc string. - ;; Use stored value since it is calculated in a non-trivial way - (put cname 'variable-documentation - (class-option-assoc options :documentation)) - - ;; We have a list of custom groups. Store them into the options. - (let ((g (class-option-assoc options :custom-groups))) - (mapc (lambda (cg) (add-to-list 'g cg)) groups) - (if (memq :custom-groups options) - (setcar (cdr (memq :custom-groups options)) g) - (setq options (cons :custom-groups (cons g options))))) - - ;; Set up the options we have collected. - (aset newc class-options options) - - ;; if this is a superclass, clear out parent (which was set to the - ;; default superclass eieio-default-superclass) - (if clearparent (aset newc class-parent nil)) - - ;; Create the cached default object. - (let ((cache (make-vector (+ (length (aref newc class-public-a)) - 3) nil))) - (aset cache 0 'object) - (aset cache object-class cname) - (aset cache object-name 'default-cache-object) - (let ((eieio-skip-typecheck t)) - ;; All type-checking has been done to our satisfaction - ;; before this call. Don't waste our time in this call.. - (eieio-set-defaults cache t)) - (aset newc class-default-object-cache cache)) - - ;; Return our new class object - ;; newc - cname - )) - -(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) - "For SLOT, signal if SPEC does not match VALUE. -If SKIPNIL is non-nil, then if VALUE is nil return t instead." - (if (and (not (eieio-eval-default-p value)) - (not eieio-skip-typecheck) - (not (and skipnil (null value))) - (not (eieio-perform-slot-validation spec value))) - (signal 'invalid-slot-type (list slot spec value)))) - -(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc - &optional defaultoverride skipnil) - "Add into NEWC attribute A. -If A already exists in NEWC, then do nothing. If it doesn't exist, -then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. -Argument ALLOC specifies if the slot is allocated per instance, or per class. -If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, -we must override its value for a default. -Optional argument SKIPNIL indicates if type checking should be skipped -if default value is nil." - ;; Make sure we duplicate those items that are sequences. - (condition-case nil - (if (sequencep d) (setq d (copy-sequence d))) - ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. - (error nil)) - (if (sequencep type) (setq type (copy-sequence type))) - (if (sequencep cust) (setq cust (copy-sequence cust))) - (if (sequencep custg) (setq custg (copy-sequence custg))) - - ;; To prevent override information w/out specification of storage, - ;; we need to do this little hack. - (if (member a (aref newc class-class-allocation-a)) (setq alloc ':class)) - - (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) - ;; In this case, we modify the INSTANCE version of a given slot. - - (progn + `(eieio-defclass ',name ',superclass ',slots ',options-and-doc)) - ;; Only add this element if it is so-far unique - (if (not (member a (aref newc class-public-a))) - (progn - (eieio-perform-slot-validation-for-default a type d skipnil) - (aset newc class-public-a (cons a (aref newc class-public-a))) - (aset newc class-public-d (cons d (aref newc class-public-d))) - (aset newc class-public-doc (cons doc (aref newc class-public-doc))) - (aset newc class-public-type (cons type (aref newc class-public-type))) - (aset newc class-public-custom (cons cust (aref newc class-public-custom))) - (aset newc class-public-custom-label (cons label (aref newc class-public-custom-label))) - (aset newc class-public-custom-group (cons custg (aref newc class-public-custom-group))) - (aset newc class-public-printer (cons print (aref newc class-public-printer))) - (aset newc class-protection (cons prot (aref newc class-protection))) - (aset newc class-initarg-tuples (cons (cons init a) (aref newc class-initarg-tuples))) - ) - ;; When defaultoverride is true, we are usually adding new local - ;; attributes which must override the default value of any slot - ;; passed in by one of the parent classes. - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (aref newc class-public-a)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np (nthcdr num (aref newc class-public-d)) - nil)) - (tp (if np (nth num (aref newc class-public-type)))) - ) - (if (not np) - (error "EIEIO internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; If we have a repeat, only update the initarg... - (unless (eq d eieio-unbound) - (eieio-perform-slot-validation-for-default a tp d skipnil) - (setcar dp d)) - ;; If we have a new initarg, check for it. - (when init - (let* ((inits (aref newc class-initarg-tuples)) - (inita (rassq a inits))) - ;; Replace the CAR of the associate INITA. - ;;(message "Initarg: %S replace %s" inita init) - (setcar inita init) - )) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - ;; - ;; EML - We used to have (if prot... here, - ;; but a prot of 'nil means public. - ;; - (let ((super-prot (nth num (aref newc class-protection))) - ) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; End original PLN - - ;; PLN Tue Jun 26 11:57:06 2007 : - ;; Do a non redundant combination of ancient custom - ;; groups and new ones. - (when custg - (let* ((groups - (nthcdr num (aref newc class-public-custom-group))) - (list1 (car groups)) - (list2 (if (listp custg) custg (list custg)))) - (if (< (length list1) (length list2)) - (setq list1 (prog1 list2 (setq list2 list1)))) - (dolist (elt list2) - (unless (memq elt list1) - (push elt list1))) - (setcar groups list1))) - ;; End PLN - - ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is - ;; set, simply replaces the old one. - (when cust - ;; (message "Custom type redefined to %s" cust) - (setcar (nthcdr num (aref newc class-public-custom)) cust)) - - ;; If a new label is specified, it simply replaces - ;; the old one. - (when label - ;; (message "Custom label redefined to %s" label) - (setcar (nthcdr num (aref newc class-public-custom-label)) label)) - ;; End PLN - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (aref newc class-public-doc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (aref newc class-public-printer)) print)) - - ))) - )) - - ;; CLASS ALLOCATED SLOTS - (let ((value (eieio-default-eval-maybe d))) - (if (not (member a (aref newc class-class-allocation-a))) - (progn - (eieio-perform-slot-validation-for-default a type value skipnil) - ;; Here we have found a :class version of a slot. This - ;; requires a very different approach. - (aset newc class-class-allocation-a (cons a (aref newc class-class-allocation-a))) - (aset newc class-class-allocation-doc (cons doc (aref newc class-class-allocation-doc))) - (aset newc class-class-allocation-type (cons type (aref newc class-class-allocation-type))) - (aset newc class-class-allocation-custom (cons cust (aref newc class-class-allocation-custom))) - (aset newc class-class-allocation-custom-label (cons label (aref newc class-class-allocation-custom-label))) - (aset newc class-class-allocation-custom-group (cons custg (aref newc class-class-allocation-custom-group))) - (aset newc class-class-allocation-protection (cons prot (aref newc class-class-allocation-protection))) - ;; Default value is stored in the 'values section, since new objects - ;; can't initialize from this element. - (aset newc class-class-allocation-values (cons value (aref newc class-class-allocation-values)))) - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (aref newc class-class-allocation-a)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np - (nthcdr num - (aref newc class-class-allocation-values)) - nil)) - (tp (if np (nth num (aref newc class-class-allocation-type)) - nil))) - (if (not np) - (error "EIEIO internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; EML - Note: the only reason to override a class bound slot - ;; is to change the default, so allow unbound in. - - ;; If we have a repeat, only update the value... - (eieio-perform-slot-validation-for-default a tp value skipnil) - (setcar dp value)) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - (let ((super-prot - (car (nthcdr num (aref newc class-class-allocation-protection))))) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; Do a non redundant combination of ancient custom groups - ;; and new ones. - (when custg - (let* ((groups - (nthcdr num (aref newc class-class-allocation-custom-group))) - (list1 (car groups)) - (list2 (if (listp custg) custg (list custg)))) - (if (< (length list1) (length list2)) - (setq list1 (prog1 list2 (setq list2 list1)))) - (dolist (elt list2) - (unless (memq elt list1) - (push elt list1))) - (setcar groups list1))) - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (aref newc class-class-allocation-doc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (aref newc class-class-allocation-printer)) print)) - - )) - )) - )) - -(defun eieio-copy-parents-into-subclass (newc parents) - "Copy into NEWC the slots of PARENTS. -Follow the rules of not overwriting early parents when applying to -the new child class." - (let ((ps (aref newc class-parent)) - (sn (class-option-assoc (aref newc class-options) - ':allow-nil-initform))) - (while ps - ;; First, duplicate all the slots of the parent. - (let ((pcv (class-v (car ps)))) - (let ((pa (aref pcv class-public-a)) - (pd (aref pcv class-public-d)) - (pdoc (aref pcv class-public-doc)) - (ptype (aref pcv class-public-type)) - (pcust (aref pcv class-public-custom)) - (plabel (aref pcv class-public-custom-label)) - (pcustg (aref pcv class-public-custom-group)) - (printer (aref pcv class-public-printer)) - (pprot (aref pcv class-protection)) - (pinit (aref pcv class-initarg-tuples)) - (i 0)) - (while pa - (eieio-add-new-slot newc - (car pa) (car pd) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) (car-safe (car pinit)) nil nil sn) - ;; Increment each value. - (setq pa (cdr pa) - pd (cdr pd) - pdoc (cdr pdoc) - i (1+ i) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - pinit (cdr pinit)) - )) ;; while/let - ;; Now duplicate all the class alloc slots. - (let ((pa (aref pcv class-class-allocation-a)) - (pdoc (aref pcv class-class-allocation-doc)) - (ptype (aref pcv class-class-allocation-type)) - (pcust (aref pcv class-class-allocation-custom)) - (plabel (aref pcv class-class-allocation-custom-label)) - (pcustg (aref pcv class-class-allocation-custom-group)) - (printer (aref pcv class-class-allocation-printer)) - (pprot (aref pcv class-class-allocation-protection)) - (pval (aref pcv class-class-allocation-values)) - (i 0)) - (while pa - (eieio-add-new-slot newc - (car pa) (aref pval i) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) nil ':class sn) - ;; Increment each value. - (setq pa (cdr pa) - pdoc (cdr pdoc) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - i (1+ i)) - ))) ;; while/let - ;; Loop over each parent class - (setq ps (cdr ps))) - )) ;;; CLOS style implementation of object creators. ;; @@ -1148,17 +150,6 @@ a string." ;;; CLOS methods and generics ;; - -(put 'eieio--defalias 'byte-hunk-handler - #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) -(defun eieio--defalias (name body) - "Like `defalias', but with less side-effects. -More specifically, it has no side-effects at all when the new function -definition is the same (`eq') as the old one." - (unless (and (fboundp name) - (eq (symbol-function name) body)) - (defalias name body))) - (defmacro defgeneric (method args &optional doc-string) "Create a generic function METHOD. DOC-STRING is the base documentation for this class. A generic @@ -1170,113 +161,6 @@ top level documentation to a method." `(eieio--defalias ',method (eieio--defgeneric-init-form ',method ,doc-string))) -(defun eieio--defgeneric-init-form (method doc-string) - "Form to use for the initial definition of a generic." - (cond - ((or (not (fboundp method)) - (eq 'autoload (car-safe (symbol-function method)))) - ;; Make sure the method tables are installed. - (eieiomt-install method) - ;; Construct the actual body of this function. - (eieio-defgeneric-form method doc-string)) - ((generic-p method) (symbol-function method)) ;Leave it as-is. - (t (error "You cannot create a generic/method over an existing symbol: %s" - method)))) - -(defun eieio-defgeneric-form (method doc-string) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD." - `(lambda (&rest local-args) - ,doc-string - (eieio-generic-call (quote ,method) local-args))) - -(defsubst eieio-defgeneric-reset-generic-form (method) - "Setup METHOD to call the generic form." - (let ((doc-string (documentation method))) - (fset method (eieio-defgeneric-form method doc-string)))) - -(defun eieio-defgeneric-form-primary-only (method doc-string) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD." - `(lambda (&rest local-args) - ,doc-string - (eieio-generic-call-primary-only (quote ,method) local-args))) - -(defsubst eieio-defgeneric-reset-generic-form-primary-only (method) - "Setup METHOD to call the generic form." - (let ((doc-string (documentation method))) - (fset method (eieio-defgeneric-form-primary-only method doc-string)))) - -(defun eieio-defgeneric-form-primary-only-one (method doc-string - class - impl - ) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD. -CLASS is the class symbol needed for private method access. -IMPL is the symbol holding the method implementation." - ;; NOTE: I tried out byte compiling this little fcn. Turns out it - ;; is faster to execute this for not byte-compiled. ie, install this, - ;; then measure calls going through here. I wonder why. - (require 'bytecomp) - (let ((byte-compile-warnings nil)) - (byte-compile - `(lambda (&rest local-args) - ,doc-string - ;; This is a cool cheat. Usually we need to look up in the - ;; method table to find out if there is a method or not. We can - ;; instead make that determination at load time when there is - ;; only one method. If the first arg is not a child of the class - ;; of that one implementation, then clearly, there is no method def. - (if (not (eieio-object-p (car local-args))) - ;; Not an object. Just signal. - (signal 'no-method-definition - (list ',method local-args)) - - ;; We do have an object. Make sure it is the right type. - (if ,(if (eq class eieio-default-superclass) - nil ; default superclass means just an obj. Already asked. - `(not (child-of-class-p (aref (car local-args) object-class) - ',class))) - - ;; If not the right kind of object, call no applicable - (apply 'no-applicable-method (car local-args) - ',method local-args) - - ;; It is ok, do the call. - ;; Fill in inter-call variables then evaluate the method. - (let ((scoped-class ',class) - (eieio-generic-call-next-method-list nil) - (eieio-generic-call-key method-primary) - (eieio-generic-call-methodname ',method) - (eieio-generic-call-arglst local-args) - ) - (apply #',impl local-args) - ;;(,impl local-args) - ))))))) - -(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) - "Setup METHOD to call the generic form." - (let* ((doc-string (documentation method)) - (M (get method 'eieio-method-tree)) - (entry (car (aref M method-primary))) - ) - (fset method (eieio-defgeneric-form-primary-only-one - method doc-string - (car entry) - (cdr entry) - )))) - -(defun eieio-unbind-method-implementations (method) - "Make the generic method METHOD have no implementations. -It will leave the original generic function in place, -but remove reference to all implementations of METHOD." - (put method 'eieio-method-tree nil) - (put method 'eieio-method-obarray nil)) - (defmacro defmethod (method &rest args) "Create a new METHOD through `defgeneric' with ARGS. @@ -1317,148 +201,6 @@ Summary: (format "Generically created method `%s'." method))) (eieio--defmethod ',method ',key ',class #',code)))) -(defun eieio--defmethod (method kind argclass code) - "Work part of the `defmethod' macro defining METHOD with ARGS." - (let ((key - ;; find optional keys - (cond ((or (eq ':BEFORE kind) - (eq ':before kind)) - method-before) - ((or (eq ':AFTER kind) - (eq ':after kind)) - method-after) - ((or (eq ':PRIMARY kind) - (eq ':primary kind)) - method-primary) - ((or (eq ':STATIC kind) - (eq ':static kind)) - method-static) - ;; Primary key - (t method-primary)))) - ;; Make sure there is a generic (when called from defclass). - (eieio--defalias - method (eieio--defgeneric-init-form - method (or (documentation code) - (format "Generically created method `%s'." method)))) - ;; create symbol for property to bind to. If the first arg is of - ;; the form (varname vartype) and `vartype' is a class, then - ;; that class will be the type symbol. If not, then it will fall - ;; under the type `primary' which is a non-specific calling of the - ;; function. - (if argclass - (if (not (class-p argclass)) - (error "Unknown class type %s in method parameters" - argclass)) - (if (= key -1) - (signal 'wrong-type-argument (list :static 'non-class-arg))) - ;; generics are higher - (setq key (eieio-specialized-key-to-generic-key key))) - ;; Put this lambda into the symbol so we can find it - (eieiomt-add method code key argclass) - ) - - (when eieio-optimize-primary-methods-flag - ;; Optimizing step: - ;; - ;; If this method, after this setup, only has primary methods, then - ;; we can setup the generic that way. - (if (generic-primary-only-p method) - ;; If there is only one primary method, then we can go one more - ;; optimization step. - (if (generic-primary-only-one-p method) - (eieio-defgeneric-reset-generic-form-primary-only-one method) - (eieio-defgeneric-reset-generic-form-primary-only method)) - (eieio-defgeneric-reset-generic-form method))) - - method) - -;;; Slot type validation - -;; This is a hideous hack for replacing `typep' from cl-macs, to avoid -;; requiring the CL library at run-time. It can be eliminated if/when -;; `typep' is merged into Emacs core. -(defun eieio--typep (val type) - (if (symbolp type) - (cond ((get type 'cl-deftype-handler) - (eieio--typep val (funcall (get type 'cl-deftype-handler)))) - ((eq type t) t) - ((eq type 'null) (null val)) - ((eq type 'atom) (atom val)) - ((eq type 'float) (and (numberp val) (not (integerp val)))) - ((eq type 'real) (numberp val)) - ((eq type 'fixnum) (integerp val)) - ((memq type '(character string-char)) (characterp val)) - (t - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (if (fboundp namep) - (funcall `(lambda () (,namep val))) - (funcall `(lambda () - (,(intern (concat name "-p")) val))))))) - (cond ((get (car type) 'cl-deftype-handler) - (eieio--typep val (apply (get (car type) 'cl-deftype-handler) - (cdr type)))) - ((memq (car type) '(integer float real number)) - (and (eieio--typep val (car type)) - (or (memq (cadr type) '(* nil)) - (if (consp (cadr type)) - (> val (car (cadr type))) - (>= val (cadr type)))) - (or (memq (caddr type) '(* nil)) - (if (consp (car (cddr type))) - (< val (caar (cddr type))) - (<= val (car (cddr type))))))) - ((memq (car type) '(and or not)) - (eval (cons (car type) - (mapcar (lambda (x) - `(eieio--typep (quote ,val) (quote ,x))) - (cdr type))))) - ((memq (car type) '(member member*)) - (memql val (cdr type))) - ((eq (car type) 'satisfies) - (funcall `(lambda () (,(cadr type) val)))) - (t (error "Bad type spec: %s" type))))) - -(defun eieio-perform-slot-validation (spec value) - "Return non-nil if SPEC does not match VALUE." - (or (eq spec t) ; t always passes - (eq value eieio-unbound) ; unbound always passes - (eieio--typep value spec))) - -(defun eieio-validate-slot-value (class slot-idx value slot) - "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. -Checks the :type specifier. -SLOT is the slot that is being checked, and is only used when throwing -an error." - (if eieio-skip-typecheck - nil - ;; Trim off object IDX junk added in for the object index. - (setq slot-idx (- slot-idx 3)) - (let ((st (aref (aref (class-v class) class-public-type) slot-idx))) - (if (not (eieio-perform-slot-validation st value)) - (signal 'invalid-slot-type (list class slot st value)))))) - -(defun eieio-validate-class-slot-value (class slot-idx value slot) - "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. -Checks the :type specifier. -SLOT is the slot that is being checked, and is only used when throwing -an error." - (if eieio-skip-typecheck - nil - (let ((st (aref (aref (class-v class) class-class-allocation-type) - slot-idx))) - (if (not (eieio-perform-slot-validation st value)) - (signal 'invalid-slot-type (list class slot st value)))))) - -(defun eieio-barf-if-slot-unbound (value instance slotname fn) - "Throw a signal if VALUE is a representation of an UNBOUND slot. -INSTANCE is the object being referenced. SLOTNAME is the offending -slot. If the slot is ok, return VALUE. -Argument FN is the function calling this verifier." - (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) - (slot-unbound instance (object-class instance) slotname fn) - value)) - ;;; Get/Set slots in an object. ;; (defmacro oref (obj slot) @@ -1467,31 +209,6 @@ Slot is the name of the slot when created by `defclass' or the label created by the :initarg tag." `(eieio-oref ,obj (quote ,slot))) -(defun eieio-oref (obj slot) - "Return the value in OBJ at SLOT in the object vector." - (if (not (or (eieio-object-p obj) (class-p obj))) - (signal 'wrong-type-argument (list '(or eieio-object-p class-p) obj))) - (if (not (symbolp slot)) - (signal 'wrong-type-argument (list 'symbolp slot))) - (if (class-p obj) (eieio-class-un-autoload obj)) - (let* ((class (if (class-p obj) obj (aref obj object-class))) - (c (eieio-slot-name-index class obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c (eieio-class-slot-name-index class slot)) - ;; Oref that slot. - (aref (aref (class-v class) class-class-allocation-values) c) - ;; The slot-missing method is a cool way of allowing an object author - ;; to intercept missing slot definitions. Since it is also the LAST - ;; thing called in this fn, its return value would be retrieved. - (slot-missing obj slot 'oref) - ;;(signal 'invalid-slot-name (list (object-name obj) slot)) - ) - (if (not (eieio-object-p obj)) - (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) - (defalias 'slot-value 'eieio-oref) (defalias 'set-slot-value 'eieio-oset) @@ -1502,110 +219,6 @@ tag. SLOT can be the slot name, or the tag specified by the :initarg tag in the `defclass' call." `(eieio-oref-default ,obj (quote ,slot))) -(defun eieio-oref-default (obj slot) - "Do the work for the macro `oref-default' with similar parameters. -Fills in OBJ's SLOT with its default value." - (if (not (or (eieio-object-p obj) (class-p obj))) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) - (let* ((cl (if (eieio-object-p obj) (aref obj object-class) obj)) - (c (eieio-slot-name-index cl obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c - (eieio-class-slot-name-index cl slot)) - ;; Oref that slot. - (aref (aref (class-v cl) class-class-allocation-values) - c) - (slot-missing obj slot 'oref-default) - ;;(signal 'invalid-slot-name (list (class-name cl) slot)) - ) - (eieio-barf-if-slot-unbound - (let ((val (nth (- c 3) (aref (class-v cl) class-public-d)))) - (eieio-default-eval-maybe val)) - obj cl 'oref-default)))) - -(defsubst eieio-eval-default-p (val) - "Whether the default value VAL should be evaluated for use." - (and (consp val) (symbolp (car val)) (fboundp (car val)))) - -(defun eieio-default-eval-maybe (val) - "Check VAL, and return what `oref-default' would provide." - (cond - ;; Is it a function call? If so, evaluate it. - ((eieio-eval-default-p val) - (eval val)) - ;;;; check for quoted things, and unquote them - ;;((and (consp val) (eq (car val) 'quote)) - ;; (car (cdr val))) - ;; return it verbatim - (t val))) - -;;; Object Set macros -;; -(defmacro oset (obj slot value) - "Set the value in OBJ for slot SLOT to VALUE. -SLOT is the slot name as specified in `defclass' or the tag created -with in the :initarg slot. VALUE can be any Lisp object." - `(eieio-oset ,obj (quote ,slot) ,value)) - -(defun eieio-oset (obj slot value) - "Do the work for the macro `oset'. -Fills in OBJ's SLOT with VALUE." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) - (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c - (eieio-class-slot-name-index (aref obj object-class) slot)) - ;; Oset that slot. - (progn - (eieio-validate-class-slot-value (object-class-fast obj) c value slot) - (aset (aref (class-v (aref obj object-class)) - class-class-allocation-values) - c value)) - ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value) - ;;(signal 'invalid-slot-name (list (object-name obj) slot)) - ) - (eieio-validate-slot-value (object-class-fast obj) c value slot) - (aset obj c value)))) - -(defmacro oset-default (class slot value) - "Set the default slot in CLASS for SLOT to VALUE. -The default value is usually set with the :initform tag during class -creation. This allows users to change the default behavior of classes -after they are created." - `(eieio-oset-default ,class (quote ,slot) ,value)) - -(defun eieio-oset-default (class slot value) - "Do the work for the macro `oset-default'. -Fills in the default value in CLASS' in SLOT with VALUE." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) - (let* ((scoped-class class) - (c (eieio-slot-name-index class nil slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c (eieio-class-slot-name-index class slot)) - (progn - ;; Oref that slot. - (eieio-validate-class-slot-value class c value slot) - (aset (aref (class-v class) class-class-allocation-values) c - value)) - (signal 'invalid-slot-name (list (class-name class) slot))) - (eieio-validate-slot-value class c value slot) - ;; Set this into the storage for defaults. - (setcar (nthcdr (- c 3) (aref (class-v class) class-public-d)) - value) - ;; Take the value, and put it into our cache object. - (eieio-oset (aref (class-v class) class-default-object-cache) - slot value) - ))) - ;;; Handy CLOS macros ;; (defmacro with-slots (spec-list object &rest body) @@ -1640,215 +253,104 @@ variable name of the same name as the slot." ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. ;; -(defmacro object-class-fast (obj) "Return the class struct defining OBJ with no check." - `(aref ,obj object-class)) +(define-obsolete-function-alias + 'object-class-fast #'eieio--object-class "24.4") -(defun class-name (class) "Return a Lisp like symbol name for CLASS." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, - ;; and I wanted a string. Arg! - (format "#<class %s>" (symbol-name class))) - -(defun object-name (obj &optional extra) +(defun eieio-object-name (obj &optional extra) "Return a Lisp like symbol string for object OBJ. If EXTRA, include that in the string returned to represent the symbol." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (format "#<%s %s%s>" (symbol-name (object-class-fast obj)) - (aref obj object-name) (or extra ""))) - -(defun object-name-string (obj) "Return a string which is OBJ's name." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (aref obj object-name)) - -(defun object-set-name-string (obj name) "Set the string which is OBJ's NAME." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (if (not (stringp name)) (signal 'wrong-type-argument (list 'stringp name))) - (aset obj object-name name)) - -(defun object-class (obj) "Return the class struct defining OBJ." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (object-class-fast obj)) -(defalias 'class-of 'object-class) - -(defun object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (class-name (object-class-fast obj))) - -(defmacro class-parents-fast (class) "Return parent classes to CLASS with no check." - `(aref (class-v ,class) class-parent)) - -(defun class-parents (class) + (eieio--check-type eieio-object-p obj) + (format "#<%s %s%s>" (symbol-name (eieio--object-class obj)) + (eieio--object-name obj) (or extra ""))) +(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") + +(defun eieio-object-name-string (obj) "Return a string which is OBJ's name." + (eieio--check-type eieio-object-p obj) + (eieio--object-name obj)) +(define-obsolete-function-alias + 'object-name-string #'eieio-object-name-string "24.4") + +(defun eieio-object-set-name-string (obj name) + "Set the string which is OBJ's NAME." + (eieio--check-type eieio-object-p obj) + (eieio--check-type stringp name) + (setf (eieio--object-name obj) name)) +(define-obsolete-function-alias + 'object-set-name-string 'eieio-object-set-name-string "24.4") + +(defun eieio-object-class (obj) "Return the class struct defining OBJ." + (eieio--check-type eieio-object-p obj) + (eieio--object-class obj)) +(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") +;; CLOS name, maybe? +(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4") + +(defun eieio-object-class-name (obj) + "Return a Lisp like symbol name for OBJ's class." + (eieio--check-type eieio-object-p obj) + (eieio-class-name (eieio--object-class obj))) +(define-obsolete-function-alias + 'object-class-name 'eieio-object-class-name "24.4") + +(defun eieio-class-parents (class) "Return parent classes to CLASS. (overload of variable). The CLOS function `class-direct-superclasses' is aliased to this function." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (class-parents-fast class)) - -(defmacro class-children-fast (class) "Return child classes to CLASS with no check." - `(aref (class-v ,class) class-children)) - -(defun class-children (class) -"Return child classes to CLASS. + (eieio--check-type class-p class) + (eieio-class-parents-fast class)) +(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") +(defun eieio-class-children (class) + "Return child classes to CLASS. The CLOS function `class-direct-subclasses' is aliased to this function." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (class-children-fast class)) - -(defun eieio-c3-candidate (class remaining-inputs) - "Returns CLASS if it can go in the result now, otherwise nil" - ;; Ensure CLASS is not in any position but the first in any of the - ;; element lists of REMAINING-INPUTS. - (and (not (let ((found nil)) - (while (and remaining-inputs (not found)) - (setq found (member class (cdr (car remaining-inputs))) - remaining-inputs (cdr remaining-inputs))) - found)) - class)) - -(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) - "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. -If a consistent order does not exist, signal an error." - (if (let ((tail remaining-inputs) - (found nil)) - (while (and tail (not found)) - (setq found (car tail) tail (cdr tail))) - (not found)) - ;; If all remaining inputs are empty lists, we are done. - (nreverse reversed-partial-result) - ;; Otherwise, we try to find the next element of the result. This - ;; is achieved by considering the first element of each - ;; (non-empty) input list and accepting a candidate if it is - ;; consistent with the rests of the input lists. - (let* ((found nil) - (tail remaining-inputs) - (next (progn - (while (and tail (not found)) - (setq found (and (car tail) - (eieio-c3-candidate (caar tail) - remaining-inputs)) - tail (cdr tail))) - found))) - (if next - ;; The graph is consistent so far, add NEXT to result and - ;; merge input lists, dropping NEXT from their heads where - ;; applicable. - (eieio-c3-merge-lists - (cons next reversed-partial-result) - (mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) - remaining-inputs)) - ;; The graph is inconsistent, give up - (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) - -(defun eieio-class-precedence-dfs (class) - "Return all parents of CLASS in depth-first order." - (let* ((parents (class-parents-fast class)) - (classes (copy-sequence - (apply #'append - (list class) - (or - (mapcar - (lambda (parent) - (cons parent - (eieio-class-precedence-dfs parent))) - parents) - '((eieio-default-superclass)))))) - (tail classes)) - ;; Remove duplicates. - (while tail - (setcdr tail (delq (car tail) (cdr tail))) - (setq tail (cdr tail))) - classes)) - -(defun eieio-class-precedence-bfs (class) - "Return all parents of CLASS in breadth-first order." - (let ((result) - (queue (or (class-parents-fast class) - '(eieio-default-superclass)))) - (while queue - (let ((head (pop queue))) - (unless (member head result) - (push head result) - (unless (eq head 'eieio-default-superclass) - (setq queue (append queue (or (class-parents-fast head) - '(eieio-default-superclass)))))))) - (cons class (nreverse result))) - ) - -(defun eieio-class-precedence-c3 (class) - "Return all parents of CLASS in c3 order." - (let ((parents (class-parents-fast class))) - (eieio-c3-merge-lists - (list class) - (append - (or - (mapcar - (lambda (x) - (eieio-class-precedence-c3 x)) - parents) - '((eieio-default-superclass))) - (list parents)))) - ) - -(defun class-precedence-list (class) - "Return (transitively closed) list of parents of CLASS. -The order, in which the parents are returned depends on the -method invocation orders of the involved classes." - (if (or (null class) (eq class 'eieio-default-superclass)) - nil - (case (class-method-invocation-order class) - (:depth-first - (eieio-class-precedence-dfs class)) - (:breadth-first - (eieio-class-precedence-bfs class)) - (:c3 - (eieio-class-precedence-c3 class)))) - ) + (eieio--check-type class-p class) + (eieio-class-children-fast class)) +(define-obsolete-function-alias + 'class-children #'eieio-class-children "24.4") ;; Official CLOS functions. -(defalias 'class-direct-superclasses 'class-parents) -(defalias 'class-direct-subclasses 'class-children) - -(defmacro class-parent-fast (class) "Return first parent class to CLASS with no check." - `(car (class-parents-fast ,class))) +(define-obsolete-function-alias + 'class-direct-superclasses #'eieio-class-parents "24.4") +(define-obsolete-function-alias + 'class-direct-subclasses #'eieio-class-children "24.4") -(defmacro class-parent (class) "Return first parent class to CLASS. (overload of variable)." - `(car (class-parents ,class))) - -(defmacro same-class-fast-p (obj class) "Return t if OBJ is of class-type CLASS with no error checking." - `(eq (aref ,obj object-class) ,class)) +(defmacro eieio-class-parent (class) + "Return first parent class to CLASS. (overload of variable)." + `(car (eieio-class-parents ,class))) +(define-obsolete-function-alias 'class-parent #'eieio-class-parent "24.4") (defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (eieio--check-type class-p class) + (eieio--check-type eieio-object-p obj) (same-class-fast-p obj class)) (defun object-of-class-p (obj class) "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (eieio--check-type eieio-object-p obj) ;; class will be checked one layer down - (child-of-class-p (aref obj object-class) class)) + (child-of-class-p (eieio--object-class obj) class)) ;; Backwards compatibility (defalias 'obj-of-class-p 'object-of-class-p) (defun child-of-class-p (child class) "Return non-nil if CHILD class is a subclass of CLASS." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (if (not (class-p child)) (signal 'wrong-type-argument (list 'class-p child))) + (eieio--check-type class-p class) + (eieio--check-type class-p child) (let ((p nil)) (while (and child (not (eq child class))) - (setq p (append p (aref (class-v child) class-parent)) + (setq p (append p (eieio--class-parent (class-v child))) child (car p) p (cdr p))) (if child t))) (defun object-slots (obj) "Return list of slots available in OBJ." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (aref (class-v (object-class-fast obj)) class-public-a)) + (eieio--check-type eieio-object-p obj) + (eieio--class-public-a (class-v (eieio--object-class obj)))) (defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (let ((ia (aref (class-v class) class-initarg-tuples)) + (eieio--check-type class-p class) + (let ((ia (eieio--class-initarg-tuples (class-v class))) (f nil)) (while (and ia (not f)) (if (eq (cdr (car ia)) slot) @@ -1856,6 +358,21 @@ method invocation orders of the involved classes." (setq ia (cdr ia))) f)) +;;; Object Set macros +;; +(defmacro oset (obj slot value) + "Set the value in OBJ for slot SLOT to VALUE. +SLOT is the slot name as specified in `defclass' or the tag created +with in the :initarg slot. VALUE can be any Lisp object." + `(eieio-oset ,obj (quote ,slot) ,value)) + +(defmacro oset-default (class slot value) + "Set the default slot in CLASS for SLOT to VALUE. +The default value is usually set with the :initform tag during class +creation. This allows users to change the default behavior of classes +after they are created." + `(eieio-oset-default ,class (quote ,slot) ,value)) + ;;; CLOS queries into classes and slots ;; (defun slot-boundp (object slot) @@ -1879,12 +396,12 @@ OBJECT can be an instance or a class." (defun slot-exists-p (object-or-class slot) "Return non-nil if OBJECT-OR-CLASS has SLOT." (let ((cv (class-v (cond ((eieio-object-p object-or-class) - (object-class object-or-class)) + (eieio-object-class object-or-class)) ((class-p object-or-class) object-or-class)) ))) - (or (memq slot (aref cv class-public-a)) - (memq slot (aref cv class-class-allocation-a))) + (or (memq slot (eieio--class-public-a cv)) + (memq slot (eieio--class-class-allocation-a cv))) )) (defun find-class (symbol &optional errorp) @@ -1904,7 +421,7 @@ LIST is a list of objects whose slots are searched. Objects in LIST do not need to have a slot named SLOT, nor does SLOT need to be bound. If these errors occur, those objects will be ignored." - (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) + (eieio--check-type listp list) (while (and list (not (condition-case nil ;; This prevents errors for missing slots. (equal key (eieio-oref (car list) slot)) @@ -1916,7 +433,7 @@ be ignored." "Return an association list with the contents of SLOT as the key element. LIST must be a list of objects with SLOT in it. This is useful when you need to do completing read on an object group." - (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) + (eieio--check-type listp list) (let ((assoclist nil)) (while list (setq assoclist (cons (cons (eieio-oref (car list) slot) @@ -1930,7 +447,7 @@ This is useful when you need to do completing read on an object group." LIST must be a list of objects, but those objects do not need to have SLOT in it. If it does not, then that element is left out of the association list." - (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) + (eieio--check-type listp list) (let ((assoclist nil)) (while list (if (slot-exists-p (car list) slot) @@ -1971,337 +488,9 @@ If SLOT is unbound, do nothing." (if (not (slot-boundp object slot)) nil (eieio-oset object slot (delete item (eieio-oref object slot))))) - -;;; EIEIO internal search functions -;; -(defun eieio-slot-originating-class-p (start-class slot) - "Return non-nil if START-CLASS is the first class to define SLOT. -This is for testing if `scoped-class' is the class that defines SLOT -so that we can protect private slots." - (let ((par (class-parents start-class)) - (ret t)) - (if (not par) - t - (while (and par ret) - (if (intern-soft (symbol-name slot) - (aref (class-v (car par)) - class-symbol-obarray)) - (setq ret nil)) - (setq par (cdr par))) - ret))) - -(defun eieio-slot-name-index (class obj slot) - "In CLASS for OBJ find the index of the named SLOT. -The slot is a symbol which is installed in CLASS by the `defclass' -call. OBJ can be nil, but if it is an object, and the slot in question -is protected, access will be allowed if OBJ is a child of the currently -`scoped-class'. -If SLOT is the value created with :initarg instead, -reverse-lookup that name, and recurse with the associated slot value." - ;; Removed checks to outside this call - (let* ((fsym (intern-soft (symbol-name slot) - (aref (class-v class) - class-symbol-obarray))) - (fsi (if (symbolp fsym) (symbol-value fsym) nil))) - (if (integerp fsi) - (cond - ((not (get fsym 'protection)) - (+ 3 fsi)) - ((and (eq (get fsym 'protection) 'protected) - scoped-class - (or (child-of-class-p class scoped-class) - (and (eieio-object-p obj) - (child-of-class-p class (object-class obj))))) - (+ 3 fsi)) - ((and (eq (get fsym 'protection) 'private) - (or (and scoped-class - (eieio-slot-originating-class-p scoped-class slot)) - eieio-initializing-object)) - (+ 3 fsi)) - (t nil)) - (let ((fn (eieio-initarg-to-attribute class slot))) - (if fn (eieio-slot-name-index class obj fn) nil))))) - -(defun eieio-class-slot-name-index (class slot) - "In CLASS find the index of the named SLOT. -The slot is a symbol which is installed in CLASS by the `defclass' -call. If SLOT is the value created with :initarg instead, -reverse-lookup that name, and recurse with the associated slot value." - ;; This will happen less often, and with fewer slots. Do this the - ;; storage cheap way. - (let* ((a (aref (class-v class) class-class-allocation-a)) - (l1 (length a)) - (af (memq slot a)) - (l2 (length af))) - ;; Slot # is length of the total list, minus the remaining list of - ;; the found slot. - (if af (- l1 l2)))) - -;;; CLOS generics internal function handling -;; -(defvar eieio-generic-call-methodname nil - "When using `call-next-method', provides a context on how to do it.") -(defvar eieio-generic-call-arglst nil - "When using `call-next-method', provides a context for parameters.") -(defvar eieio-generic-call-key nil - "When using `call-next-method', provides a context for the current key. -Keys are a number representing :before, :primary, and :after methods.") -(defvar eieio-generic-call-next-method-list nil - "When executing a PRIMARY or STATIC method, track the 'next-method'. -During executions, the list is first generated, then as each next method -is called, the next method is popped off the stack.") - -(defvar eieio-pre-method-execution-hooks nil - "Abnormal hook run just before an EIEIO method is executed. -The hook function must accept one argument, the list of forms -about to be executed.") - -(defun eieio-generic-call (method args) - "Call METHOD with ARGS. -ARGS provides the context on which implementation to use. -This should only be called from a generic function." - ;; We must expand our arguments first as they are always - ;; passed in as quoted symbols - (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) - (eieio-generic-call-methodname method) - (eieio-generic-call-arglst args) - (firstarg nil) - (primarymethodlist nil)) - ;; get a copy - (setq newargs args - firstarg (car newargs)) - ;; Is the class passed in autoloaded? - ;; Since class names are also constructors, they can be autoloaded - ;; via the autoload command. Check for this, and load them in. - ;; It's ok if it doesn't turn out to be a class. Probably want that - ;; function loaded anyway. - (if (and (symbolp firstarg) - (fboundp firstarg) - (listp (symbol-function firstarg)) - (eq 'autoload (car (symbol-function firstarg)))) - (load (nth 1 (symbol-function firstarg)))) - ;; Determine the class to use. - (cond ((eieio-object-p firstarg) - (setq mclass (object-class-fast firstarg))) - ((class-p firstarg) - (setq mclass firstarg)) - ) - ;; Make sure the class is a valid class - ;; mclass can be nil (meaning a generic for should be used. - ;; mclass cannot have a value that is not a class, however. - (when (and (not (null mclass)) (not (class-p mclass))) - (error "Cannot dispatch method %S on class %S" - method mclass) - ) - ;; Now create a list in reverse order of all the calls we have - ;; make in order to successfully do this right. Rules: - ;; 1) Only call generics if scoped-class is not defined - ;; This prevents multiple calls in the case of recursion - ;; 2) Only call static if this is a static method. - ;; 3) Only call specifics if the definition allows for them. - ;; 4) Call in order based on :before, :primary, and :after - (when (eieio-object-p firstarg) - ;; Non-static calls do all this stuff. - - ;; :after methods - (setq tlambdas - (if mclass - (eieiomt-method-list method method-after mclass) - (list (eieio-generic-form method method-after nil))) - ;;(or (and mclass (eieio-generic-form method method-after mclass)) - ;; (eieio-generic-form method method-after nil)) - ) - (setq lambdas (append tlambdas lambdas) - keys (append (make-list (length tlambdas) method-after) keys)) - - ;; :primary methods - (setq tlambdas - (or (and mclass (eieio-generic-form method method-primary mclass)) - (eieio-generic-form method method-primary nil))) - (when tlambdas - (setq lambdas (cons tlambdas lambdas) - keys (cons method-primary keys) - primarymethodlist - (eieiomt-method-list method method-primary mclass))) - - ;; :before methods - (setq tlambdas - (if mclass - (eieiomt-method-list method method-before mclass) - (list (eieio-generic-form method method-before nil))) - ;;(or (and mclass (eieio-generic-form method method-before mclass)) - ;; (eieio-generic-form method method-before nil)) - ) - (setq lambdas (append tlambdas lambdas) - keys (append (make-list (length tlambdas) method-before) keys)) - ) - - (if mclass - ;; For the case of a class, - ;; if there were no methods found, then there could be :static methods. - (when (not lambdas) - (setq tlambdas - (eieio-generic-form method method-static mclass)) - (setq lambdas (cons tlambdas lambdas) - keys (cons method-static keys) - primarymethodlist ;; Re-use even with bad name here - (eieiomt-method-list method method-static mclass))) - ;; For the case of no class (ie - mclass == nil) then there may - ;; be a primary method. - (setq tlambdas - (eieio-generic-form method method-primary nil)) - (when tlambdas - (setq lambdas (cons tlambdas lambdas) - keys (cons method-primary keys) - primarymethodlist - (eieiomt-method-list method method-primary nil))) - ) - - (run-hook-with-args 'eieio-pre-method-execution-hooks - primarymethodlist) - - ;; Now loop through all occurrences forms which we must execute - ;; (which are happily sorted now) and execute them all! - (let ((rval nil) (lastval nil) (rvalever nil) (found nil)) - (while lambdas - (if (car lambdas) - (let* ((scoped-class (cdr (car lambdas))) - (eieio-generic-call-key (car keys)) - (has-return-val - (or (= eieio-generic-call-key method-primary) - (= eieio-generic-call-key method-static))) - (eieio-generic-call-next-method-list - ;; Use the cdr, as the first element is the fcn - ;; we are calling right now. - (when has-return-val (cdr primarymethodlist))) - ) - (setq found t) - ;;(setq rval (apply (car (car lambdas)) newargs)) - (setq lastval (apply (car (car lambdas)) newargs)) - (when has-return-val - (setq rval lastval - rvalever t)) - )) - (setq lambdas (cdr lambdas) - keys (cdr keys))) - (if (not found) - (if (eieio-object-p (car args)) - (setq rval (apply 'no-applicable-method (car args) method args) - rvalever t) - (signal - 'no-method-definition - (list method args)))) - ;; Right Here... it could be that lastval is returned when - ;; rvalever is nil. Is that right? - rval))) - -(defun eieio-generic-call-primary-only (method args) - "Call METHOD with ARGS for methods with only :PRIMARY implementations. -ARGS provides the context on which implementation to use. -This should only be called from a generic function. - -This method is like `eieio-generic-call', but only -implementations in the :PRIMARY slot are queried. After many -years of use, it appears that over 90% of methods in use -have :PRIMARY implementations only. We can therefore optimize -for this common case to improve performance." - ;; We must expand our arguments first as they are always - ;; passed in as quoted symbols - (let ((newargs nil) (mclass nil) (lambdas nil) - (eieio-generic-call-methodname method) - (eieio-generic-call-arglst args) - (firstarg nil) - (primarymethodlist nil) - ) - ;; get a copy - (setq newargs args - firstarg (car newargs)) - - ;; Determine the class to use. - (cond ((eieio-object-p firstarg) - (setq mclass (object-class-fast firstarg))) - ((not firstarg) - (error "Method %s called on nil" method)) - ((not (eieio-object-p firstarg)) - (error "Primary-only method %s called on something not an object" method)) - (t - (error "EIEIO Error: Improperly classified method %s as primary only" - method) - )) - ;; Make sure the class is a valid class - ;; mclass can be nil (meaning a generic for should be used. - ;; mclass cannot have a value that is not a class, however. - (when (null mclass) - (error "Cannot dispatch method %S on class %S" method mclass) - ) - - ;; :primary methods - (setq lambdas (eieio-generic-form method method-primary mclass)) - (setq primarymethodlist ;; Re-use even with bad name here - (eieiomt-method-list method method-primary mclass)) - - ;; Now loop through all occurrences forms which we must execute - ;; (which are happily sorted now) and execute them all! - (let* ((rval nil) (lastval nil) (rvalever nil) - (scoped-class (cdr lambdas)) - (eieio-generic-call-key method-primary) - ;; Use the cdr, as the first element is the fcn - ;; we are calling right now. - (eieio-generic-call-next-method-list (cdr primarymethodlist)) - ) - - (if (or (not lambdas) (not (car lambdas))) - - ;; No methods found for this impl... - (if (eieio-object-p (car args)) - (setq rval (apply 'no-applicable-method (car args) method args) - rvalever t) - (signal - 'no-method-definition - (list method args))) - - ;; Do the regular implementation here. - - (run-hook-with-args 'eieio-pre-method-execution-hooks - lambdas) - - (setq lastval (apply (car lambdas) newargs)) - (setq rval lastval - rvalever t) - ) - ;; Right Here... it could be that lastval is returned when - ;; rvalever is nil. Is that right? - rval))) - -(defun eieiomt-method-list (method key class) - "Return an alist list of methods lambdas. -METHOD is the method name. -KEY represents either :before, or :after methods. -CLASS is the starting class to search from in the method tree. -If CLASS is nil, then an empty list of methods should be returned." - ;; Note: eieiomt - the MT means MethodTree. See more comments below - ;; for the rest of the eieiomt methods. - - ;; Collect lambda expressions stored for the class and its parent - ;; classes. - (let (lambdas) - (dolist (ancestor (class-precedence-list class)) - ;; Lookup the form to use for the PRIMARY object for the next level - (let ((tmpl (eieio-generic-form method key ancestor))) - (when (and tmpl - (or (not lambdas) - ;; This prevents duplicates coming out of the - ;; class method optimizer. Perhaps we should - ;; just not optimize before/afters? - (not (member tmpl lambdas)))) - (push tmpl lambdas)))) - - ;; Return collected lambda. For :after methods, return in current - ;; order (most general class last); Otherwise, reverse order. - (if (eq key method-after) - lambdas - (nreverse lambdas)))) +;;; +;; Method Calling Functions (defun next-method-p () "Return non-nil if there is a next method. @@ -2319,7 +508,7 @@ If REPLACEMENT-ARGS is non-nil, then use them instead of arguments passed in at the top level. Use `next-method-p' to find out if there is a next method to call." - (if (not scoped-class) + (if (not (eieio--scoped-class)) (error "`call-next-method' not called within a class specific method")) (if (and (/= eieio-generic-call-key method-primary) (/= eieio-generic-call-key method-static)) @@ -2333,220 +522,10 @@ Use `next-method-p' to find out if there is a next method to call." (let* ((eieio-generic-call-next-method-list (cdr eieio-generic-call-next-method-list)) (eieio-generic-call-arglst newargs) - (scoped-class (cdr next)) (fcn (car next)) ) - (apply fcn newargs) - )))) - -;;; -;; eieio-method-tree : eieiomt- -;; -;; Stored as eieio-method-tree in property list of a generic method -;; -;; (eieio-method-tree . [BEFORE PRIMARY AFTER -;; genericBEFORE genericPRIMARY genericAFTER]) -;; and -;; (eieio-method-obarray . [BEFORE PRIMARY AFTER -;; genericBEFORE genericPRIMARY genericAFTER]) -;; where the association is a vector. -;; (aref 0 -- all static methods. -;; (aref 1 -- all methods classified as :before -;; (aref 2 -- all methods classified as :primary -;; (aref 3 -- all methods classified as :after -;; (aref 4 -- a generic classified as :before -;; (aref 5 -- a generic classified as :primary -;; (aref 6 -- a generic classified as :after -;; -(defvar eieiomt-optimizing-obarray nil - "While mapping atoms, this contain the obarray being optimized.") - -(defun eieiomt-install (method-name) - "Install the method tree, and obarray onto METHOD-NAME. -Do not do the work if they already exist." - (let ((emtv (get method-name 'eieio-method-tree)) - (emto (get method-name 'eieio-method-obarray))) - (if (or (not emtv) (not emto)) - (progn - (setq emtv (put method-name 'eieio-method-tree - (make-vector method-num-slots nil)) - emto (put method-name 'eieio-method-obarray - (make-vector method-num-slots nil))) - (aset emto 0 (make-vector 11 0)) - (aset emto 1 (make-vector 11 0)) - (aset emto 2 (make-vector 41 0)) - (aset emto 3 (make-vector 11 0)) - )))) - -(defun eieiomt-add (method-name method key class) - "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. -METHOD-NAME is the name created by a call to `defgeneric'. -METHOD are the forms for a given implementation. -KEY is an integer (see comment in eieio.el near this function) which -is associated with the :static :before :primary and :after tags. -It also indicates if CLASS is defined or not. -CLASS is the class this method is associated with." - (if (or (> key method-num-slots) (< key 0)) - (error "eieiomt-add: method key error!")) - (let ((emtv (get method-name 'eieio-method-tree)) - (emto (get method-name 'eieio-method-obarray))) - ;; Make sure the method tables are available. - (if (or (not emtv) (not emto)) - (error "Programmer error: eieiomt-add")) - ;; only add new cells on if it doesn't already exist! - (if (assq class (aref emtv key)) - (setcdr (assq class (aref emtv key)) method) - (aset emtv key (cons (cons class method) (aref emtv key)))) - ;; Add function definition into newly created symbol, and store - ;; said symbol in the correct obarray, otherwise use the - ;; other array to keep this stuff - (if (< key method-num-lists) - (let ((nsym (intern (symbol-name class) (aref emto key)))) - (fset nsym method))) - ;; Now optimize the entire obarray - (if (< key method-num-lists) - (let ((eieiomt-optimizing-obarray (aref emto key))) - ;; @todo - Is this overkill? Should we just clear the symbol? - (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) - )) - -(defun eieiomt-next (class) - "Return the next parent class for CLASS. -If CLASS is a superclass, return variable `eieio-default-superclass'. -If CLASS is variable `eieio-default-superclass' then return nil. -This is different from function `class-parent' as class parent returns -nil for superclasses. This function performs no type checking!" - ;; No type-checking because all calls are made from functions which - ;; are safe and do checking for us. - (or (class-parents-fast class) - (if (eq class 'eieio-default-superclass) - nil - '(eieio-default-superclass)))) - -(defun eieiomt-sym-optimize (s) - "Find the next class above S which has a function body for the optimizer." - ;; Set the value to nil in case there is no nearest cell. - (set s nil) - ;; Find the nearest cell that has a function body. If we find one, - ;; we replace the nil from above. - (let ((external-symbol (intern-soft (symbol-name s)))) - (catch 'done - (dolist (ancestor (rest (class-precedence-list external-symbol))) - (let ((ov (intern-soft (symbol-name ancestor) - eieiomt-optimizing-obarray))) - (when (fboundp ov) - (set s ov) ;; store ov as our next symbol - (throw 'done ancestor))))))) - -(defun eieio-generic-form (method key class) - "Return the lambda form belonging to METHOD using KEY based upon CLASS. -If CLASS is not a class then use `generic' instead. If class has -no form, but has a parent class, then trace to that parent class. -The first time a form is requested from a symbol, an optimized path -is memorized for faster future use." - (let ((emto (aref (get method 'eieio-method-obarray) - (if class key (eieio-specialized-key-to-generic-key key))))) - (if (class-p class) - ;; 1) find our symbol - (let ((cs (intern-soft (symbol-name class) emto))) - (if (not cs) - ;; 2) If there isn't one, then make one. - ;; This can be slow since it only occurs once - (progn - (setq cs (intern (symbol-name class) emto)) - ;; 2.1) Cache its nearest neighbor with a quick optimize - ;; which should only occur once for this call ever - (let ((eieiomt-optimizing-obarray emto)) - (eieiomt-sym-optimize cs)))) - ;; 3) If it's bound return this one. - (if (fboundp cs) - (cons cs (aref (class-v class) class-symbol)) - ;; 4) If it's not bound then this variable knows something - (if (symbol-value cs) - (progn - ;; 4.1) This symbol holds the next class in its value - (setq class (symbol-value cs) - cs (intern-soft (symbol-name class) emto)) - ;; 4.2) The optimizer should always have chosen a - ;; function-symbol - ;;(if (fboundp cs) - (cons cs (aref (class-v (intern (symbol-name class))) - class-symbol)) - ;;(error "EIEIO optimizer: erratic data loss!")) - ) - ;; There never will be a funcall... - nil))) - ;; for a generic call, what is a list, is the function body we want. - (let ((emtl (aref (get method 'eieio-method-tree) - (if class key (eieio-specialized-key-to-generic-key key))))) - (if emtl - ;; The car of EMTL is supposed to be a class, which in this - ;; case is nil, so skip it. - (cons (cdr (car emtl)) nil) - nil))))) - -;;; -;; Way to assign slots based on a list. Used for constructors, or -;; even resetting an object at run-time -;; -(defun eieio-set-defaults (obj &optional set-all) - "Take object OBJ, and reset all slots to their defaults. -If SET-ALL is non-nil, then when a default is nil, that value is -reset. If SET-ALL is nil, the slots are only reset if the default is -not nil." - (let ((scoped-class (aref obj object-class)) - (eieio-initializing-object t) - (pub (aref (class-v (aref obj object-class)) class-public-a))) - (while pub - (let ((df (eieio-oref-default obj (car pub)))) - (if (or df set-all) - (eieio-oset obj (car pub) df))) - (setq pub (cdr pub))))) - -(defun eieio-initarg-to-attribute (class initarg) - "For CLASS, convert INITARG to the actual attribute name. -If there is no translation, pass it in directly (so we can cheat if -need be... May remove that later...)" - (let ((tuple (assoc initarg (aref (class-v class) class-initarg-tuples)))) - (if tuple - (cdr tuple) - nil))) - -(defun eieio-attribute-to-initarg (class attribute) - "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. -This is usually a symbol that starts with `:'." - (let ((tuple (rassoc attribute (aref (class-v class) class-initarg-tuples)))) - (if tuple - (car tuple) - nil))) - - -;;; Here are some special types of errors -;; -(intern "no-method-definition") -(put 'no-method-definition 'error-conditions '(no-method-definition error)) -(put 'no-method-definition 'error-message "No method definition") - -(intern "no-next-method") -(put 'no-next-method 'error-conditions '(no-next-method error)) -(put 'no-next-method 'error-message "No next method") - -(intern "invalid-slot-name") -(put 'invalid-slot-name 'error-conditions '(invalid-slot-name error)) -(put 'invalid-slot-name 'error-message "Invalid slot name") - -(intern "invalid-slot-type") -(put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil)) -(put 'invalid-slot-type 'error-message "Invalid slot type") - -(intern "unbound-slot") -(put 'unbound-slot 'error-conditions '(unbound-slot error nil)) -(put 'unbound-slot 'error-message "Unbound slot") - -(intern "inconsistent-class-hierarchy") -(put 'inconsistent-class-hierarchy 'error-conditions - '(inconsistent-class-hierarchy error nil)) -(put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy") + (eieio--with-scoped-class (cdr next) + (apply fcn newargs)) )))) ;;; Here are some CLOS items that need the CL package ;; @@ -2603,10 +582,9 @@ SLOTS are the initialization slots used by `shared-initialize'. This static method is called when an object is constructed. It allocates the vector used to represent an EIEIO object, and then calls `shared-initialize' on that object." - (let* ((new-object (copy-sequence (aref (class-v class) - class-default-object-cache)))) + (let* ((new-object (copy-sequence (eieio--class-default-object-cache (class-v class))))) ;; Update the name for the newly created object. - (aset new-object object-name newname) + (setf (eieio--object-name new-object) newname) ;; Call the initialize method on the new object with the slots ;; that were passed down to us. (initialize-instance new-object slots) @@ -2620,9 +598,9 @@ Called from the constructor routine.") (defmethod shared-initialize ((obj eieio-default-superclass) slots) "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine." - (let ((scoped-class (aref obj object-class))) + (eieio--with-scoped-class (eieio--object-class obj) (while slots - (let ((rn (eieio-initarg-to-attribute (object-class-fast obj) + (let ((rn (eieio-initarg-to-attribute (eieio--object-class obj) (car slots)))) (if (not rn) (slot-missing obj (car slots) 'oset (car (cdr slots))) @@ -2642,27 +620,27 @@ call `shared-initialize' yourself, or you can call `call-next-method' to have this constructor called automatically. If these steps are not taken, then new objects of your class will not have their values dynamically set from SLOTS." - ;; First, see if any of our defaults are `lambda', and - ;; re-evaluate them and apply the value to our slots. - (let* ((scoped-class (class-v (aref this object-class))) - (slot (aref scoped-class class-public-a)) - (defaults (aref scoped-class class-public-d))) - (while slot - ;; For each slot, see if we need to evaluate it. - ;; - ;; Paul Landes said in an email: - ;; > CL evaluates it if it can, and otherwise, leaves it as - ;; > the quoted thing as you already have. This is by the - ;; > Sonya E. Keene book and other things I've look at on the - ;; > web. - (let ((dflt (eieio-default-eval-maybe (car defaults)))) - (when (not (eq dflt (car defaults))) - (eieio-oset this (car slot) dflt) )) - ;; Next. - (setq slot (cdr slot) - defaults (cdr defaults)))) - ;; Shared initialize will parse our slots for us. - (shared-initialize this slots)) + ;; First, see if any of our defaults are `lambda', and + ;; re-evaluate them and apply the value to our slots. + (let* ((this-class (class-v (eieio--object-class this))) + (slot (eieio--class-public-a this-class)) + (defaults (eieio--class-public-d this-class))) + (while slot + ;; For each slot, see if we need to evaluate it. + ;; + ;; Paul Landes said in an email: + ;; > CL evaluates it if it can, and otherwise, leaves it as + ;; > the quoted thing as you already have. This is by the + ;; > Sonya E. Keene book and other things I've look at on the + ;; > web. + (let ((dflt (eieio-default-eval-maybe (car defaults)))) + (when (not (eq dflt (car defaults))) + (eieio-oset this (car slot) dflt) )) + ;; Next. + (setq slot (cdr slot) + defaults (cdr defaults)))) + ;; Shared initialize will parse our slots for us. + (shared-initialize this slots)) (defgeneric slot-missing (object slot-name operation &optional new-value) "Method invoked when an attempt to access a slot in OBJECT fails.") @@ -2676,7 +654,7 @@ to be set. This method is called from `oref', `oset', and other functions which directly reference slots in EIEIO objects." - (signal 'invalid-slot-name (list (object-name object) + (signal 'invalid-slot-name (list (eieio-object-name object) slot-name))) (defgeneric slot-unbound (object class slot-name fn) @@ -2694,7 +672,7 @@ Use `slot-boundp' to determine if a slot is bound or not. In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but EIEIO can only dispatch on the first argument, so the first two are swapped." - (signal 'unbound-slot (list (class-name class) (object-name object) + (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) slot-name fn))) (defgeneric no-applicable-method (object method &rest args) @@ -2708,7 +686,7 @@ ARGS are the arguments that were passed to METHOD. Implement this for a class to block this signal. The return value becomes the return value of the original method call." - (signal 'no-method-definition (list method (object-name object))) + (signal 'no-method-definition (list method (eieio-object-name object))) ) (defgeneric no-next-method (object &rest args) @@ -2722,8 +700,8 @@ ARGS are the arguments it is called by. This method signals `no-next-method' by default. Override this method to not throw an error, and its return value becomes the return value of `call-next-method'." - (signal 'no-next-method (list (object-name object) args)) -) + (signal 'no-next-method (list (eieio-object-name object) args)) + ) (defgeneric clone (obj &rest params) "Make a copy of OBJ, and then supply PARAMS. @@ -2735,7 +713,7 @@ first and modify the returned object.") (defmethod clone ((obj eieio-default-superclass) &rest params) "Make a copy of OBJ, and then apply PARAMS." (let ((nobj (copy-sequence obj)) - (nm (aref obj object-name)) + (nm (eieio--object-name obj)) (passname (and params (stringp (car params)))) (num 1)) (if params (shared-initialize nobj (if passname (cdr params) params))) @@ -2744,8 +722,8 @@ first and modify the returned object.") (if (string-match "-\\([0-9]+\\)" nm) (setq num (1+ (string-to-number (match-string 1 nm))) nm (substring nm 0 (match-beginning 0)))) - (aset nobj object-name (concat nm "-" (int-to-string num)))) - (aset nobj object-name (car params))) + (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num)))) + (setf (eieio--object-name nobj) (car params))) nobj)) (defgeneric destructor (this &rest params) @@ -2777,7 +755,7 @@ Implement this function and specify STRINGS in a call to `call-next-method' to provide additional summary information. When passing in extra strings from child classes, always remember to prepend a space." - (object-name this (apply 'concat strings))) + (eieio-object-name this (apply 'concat strings))) (defvar eieio-print-depth 0 "When printing, keep track of the current indentation depth.") @@ -2794,11 +772,11 @@ object are discouraged from being written. this object." (when comment (princ ";; Object ") - (princ (object-name-string this)) + (princ (eieio-object-name-string this)) (princ "\n") (princ comment) (princ "\n")) - (let* ((cl (object-class this)) + (let* ((cl (eieio-object-class this)) (cv (class-v cl))) ;; Now output readable lisp to recreate this object ;; It should look like this: @@ -2806,14 +784,14 @@ this object." ;; Each slot's slot is writen using its :writer. (princ (make-string (* eieio-print-depth 2) ? )) (princ "(") - (princ (symbol-name (class-constructor (object-class this)))) - (princ " \"") - (princ (object-name-string this)) - (princ "\"\n") + (princ (symbol-name (class-constructor (eieio-object-class this)))) + (princ " ") + (prin1 (eieio-object-name-string this)) + (princ "\n") ;; Loop over all the public slots - (let ((publa (aref cv class-public-a)) - (publd (aref cv class-public-d)) - (publp (aref cv class-public-printer)) + (let ((publa (eieio--class-public-a cv)) + (publd (eieio--class-public-d cv)) + (publp (eieio--class-public-printer cv)) (eieio-print-depth (1+ eieio-print-depth))) (while publa (when (slot-boundp this (car publa)) @@ -2821,28 +799,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))) + (princ (eieio-class-name thing))) + ((or (keywordp thing) (booleanp thing)) + (prin1 thing)) ((symbolp thing) (princ (concat "'" (symbol-name thing)))) (t (prin1 thing)))) @@ -2853,16 +839,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 ")"))) @@ -2874,116 +860,13 @@ This may create or delete slots, but does not affect the return value of `eq'." (error "EIEIO: `change-class' is unimplemented")) -) - - -;;; Obsolete backward compatibility functions. -;; Needed to run byte-code compiled with the EIEIO of Emacs-23. - -(defun eieio-defmethod (method args) - "Obsolete work part of an old version of the `defmethod' macro." - (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) - ;; find optional keys - (setq key - (cond ((or (eq ':BEFORE (car args)) - (eq ':before (car args))) - (setq args (cdr args)) - method-before) - ((or (eq ':AFTER (car args)) - (eq ':after (car args))) - (setq args (cdr args)) - method-after) - ((or (eq ':PRIMARY (car args)) - (eq ':primary (car args))) - (setq args (cdr args)) - method-primary) - ((or (eq ':STATIC (car args)) - (eq ':static (car args))) - (setq args (cdr args)) - method-static) - ;; Primary key - (t method-primary))) - ;; get body, and fix contents of args to be the arguments of the fn. - (setq body (cdr args) - args (car args)) - (setq loopa args) - ;; Create a fixed version of the arguments - (while loopa - (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) - argfix)) - (setq loopa (cdr loopa))) - ;; make sure there is a generic - (eieio-defgeneric - method - (if (stringp (car body)) - (car body) (format "Generically created method `%s'." method))) - ;; create symbol for property to bind to. If the first arg is of - ;; the form (varname vartype) and `vartype' is a class, then - ;; that class will be the type symbol. If not, then it will fall - ;; under the type `primary' which is a non-specific calling of the - ;; function. - (setq firstarg (car args)) - (if (listp firstarg) - (progn - (setq argclass (nth 1 firstarg)) - (if (not (class-p argclass)) - (error "Unknown class type %s in method parameters" - (nth 1 firstarg)))) - (if (= key -1) - (signal 'wrong-type-argument (list :static 'non-class-arg))) - ;; generics are higher - (setq key (eieio-specialized-key-to-generic-key key))) - ;; Put this lambda into the symbol so we can find it - (if (byte-code-function-p (car-safe body)) - (eieiomt-add method (car-safe body) key argclass) - (eieiomt-add method (append (list 'lambda (reverse argfix)) body) - key argclass)) - ) - - (when eieio-optimize-primary-methods-flag - ;; Optimizing step: - ;; - ;; If this method, after this setup, only has primary methods, then - ;; we can setup the generic that way. - (if (generic-primary-only-p method) - ;; If there is only one primary method, then we can go one more - ;; optimization step. - (if (generic-primary-only-one-p method) - (eieio-defgeneric-reset-generic-form-primary-only-one method) - (eieio-defgeneric-reset-generic-form-primary-only method)) - (eieio-defgeneric-reset-generic-form method))) - - method) -(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") - -(defun eieio-defgeneric (method doc-string) - "Obsolete work part of an old version of the `defgeneric' macro." - (if (and (fboundp method) (not (generic-p method)) - (or (byte-code-function-p (symbol-function method)) - (not (eq 'autoload (car (symbol-function method))))) - ) - (error "You cannot create a generic/method over an existing symbol: %s" - method)) - ;; Don't do this over and over. - (unless (fboundp 'method) - ;; This defun tells emacs where the first definition of this - ;; method is defined. - `(defun ,method nil) - ;; Make sure the method tables are installed. - (eieiomt-install method) - ;; Apply the actual body of this function. - (fset method (eieio-defgeneric-form method doc-string)) - ;; Return the method - 'method)) -(make-obsolete 'eieio-defgeneric nil "24.1") - ;;; Interfacing with edebug ;; (defun eieio-edebug-prin1-to-string (object &optional noescape) "Display EIEIO OBJECT in fancy format. Overrides the edebug default. Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." - (cond ((class-p object) (class-name object)) + (cond ((class-p object) (eieio-class-name object)) ((eieio-object-p object) (object-print object)) ((and (listp object) (or (class-p (car object)) (eieio-object-p (car object)))) @@ -3021,29 +904,6 @@ Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." ) ) -;;; Interfacing with imenu in emacs lisp mode -;; (Only if the expression is defined) -;; -(if (eval-when-compile (boundp 'list-imenu-generic-expression)) -(progn - -(defun eieio-update-lisp-imenu-expression () - "Examine `lisp-imenu-generic-expression' and modify it to find `defmethod'." - (let ((exp lisp-imenu-generic-expression)) - (while exp - ;; it's of the form '( ( title expr indx ) ... ) - (let* ((subcar (cdr (car exp))) - (substr (car subcar))) - (if (and (not (string-match "|method\\\\" substr)) - (string-match "|advice\\\\" substr)) - (setcar subcar - (replace-match "|advice\\|method\\" t t substr 0)))) - (setq exp (cdr exp))))) - -(eieio-update-lisp-imenu-expression) - -)) - ;;; Autoloading some external symbols, and hooking into the help system ;; diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 6e5b8e92fb8..4efbdcb22cb 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -1,6 +1,6 @@ ;;; eldoc.el --- show function arglist or variable docstring in echo area -;; Copyright (C) 1996-2012 Free Software Foundation, Inc. +;; Copyright (C) 1996-2013 Free Software Foundation, Inc. ;; Author: Noah Friedman <friedman@splode.com> ;; Maintainer: friedman@splode.com @@ -146,6 +146,10 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") "Idle time delay currently in use by timer. This is used to determine if `eldoc-idle-delay' is changed by the user.") +(defvar eldoc-message-function 'eldoc-minibuffer-message + "The function used by `eldoc-message' to display messages. +It should receive the same arguments as `message'.") + ;;;###autoload (define-minor-mode eldoc-mode @@ -170,6 +174,20 @@ expression point is on." (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area))) ;;;###autoload +(define-minor-mode eldoc-post-insert-mode nil + :group 'eldoc :lighter (:eval (if eldoc-mode "" + (concat eldoc-minor-mode-string "|i"))) + (setq eldoc-last-message nil) + (let ((prn-info (lambda () + (unless eldoc-mode + (eldoc-print-current-symbol-info))))) + (if eldoc-post-insert-mode + (add-hook 'post-self-insert-hook prn-info nil t) + (remove-hook 'post-self-insert-hook prn-info t)))) + +(add-hook 'eval-expression-minibuffer-setup-hook 'eldoc-post-insert-mode) + +;;;###autoload (defun turn-on-eldoc-mode () "Unequivocally turn on ElDoc mode (see command `eldoc-mode')." (interactive) @@ -180,14 +198,46 @@ expression point is on." (or (and eldoc-timer (memq eldoc-timer timer-idle-list)) (setq eldoc-timer - (run-with-idle-timer eldoc-idle-delay t - 'eldoc-print-current-symbol-info))) + (run-with-idle-timer + eldoc-idle-delay t + (lambda () (and eldoc-mode (eldoc-print-current-symbol-info)))))) ;; If user has changed the idle delay, update the timer. (cond ((not (= eldoc-idle-delay eldoc-current-idle-delay)) (setq eldoc-current-idle-delay eldoc-idle-delay) (timer-set-idle-time eldoc-timer eldoc-idle-delay t)))) +(defvar eldoc-mode-line-string nil) +(put 'eldoc-mode-line-string 'risky-local-variable t) + +(defun eldoc-minibuffer-message (format-string &rest args) + "Display messages in the mode-line when in the minibuffer. +Otherwise work like `message'." + (if (minibufferp) + (progn + (with-current-buffer + (window-buffer + (or (window-in-direction 'above (minibuffer-window)) + (minibuffer-selected-window) + (get-largest-window))) + (unless (and (listp mode-line-format) + (assq 'eldoc-mode-line-string mode-line-format)) + (setq mode-line-format + (list "" '(eldoc-mode-line-string + (" " eldoc-mode-line-string " ")) + mode-line-format)))) + (add-hook 'minibuffer-exit-hook + (lambda () (setq eldoc-mode-line-string nil)) + nil t) + (cond + ((null format-string) + (setq eldoc-mode-line-string nil)) + ((stringp format-string) + (setq eldoc-mode-line-string + (apply 'format format-string args)))) + (force-mode-line-update)) + (apply 'message format-string args))) + (defun eldoc-message (&rest args) (let ((omessage eldoc-last-message)) (setq eldoc-last-message @@ -203,8 +253,9 @@ expression point is on." ;; they are Legion. ;; Emacs way of preventing log messages. (let ((message-log-max nil)) - (cond (eldoc-last-message (message "%s" eldoc-last-message)) - (omessage (message nil))))) + (cond (eldoc-last-message + (funcall eldoc-message-function "%s" eldoc-last-message)) + (omessage (funcall eldoc-message-function nil))))) eldoc-last-message) ;; This function goes on pre-command-hook for XEmacs or when using idle @@ -236,11 +287,7 @@ expression point is on." (defun eldoc-display-message-no-interference-p () (and eldoc-mode (not executing-kbd-macro) - (not (and (boundp 'edebug-active) edebug-active)) - ;; Having this mode operate in an active minibuffer/echo area causes - ;; interference with what's going on there. - (not cursor-in-echo-area) - (not (eq (selected-window) (minibuffer-window))))) + (not (and (boundp 'edebug-active) edebug-active)))) ;;;###autoload @@ -262,7 +309,7 @@ Emacs Lisp mode) that support ElDoc.") (defun eldoc-print-current-symbol-info () (condition-case err - (and (eldoc-display-message-p) + (and (or (eldoc-display-message-p) eldoc-post-insert-mode) (if eldoc-documentation-function (eldoc-message (funcall eldoc-documentation-function)) (let* ((current-symbol (eldoc-current-symbol)) @@ -356,7 +403,8 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." (setq doc (copy-sequence args)) (add-text-properties start end (list 'face argument-face) doc)) (setq doc (eldoc-docstring-format-sym-doc - sym doc 'font-lock-function-name-face)) + sym doc (if (functionp sym) 'font-lock-function-name-face + 'font-lock-keyword-face))) doc))) ;; Return a string containing a brief (one-line) documentation string for diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 2ff0ace9f4c..7998f732f06 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -1,6 +1,6 @@ ;;; elint.el --- Lint Emacs Lisp -;; Copyright (C) 1997, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2001-2013 Free Software Foundation, Inc. ;; Author: Peter Liljenberg <petli@lysator.liu.se> ;; Created: May 1997 diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index b94817cdb02..f1321eb4e6d 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -1,7 +1,7 @@ -;;; elp.el --- Emacs Lisp Profiler +;;; elp.el --- Emacs Lisp Profiler -*- lexical-binding: t -*- -;; Copyright (C) 1994-1995, 1997-1998, 2001-2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1994-1995, 1997-1998, 2001-2013 Free Software +;; Foundation, Inc. ;; Author: Barry A. Warsaw ;; Maintainer: FSF @@ -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 a7916354c91..531e83c1e6a 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -1,24 +1,24 @@ -;;; 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-2012 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2010-2013 Free Software Foundation, Inc. ;; Author: Lennart Borgman (lennart O borgman A gmail O com) ;; Christian Ohler <ohler@gnu.org> ;; This file is part of GNU 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. -;; +;; GNU Emacs 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. + +;; GNU Emacs 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/'. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -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 ad5e20cb8a4..656cb0a6a14 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1,24 +1,24 @@ -;;; ert.el --- Emacs Lisp Regression Testing +;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- -;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. +;; Copyright (C) 2007-2008, 2010-2013 Free Software Foundation, Inc. ;; Author: Christian Ohler <ohler@gnu.org> ;; Keywords: lisp, tools ;; This file is part of GNU 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. -;; +;; GNU Emacs 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. + +;; GNU Emacs 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/'. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -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 @@ -388,16 +389,11 @@ DATA is displayed to the user and should state the reason of the failure." (defun ert--expand-should-1 (whole form inner-expander) "Helper function for the `should' macro and its variants." (let ((form - ;; If `cl-macroexpand' isn't bound, the code that we're - ;; compiling doesn't depend on cl and thus doesn't need an - ;; environment arg for `macroexpand'. - (if (fboundp 'cl-macroexpand) - ;; Suppress warning about run-time call to cl function: we - ;; only call it if it's fboundp. - (with-no-warnings - (cl-macroexpand form (and (boundp 'cl-macro-environment) - cl-macro-environment))) - (macroexpand form)))) + (macroexpand form (cond + ((boundp 'macroexpand-all-environment) + macroexpand-all-environment) + ((boundp 'cl-macro-environment) + cl-macro-environment))))) (cond ((or (atom form) (ert--special-operator-p (car form))) (let ((value (ert--gensym "value-"))) @@ -410,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-")) @@ -451,35 +447,36 @@ 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." + (declare (debug t)) (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." + (declare (debug t)) (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))))) @@ -490,10 +487,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) @@ -512,7 +509,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 @@ -525,6 +522,7 @@ non-nil, the error matches TYPE if it is an element of TYPE. If the error matches, returns (ERROR-SYMBOL . DATA) from the error. If not, or if no error was signaled, abort the test as failed." + (declare (debug t)) (unless type (setq type ''error)) (ert--expand-should `(should-error ,form ,@keys) @@ -560,20 +558,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) @@ -581,7 +580,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))) @@ -593,19 +592,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) @@ -613,12 +612,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) @@ -637,10 +636,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. @@ -648,8 +647,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 @@ -659,21 +658,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. @@ -697,29 +696,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) @@ -734,8 +734,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 @@ -755,18 +755,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 () @@ -779,7 +780,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. @@ -796,33 +797,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 @@ -831,7 +832,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 @@ -839,21 +840,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 @@ -864,39 +865,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 () @@ -934,18 +938,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) @@ -987,32 +991,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." @@ -1053,9 +1057,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 @@ -1083,7 +1087,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) @@ -1093,51 +1097,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) @@ -1146,26 +1150,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))))) @@ -1182,21 +1187,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) @@ -1246,21 +1251,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. @@ -1278,11 +1287,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 @@ -1324,8 +1333,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)) @@ -1349,7 +1358,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 "--") @@ -1361,7 +1370,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")) @@ -1383,9 +1392,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)) @@ -1421,14 +1430,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" @@ -1446,19 +1455,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 @@ -1484,7 +1493,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)))) @@ -1532,7 +1541,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'." @@ -1557,7 +1566,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)))) @@ -1614,11 +1623,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. ;; @@ -1694,7 +1703,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 @@ -1705,12 +1714,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) @@ -1813,7 +1822,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)) @@ -1824,7 +1833,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)) @@ -1850,7 +1859,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") @@ -1908,9 +1917,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))))) @@ -1945,21 +1955,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) @@ -1976,19 +1986,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)) @@ -2020,28 +2030,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'." @@ -2121,15 +2131,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 @@ -2158,11 +2168,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. @@ -2210,7 +2220,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)))) @@ -2282,9 +2292,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)) @@ -2294,7 +2304,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)))) @@ -2303,13 +2313,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 ")) @@ -2350,7 +2360,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)) @@ -2408,13 +2418,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)) @@ -2443,17 +2454,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) @@ -2462,13 +2472,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)))) @@ -2481,7 +2491,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/ewoc.el b/lisp/emacs-lisp/ewoc.el index 5de3da65174..ffd17e5d7af 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -1,6 +1,6 @@ ;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer -*- lexical-binding: t -*- -;; Copyright (C) 1991-2012 Free Software Foundation, Inc. +;; Copyright (C) 1991-2013 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index e1e153d9117..f06ad912bc8 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -1,6 +1,6 @@ ;;; find-func.el --- find the definition of the Emacs Lisp function near point -;; Copyright (C) 1997, 1999, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2013 Free Software Foundation, Inc. ;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp> ;; Maintainer: petersen@kurims.kyoto-u.ac.jp diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el index 39797fb5433..82b3e94bb4d 100644 --- a/lisp/emacs-lisp/find-gc.el +++ b/lisp/emacs-lisp/find-gc.el @@ -1,6 +1,6 @@ ;;; find-gc.el --- detect functions that call the garbage collector -;; Copyright (C) 1992, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. ;; Maintainer: FSF diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index f7d6cdc3b75..6dee2cb48da 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,6 +1,6 @@ ;;; float-sup.el --- define some constants useful for floating point numbers. -;; Copyright (C) 1985-1987, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 2001-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index 80b6122822e..dd5ff0ec694 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -1,6 +1,6 @@ ;;; generic.el --- defining simple major modes with comment and font-lock ;; -;; Copyright (C) 1997, 1999, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2013 Free Software Foundation, Inc. ;; ;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Fri Sep 27 1996 diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el index 859b7d32b9e..d3a43329366 100644 --- a/lisp/emacs-lisp/gulp.el +++ b/lisp/emacs-lisp/gulp.el @@ -1,6 +1,6 @@ ;;; gulp.el --- ask for updates for Lisp packages -;; Copyright (C) 1996, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2013 Free Software Foundation, Inc. ;; Author: Sam Shteingold <shteingd@math.ucla.edu> ;; Maintainer: FSF diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 4caa0a73866..cf090e5e758 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -1,22 +1,25 @@ -;;; gv.el --- Generalized variables -*- lexical-binding: t -*- +;;; gv.el --- generalized variables -*- lexical-binding: t -*- -;; Copyright (C) 2012 Free Software Foundation, Inc. +;; Copyright (C) 2012-2013 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions +;; Package: emacs -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs 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, +;; GNU Emacs 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/>. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -108,7 +111,7 @@ DO must return an Elisp expression." GETTER will be bound to a copyable expression that returns the value of PLACE. SETTER will be bound to a function that takes an expression V and returns -and new expression that sets PLACE to V. +a new expression that sets PLACE to V. BODY should return some Elisp expression E manipulating PLACE via GETTER and SETTER. The returned value will then be an Elisp expression that first evaluates @@ -191,7 +194,7 @@ well for simple place forms. Assignments of VAL to (NAME ARGS...) are expanded by binding the argument forms (VAL ARGS...) according to ARGLIST, then executing BODY, which must return a Lisp form that does the assignment. -The first arg in ARLIST (the one that receives VAL) receives an expression +The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) `(aset ,a ,i ,v))" @@ -206,13 +209,21 @@ to be pure and copyable. Example use: This macro is an easy-to-use substitute for `gv-define-expander' that works well for simple place forms. Assignments of VAL to (NAME ARGS...) are turned into calls of the form (SETTER ARGS... VAL). + If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and -instead the assignment is turned into (prog1 VAL (SETTER ARGS... VAL)) +instead the assignment is turned into something equivalent to + \(let ((temp VAL)) + (SETTER ARGS... temp) + temp) so as to preserve the semantics of `setf'." (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) - (let ((set-call `(cons ',setter (append args (list val))))) `(gv-define-setter ,name (val &rest args) - ,(if fix-return `(list 'prog1 val ,set-call) set-call)))) + ,(if fix-return + `(macroexp-let2 nil v val + `(progn + (,',setter ,@(append args (list v))) + ,v)) + `(cons ',setter (append args (list val)))))) ;;; Typical operations on generalized variables. @@ -225,7 +236,7 @@ For example, (setf (cadr x) y) is equivalent to (setcar (cdr x) y). The return value is the last VAL in the list. \(fn PLACE VAL PLACE VAL ...)" - (declare (debug (gv-place form))) + (declare (debug (&rest [gv-place form]))) (if (and args (null (cddr args))) (let ((place (pop args)) (val (car args))) @@ -266,7 +277,7 @@ The return value is the last VAL in the list. ;;;###autoload (put 'gv-place 'edebug-form-spec 'edebug-match-form) ;; CL did the equivalent of: -;;(gv-define-expand edebug-after (lambda (before index place) place)) +;;(gv-define-macroexpand edebug-after (lambda (before index place) place)) (put 'edebug-after 'gv-expander (lambda (do before index place) @@ -355,7 +366,8 @@ The return value is the last VAL in the list. (put 'if 'gv-expander (lambda (do test then &rest else) - (if (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy))) + (if (or (not lexical-binding) ;The other code requires lexical-binding. + (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))) ;; This duplicates the `do' code, which is a problem if that ;; code is large, but otherwise results in more efficient code. `(if ,test ,(gv-get then do) @@ -373,7 +385,8 @@ The return value is the last VAL in the list. (put 'cond 'gv-expander (lambda (do &rest branches) - (if (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy))) + (if (or (not lexical-binding) ;The other code requires lexical-binding. + (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))) ;; This duplicates the `do' code, which is a problem if that ;; code is large, but otherwise results in more efficient code. `(cond @@ -428,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/helper.el b/lisp/emacs-lisp/helper.el index e10cbdb3b6e..f3b7de521cf 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -1,6 +1,6 @@ ;;; helper.el --- utility help package supporting help in electric modes -;; Copyright (C) 1985, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1985, 2001-2013 Free Software Foundation, Inc. ;; Author: K. Shane Hartman ;; Maintainer: FSF diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index f9a1c5dbf83..f2e691102d4 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,6 +1,7 @@ ;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -;; Copyright (C) 1992, 1994, 1997, 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1994, 1997, 2000-2013 Free Software Foundation, +;; Inc. ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> ;; Maintainer: FSF @@ -208,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 @@ -229,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." @@ -282,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)))) @@ -306,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. @@ -489,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 64aac4b81db..cbd8854e7d6 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1,6 +1,6 @@ ;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands -;; Copyright (C) 1985-1986, 1999-2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: lisp, languages @@ -195,52 +195,43 @@ 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 + lisp-font-lock-keywords-1 + lisp-font-lock-keywords-2) + nil ,keywords-case-insensitive nil nil (font-lock-mark-block-function . mark-defun) (font-lock-syntactic-face-function - . lisp-font-lock-syntactic-face-function)))) + . lisp-font-lock-syntactic-face-function))) + (prog-prettify-install lisp--prettify-symbols-alist)) (defun lisp-outline-level () "Lisp mode `outline-level' function." @@ -249,8 +240,35 @@ 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))) + (set-keymap-parent map prog-mode-map) (define-key map "\e\C-q" 'indent-sexp) (define-key map "\177" 'backward-delete-char-untabify) ;; This gets in the way when viewing a Lisp file in view-mode. As @@ -320,6 +338,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 @@ -363,7 +397,7 @@ font-lock keywords will not be case sensitive." :enable mark-active)) (bindings--define-key menu-map [eval-sexp] '(menu-item "Evaluate Last S-expression" eval-last-sexp - :help "Evaluate sexp before point; print value in minibuffer")) + :help "Evaluate sexp before point; print value in echo area")) (bindings--define-key menu-map [separator-format] menu-bar-separator) (bindings--define-key menu-map [comment-region] '(menu-item "Comment Out Region" comment-region @@ -416,6 +450,9 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") :type 'hook :group 'lisp) +(defconst lisp--prettify-symbols-alist + '(("lambda" . ?λ))) + (define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" "Major mode for editing Lisp code to run in Emacs. Commands: @@ -519,10 +556,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 () @@ -742,7 +778,7 @@ If CHAR is not a character, return nil." (defun eval-last-sexp-1 (eval-last-sexp-arg-internal) - "Evaluate sexp before point; print value in minibuffer. + "Evaluate sexp before point; print value in the echo area. With argument, print output into current buffer." (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) ;; Setup the lexical environment if lexical-binding is enabled. @@ -778,6 +814,7 @@ With argument, print output into current buffer." (defun eval-sexp-add-defvars (exp &optional pos) "Prepend EXP with all the `defvar's that precede it in the buffer. POS specifies the starting position where EXP was found and defaults to point." + (setq exp (macroexpand-all exp)) ;Eager macro-expansion. (if (not lexical-binding) exp (save-excursion @@ -795,7 +832,7 @@ POS specifies the starting position where EXP was found and defaults to point." `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp))))) (defun eval-last-sexp (eval-last-sexp-arg-internal) - "Evaluate sexp before point; print value in minibuffer. + "Evaluate sexp before point; print value in the echo area. Interactively, with prefix argument, print output into current buffer. Truncates long output according to the value of the variables `eval-expression-print-length' and `eval-expression-print-level'. @@ -816,6 +853,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 +869,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,35 +890,21 @@ 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))) (defun eval-defun-2 () "Evaluate defun that point is in or before. -The value is displayed in the minibuffer. +The value is displayed in the echo area. If the current defun is actually a call to `defvar', then reset the variable using the initial value expression even if the variable already has some other value. \(Normally `defvar' does not change the variable's value if it already has a value.\) -With argument, insert value in current buffer after the defun. Return the result of evaluation." ;; FIXME: the print-length/level bindings should only be applied while ;; printing, not while evaluating. @@ -914,11 +943,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. @@ -926,11 +956,11 @@ this command arranges for all errors to enter the debugger. With a prefix argument, instrument the code for Edebug. If acting on a `defun' for FUNCTION, and the function was -instrumented, `Edebug: FUNCTION' is printed in the minibuffer. If not +instrumented, `Edebug: FUNCTION' is printed in the echo area. If not instrumented, just FUNCTION is printed. If not acting on a `defun', the result of evaluation is displayed in -the minibuffer. This display is controlled by the variables +the echo area. This display is controlled by the variables `eval-expression-print-length' and `eval-expression-print-level', which see." (interactive "P") @@ -1148,7 +1178,7 @@ is the buffer position of the start of the containing expression." The function `calculate-lisp-indent' calls this to determine if the arguments of a Lisp function call should be indented specially. -INDENT-POINT is the position where the user typed TAB, or equivalent. +INDENT-POINT is the position at which the line being indented begins. Point is located at the point to indent under (for default indentation); STATE is the `parse-partial-sexp' state for that position. @@ -1412,6 +1442,8 @@ Any non-integer value means do not use a different value of :type '(choice (integer) (const :tag "Use the current `fill-column'" t)) :group 'lisp) +(put 'emacs-lisp-docstring-fill-column 'safe-local-variable + (lambda (x) (or (eq x t) (integerp x)))) (defun lisp-fill-paragraph (&optional justify) "Like \\[fill-paragraph], but handle Emacs Lisp comments and docstrings. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index bcb7fab026b..a31bef2391d 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -1,6 +1,7 @@ -;;; lisp.el --- Lisp editing commands for Emacs +;;; lisp.el --- Lisp editing commands for Emacs -*- lexical-binding:t -*- -;; Copyright (C) 1985-1986, 1994, 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1994, 2000-2013 Free Software Foundation, +;; Inc. ;; Maintainer: FSF ;; Keywords: lisp, languages @@ -45,6 +46,12 @@ This affects `insert-parentheses' and `insert-pair'." :group 'lisp) (defvar forward-sexp-function nil + ;; FIXME: + ;; - for some uses, we may want a "sexp-only" version, which only + ;; jumps over a well-formed sexp, rather than some dwimish thing + ;; like jumping from an "else" back up to its "if". + ;; - for up-list, we could use the "sexp-only" behavior as well + ;; to treat the dwimish halfsexp as a form of "up-list" step. "If non-nil, `forward-sexp' delegates to this function. Should take the same arguments and behave similarly to `forward-sexp'.") @@ -255,9 +262,9 @@ is called as a function to find the defun's beginning." ;; convention, fallback on the old implementation. (wrong-number-of-arguments (if (> arg 0) - (dotimes (i arg) + (dotimes (_ arg) (funcall beginning-of-defun-function)) - (dotimes (i (- arg)) + (dotimes (_ (- arg)) (funcall end-of-defun-function)))))) ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start) @@ -435,7 +442,7 @@ it marks the next defun after the ones already marked." (beginning-of-defun)) (re-search-backward "^\n" (- (point) 1) t))))) -(defun narrow-to-defun (&optional arg) +(defun narrow-to-defun (&optional _arg) "Make text outside current defun invisible. The defun visible is the one that contains point or follows point. Optional ARG is ignored." @@ -617,9 +624,10 @@ character." ;; "Unbalanced parentheses", but those may not be so ;; accurate/helpful, e.g. quotes may actually be ;; mismatched. - (error "Unmatched bracket or quote")))) + (user-error "Unmatched bracket or quote")))) (defun field-complete (table &optional predicate) + (declare (obsolete completion-in-region "24.4")) (let ((minibuffer-completion-table table) (minibuffer-completion-predicate predicate) ;; This made sense for lisp-complete-symbol, but for @@ -644,6 +652,7 @@ considered. If the symbol starts just after an open-parenthesis, only symbols with function definitions are considered. Otherwise, all symbols with function definitions, values or properties are considered." + (declare (obsolete completion-at-point "24.4")) (interactive) (let* ((data (lisp-completion-at-point predicate)) (plist (nthcdr 3 data))) @@ -653,10 +662,96 @@ considered." (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data) (plist-get plist :predicate)))))) - -(defun lisp-completion-at-point (&optional predicate) +(defun lisp--local-variables-1 (vars sexp) + "Return the vars locally bound around the witness, or nil if not found." + (let (res) + (while + (unless + (setq res + (pcase sexp + (`(,(or `let `let*) ,bindings) + (let ((vars vars)) + (when (eq 'let* (car sexp)) + (dolist (binding (cdr (reverse bindings))) + (push (or (car-safe binding) binding) vars))) + (lisp--local-variables-1 + vars (car (cdr-safe (car (last bindings))))))) + (`(,(or `let `let*) ,bindings . ,body) + (let ((vars vars)) + (dolist (binding bindings) + (push (or (car-safe binding) binding) vars)) + (lisp--local-variables-1 vars (car (last body))))) + (`(lambda ,_) (setq sexp nil)) + (`(lambda ,args . ,body) + (lisp--local-variables-1 + (append args vars) (car (last body)))) + (`(condition-case ,_ ,e) (lisp--local-variables-1 vars e)) + (`(condition-case ,v ,_ . ,catches) + (lisp--local-variables-1 + (cons v vars) (cdr (car (last catches))))) + (`(,_ . ,_) + (lisp--local-variables-1 vars (car (last sexp)))) + (`lisp--witness--lisp (or vars '(nil))) + (_ nil))) + (setq sexp (ignore-errors (butlast sexp))))) + res)) + +(defun lisp--local-variables () + "Return a list of locally let-bound variables at point." + (save-excursion + (skip-syntax-backward "w_") + (let* ((ppss (syntax-ppss)) + (txt (buffer-substring-no-properties (or (car (nth 9 ppss)) (point)) + (or (nth 8 ppss) (point)))) + (closer ())) + (dolist (p (nth 9 ppss)) + (push (cdr (syntax-after p)) closer)) + (setq closer (apply #'string closer)) + (let* ((sexp (car (read-from-string + (concat txt "lisp--witness--lisp" closer)))) + (macroexpand-advice (lambda (expander form &rest args) + (condition-case nil + (apply expander form args) + (error form)))) + (sexp + (unwind-protect + (progn + (advice-add 'macroexpand :around macroexpand-advice) + (macroexpand-all sexp)) + (advice-remove 'macroexpand macroexpand-advice))) + (vars (lisp--local-variables-1 nil sexp))) + (delq nil + (mapcar (lambda (var) + (and (symbolp var) + (not (string-match (symbol-name var) "\\`[&_]")) + ;; Eliminate uninterned vars. + (intern-soft var) + var)) + vars)))))) + +(defvar lisp--local-variables-completion-table + ;; Use `defvar' rather than `defconst' since defconst would purecopy this + ;; value, which would doubly fail: it would fail because purecopy can't + ;; handle the recursive bytecode object, and it would fail because it would + ;; move `lastpos' and `lastvars' to pure space where they'd be immutable! + (let ((lastpos nil) (lastvars nil)) + (letrec ((hookfun (lambda () + (setq lastpos nil) + (remove-hook 'post-command-hook hookfun)))) + (completion-table-dynamic + (lambda (_string) + (save-excursion + (skip-syntax-backward "_w") + (let ((newpos (cons (point) (current-buffer)))) + (unless (equal lastpos newpos) + (add-hook 'post-command-hook hookfun) + (setq lastpos newpos) + (setq lastvars + (mapcar #'symbol-name (lisp--local-variables)))))) + lastvars))))) + +(defun lisp-completion-at-point (&optional _predicate) "Function used for `completion-at-point-functions' in `emacs-lisp-mode'." - ;; FIXME: the `end' could be after point? (with-syntax-table emacs-lisp-mode-syntax-table (let* ((pos (point)) (beg (condition-case nil @@ -665,25 +760,6 @@ considered." (skip-syntax-forward "'") (point)) (scan-error pos))) - (predicate - (or predicate - (save-excursion - (goto-char beg) - (if (not (eq (char-before) ?\()) - (lambda (sym) ;why not just nil ? -sm - (or (boundp sym) (fboundp sym) - (symbol-plist sym))) - ;; Looks like a funcall position. Let's double check. - (if (condition-case nil - (progn (up-list -2) (forward-char 1) - (eq (char-after) ?\()) - (error nil)) - ;; If the first element of the parent list is an open - ;; paren we are probably not in a funcall position. - ;; Maybe a `let' varlist or something. - nil - ;; Else, we assume that a function name is expected. - 'fboundp))))) (end (unless (or (eq beg (point-max)) (member (char-syntax (char-after beg)) '(?\" ?\( ?\)))) @@ -693,12 +769,57 @@ considered." (forward-sexp 1) (when (>= (point) pos) (point))) - (scan-error pos))))) + (scan-error pos)))) + (funpos (eq (char-before beg) ?\()) ;t if in function position. + (table-etc + (if (not funpos) + ;; FIXME: We could look at the first element of the list and + ;; use it to provide a more specific completion table in some + ;; cases. E.g. filter out keywords that are not understood by + ;; the macro/function being called. + (list nil (completion-table-in-turn + lisp--local-variables-completion-table + obarray) ;Could be anything. + :annotation-function + (lambda (str) (if (fboundp (intern-soft str)) " <f>"))) + ;; Looks like a funcall position. Let's double check. + (save-excursion + (goto-char (1- beg)) + (let ((parent + (condition-case nil + (progn (up-list -1) (forward-char 1) + (let ((c (char-after))) + (if (eq c ?\() ?\( + (if (memq (char-syntax c) '(?w ?_)) + (read (current-buffer)))))) + (error nil)))) + (pcase parent + ;; FIXME: Rather than hardcode special cases here, + ;; we should use something like a symbol-property. + (`declare + (list t (mapcar (lambda (x) (symbol-name (car x))) + (delete-dups + (append + macro-declarations-alist + defun-declarations-alist))))) + ((and (or `condition-case `condition-case-unless-debug) + (guard (save-excursion + (ignore-errors + (forward-sexp 2) + (< (point) beg))))) + (list t obarray + :predicate (lambda (sym) (get sym 'error-conditions)))) + (_ (list nil obarray #'fboundp)))))))) (when end - (list beg end obarray - :predicate predicate - :annotation-function - (unless (eq predicate 'fboundp) - (lambda (str) (if (fboundp (intern-soft str)) " <f>")))))))) + (let ((tail (if (null (car table-etc)) + (cdr table-etc) + (cons + (if (memq (char-syntax (or (char-after end) ?\s)) + '(?\s ?>)) + (cadr table-etc) + (apply-partially 'completion-table-with-terminator + " " (cadr table-etc))) + (cddr table-etc))))) + `(,beg ,end ,@tail)))))) ;;; lisp.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 394225d697e..e8b513fcd3e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,6 +1,6 @@ ;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*- ;; -;; Copyright (C) 2004-2012 Free Software Foundation, Inc. +;; Copyright (C) 2004-2013 Free Software Foundation, Inc. ;; ;; Author: Miles Bader <miles@gnu.org> ;; Keywords: lisp, compiler, macros @@ -100,17 +100,50 @@ each clause." (error (message "Compiler-macro error for %S: %S" (car form) err) form))) -(defun macroexp--eval-if-compile (&rest _forms) +(defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. The purpose is to delay warnings to bytecomp.el, so they can use things like `byte-compile-log-warning' to get better file-and-line-number data and also to avoid outputting the warning during normal execution." nil) -(put 'macroexp--eval-if-compile 'byte-compile +(put 'macroexp--funcall-if-compiled 'byte-compile (lambda (form) - (mapc (lambda (x) (funcall (eval x))) (cdr form)) + (funcall (eval (cadr form))) (byte-compile-constant nil))) +(defun macroexp--compiling-p () + "Return non-nil if we're macroexpanding for the compiler." + ;; FIXME: ¡¡Major Ugly Hack!! To determine whether the output of this + ;; macro-expansion will be processed by the byte-compiler, we check + ;; circumstantial evidence. + (member '(declare-function . byte-compile-macroexpand-declare-function) + macroexpand-all-environment)) + + +(defun macroexp--warn-and-return (msg form) + (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) + (cond + ((null msg) form) + ((macroexp--compiling-p) + `(progn + (macroexp--funcall-if-compiled ',when-compiled) + ,form)) + (t + (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) + (let ((instead (car obsolescence-data)) + (asof (nth 2 obsolescence-data))) + (format "`%s' is an obsolete %s%s%s" fun type + (if asof (concat " (as of " asof ")") "") + (cond ((stringp instead) (concat "; " instead)) + (instead (format "; use `%s' instead." instead)) + (t "."))))) + (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. @@ -129,10 +162,17 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (and (not (eq form new-form)) ;It was a macro call. (car-safe form) (symbolp (car form)) - (get (car form) 'byte-obsolete-info)) - `(progn (macroexp--eval-if-compile - (lambda () (byte-compile-warn-obsolete ',(car form)))) - ,new-form) + (get (car form) 'byte-obsolete-info) + (or (not (fboundp 'byte-compile-warning-enabled-p)) + (byte-compile-warning-enabled-p 'obsolete))) + (let* ((fun (car form)) + (obsolete (get fun 'byte-obsolete-info))) + (macroexp--warn-and-return + (macroexp--obsolete-warning + fun obsolete + (if (symbolp (symbol-function fun)) + "alias" "macro")) + new-form)) new-form))) (pcase form (`(cond . ,clauses) @@ -175,26 +215,16 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; First arg is a function: (`(,(and fun (or `funcall `apply `mapcar `mapatoms `mapconcat `mapc)) ',(and f `(lambda . ,_)) . ,args) - (byte-compile-log-warning + (macroexp--warn-and-return (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) - t) - ;; We don't use `macroexp--cons' since there's clearly a change. - (cons fun - (cons (macroexp--expand-all (list 'function f)) - (macroexp--all-forms args)))) + (macroexp--expand-all `(,fun ,f . ,args)))) ;; Second arg is a function: (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) - (byte-compile-log-warning + (macroexp--warn-and-return (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) - t) - ;; We don't use `macroexp--cons' since there's clearly a change. - (cons fun - (cons (macroexp--expand-all arg1) - (cons (macroexp--expand-all - (list 'function f)) - (macroexp--all-forms args))))) + (macroexp--expand-all `(,fun ,arg1 ,f . ,args)))) (`(,func . ,_) ;; Macro expand compiler macros. This cannot be delayed to ;; byte-optimize-form because the output of the compiler-macro can diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 289751f4944..13202a9ce4d 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -1,6 +1,6 @@ ;;; map-ynp.el --- general-purpose boolean question-asker -;; Copyright (C) 1991-1995, 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 1991-1995, 2000-2013 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Maintainer: FSF diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el new file mode 100644 index 00000000000..c08d671e7eb --- /dev/null +++ b/lisp/emacs-lisp/nadvice.el @@ -0,0 +1,468 @@ +;;; 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 and 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) + (:override "\300\301\"\207" 4) + (: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) + (:filter-args "\300\302\301!\"\207" 5) + (:filter-return "\301\300\302\"!\207" 5)) + "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 name definition) + (let ((found nil)) + (while (and (not found) (advice--p definition)) + (if (or (equal function (advice--car definition)) + (when name + (equal name (cdr (assq 'name (advice--props definition)))))) + (setq found definition) + (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: + ;; - 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)) +`:override' (lambda (&rest r) (apply FUNCTION 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))) +`:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r))) +`:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN 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. + +If PLACE is a simple variable, only its global value will be affected. +Use (local 'VAR) if you want to apply FUNCTION to VAR buffer-locally. + +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) + (setq place `(default-value ',place)))) + `(advice--add-function ,where (gv-ref ,place) ,function ,props)) + +;;;###autoload +(defun advice--add-function (where ref function props) + (let ((a (advice--member-p function (cdr (assq 'name props)) + (gv-deref ref)))) + (when a + ;; The advice is already present. Remove the old one, first. + (setf (gv-deref ref) + (advice--remove-function (gv-deref ref) (advice--car a)))) + (setf (gv-deref ref) + (advice--make where function (gv-deref ref) props)))) + +;;;###autoload +(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 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-x.el b/lisp/emacs-lisp/package-x.el index 761d27a2e28..a3ce1672a63 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -1,6 +1,6 @@ ;;; package-x.el --- Package extras -;; Copyright (C) 2007-2012 Free Software Foundation, Inc. +;; Copyright (C) 2007-2013 Free Software Foundation, Inc. ;; Author: Tom Tromey <tromey@redhat.com> ;; Created: 10 Mar 2007 @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs 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, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -21,9 +21,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index b01cdbc7b8e..41b635bbe30 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1,18 +1,19 @@ ;;; package.el --- Simple package system for Emacs -;; Copyright (C) 2007-2012 Free Software Foundation, Inc. +;; Copyright (C) 2007-2013 Free Software Foundation, Inc. ;; Author: Tom Tromey <tromey@redhat.com> ;; Created: 10 Mar 2007 -;; Version: 1.0 +;; Version: 1.0.1 ;; Keywords: tools +;; Package-Requires: ((tabulated-list "1.0")) ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs 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, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -20,9 +21,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Change Log: @@ -236,11 +235,28 @@ a package can run arbitrary code." :group 'package :version "24.1") +(defcustom package-pinned-packages nil + "An alist of packages that are pinned to a specific archive + +Each element has the form (SYM . ID). + SYM is a package, as a symbol. + ID is an archive name, as a string. This should correspond to an + entry in `package-archives'. + +If the archive of name ID does not contain the package SYM, no +other location will be considered, which will make the +package unavailable." + :type '(alist :key-type (symbol :tag "Package") + :value-type (string :tag "Archive name")) + :risky t + :group 'package + :version "24.4") + (defconst package-archive-version 1 "Version number of the package archive understood by this file. Lower version numbers than this will probably be understood as well.") -(defconst package-el-version "1.0" +(defconst package-el-version "1.0.1" "Version of package.el.") ;; We don't prime the cache since it tends to get out of date. @@ -573,7 +589,8 @@ EXTRA-PROPERTIES is currently unused." (concat ";;; " (file-name-nondirectory file) " --- automatically extracted autoloads\n" ";;\n" - ";;; Code:\n\n" + ";;; Code:\n" + "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n" " \n;; Local Variables:\n" ";; version-control: never\n" ";; no-byte-compile: t\n" @@ -590,12 +607,15 @@ EXTRA-PROPERTIES is currently unused." ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) (version-control 'never)) - (unless (fboundp 'autoload-ensure-default-file) - (package-autoload-ensure-default-file generated-autoload-file)) - (update-directory-autoloads pkg-dir))) + (package-autoload-ensure-default-file generated-autoload-file) + (update-directory-autoloads pkg-dir) + (let ((buf (find-buffer-visiting generated-autoload-file))) + (when buf (kill-buffer buf))))) (defvar tar-parse-info) (declare-function tar-untar-buffer "tar-mode" ()) +(declare-function tar-header-name "tar-mode" (tar-header) t) +(declare-function tar-header-link-type "tar-mode" (tar-header) t) (defun package-untar-buffer (dir) "Untar the current buffer. @@ -604,10 +624,16 @@ untar into a directory named DIR; otherwise, signal an error." (require 'tar-mode) (tar-mode) ;; Make sure everything extracts into DIR. - (let ((regexp (concat "\\`" (regexp-quote dir) "/"))) + (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/")) + (case-fold-search (memq system-type '(windows-nt ms-dos cygwin)))) (dolist (tar-data tar-parse-info) - (unless (string-match regexp (aref tar-data 2)) - (error "Package does not untar cleanly into directory %s/" dir)))) + (let ((name (expand-file-name (tar-header-name tar-data)))) + (or (string-match regexp name) + ;; Tarballs created by some utilities don't list + ;; directories with a trailing slash (Bug#13136). + (and (string-equal dir name) + (eq (tar-header-link-type tar-data) 5)) + (error "Package does not untar cleanly into directory %s/" dir))))) (tar-untar-buffer)) (defun package-unpack (package version) @@ -727,9 +753,12 @@ 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." + (unless package--initialized (error "package.el is not yet initialized!")) (let ((pkg-desc (assq package package-alist))) (if pkg-desc (version-list-<= min-version @@ -781,9 +810,8 @@ but version %s required" "Need package `%s-%s', but only %s is available" (symbol-name next-pkg) (package-version-join next-version) (package-version-join (package-desc-vers (cdr pkg-desc))))) - ;; Only add to the transaction if we don't already have it. - (unless (memq next-pkg package-list) - (push next-pkg package-list)) + ;; Move to front, so it gets installed early enough (bug#14082). + (setq package-list (cons next-pkg (delq next-pkg package-list))) (setq package-list (package-compute-transaction package-list (package-desc-reqs @@ -846,8 +874,13 @@ Also, add the originating archive to the end of the package vector." (version (package-desc-vers (cdr package))) (entry (cons name (vconcat (cdr package) (vector archive)))) - (existing-package (assq name package-archive-contents))) - (cond ((not existing-package) + (existing-package (assq name package-archive-contents)) + (pinned-to-archive (assoc name package-pinned-packages))) + (cond ((and pinned-to-archive + ;; If pinned to another archive, skip entirely. + (not (equal (cdr pinned-to-archive) archive))) + nil) + ((not existing-package) (add-to-list 'package-archive-contents entry)) ((version-list-< (package-desc-vers (cdr existing-package)) version) @@ -887,8 +920,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. @@ -1173,7 +1204,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 @@ -1187,6 +1218,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") @@ -1215,8 +1247,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") @@ -1579,10 +1613,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")) @@ -1602,16 +1637,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) @@ -1621,7 +1660,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 09e47b69b91..e000c343721 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,6 +1,6 @@ ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*- -;; Copyright (C) 2010-2012 Free Software Foundation, Inc. +;; Copyright (C) 2010-2013 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: @@ -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." @@ -517,6 +518,10 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--self-quoting-p (upat) (or (keywordp upat) (numberp upat) (stringp upat))) +(defsubst pcase--mark-used (sym) + ;; Exceptionally, `sym' may be a constant expression rather than a symbol. + (if (symbolp sym) (put sym 'pcase-used t))) + ;; It's very tempting to use `pcase' below, tho obviously, it'd create ;; bootstrapping problems. (defun pcase--u1 (matches code vars rest) @@ -581,7 +586,7 @@ Otherwise, it defers to REST which is a list of branches of the form ((memq upat '(t _)) (pcase--u1 matches code vars rest)) ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) - (if (eq (car upat) 'pred) (put sym 'pcase-used t)) + (if (eq (car upat) 'pred) (pcase--mark-used sym)) (let* ((splitrest (pcase--split-rest sym (lambda (pat) (pcase--split-pred upat pat)) rest)) @@ -614,10 +619,10 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) ((pcase--self-quoting-p upat) - (put sym 'pcase-used t) + (pcase--mark-used sym) (pcase--q1 sym upat matches code vars rest)) ((symbolp upat) - (put sym 'pcase-used t) + (pcase--mark-used sym) (if (not (assq upat vars)) (pcase--u1 matches code (cons (cons upat sym) vars) rest) ;; Non-linear pattern. Turn it into an `eq' test. @@ -640,7 +645,7 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) code vars rest))) ((eq (car-safe upat) '\`) - (put sym 'pcase-used t) + (pcase--mark-used sym) (pcase--q1 sym (cadr upat) matches code vars rest)) ((eq (car-safe upat) 'or) (let ((all (> (length (cdr upat)) 1)) @@ -662,7 +667,7 @@ Otherwise, it defers to REST which is a list of branches of the form sym (lambda (pat) (pcase--split-member elems pat)) rest)) (then-rest (car splitrest)) (else-rest (cdr splitrest))) - (put sym 'pcase-used t) + (pcase--mark-used sym) (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) (pcase--u1 matches code vars then-rest) (pcase--u else-rest))) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 30c16b51b9e..b7e553272f2 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -1,6 +1,6 @@ ;;; pp.el --- pretty printer for Emacs Lisp -;; Copyright (C) 1989, 1993, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1993, 2001-2013 Free Software Foundation, Inc. ;; Author: Randal Schwartz <merlyn@stonehenge.com> ;; Keywords: lisp diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 05bb7577d22..9b73bea065f 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -1,6 +1,6 @@ ;;; re-builder.el --- building Regexps with visual feedback -*- lexical-binding: t -*- -;; Copyright (C) 1999-2012 Free Software Foundation, Inc. +;; Copyright (C) 1999-2013 Free Software Foundation, Inc. ;; Author: Detlev Zundel <dzu@gnu.org> ;; Keywords: matching, lisp, tools diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 8c64327c0ff..de9966c0af0 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -1,6 +1,6 @@ ;;; regexp-opt.el --- generate efficient regexps to match strings -;; Copyright (C) 1994-2012 Free Software Foundation, Inc. +;; Copyright (C) 1994-2013 Free Software Foundation, Inc. ;; Author: Simon Marshall <simon@gnu.org> ;; Maintainer: FSF diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index a68c67246ff..9514ee62485 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -1,6 +1,6 @@ ;;; regi.el --- REGular expression Interpreting engine -;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. ;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> ;; Maintainer: bwarsaw@cen.com diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index cee6a43df86..f2c4389e71f 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -1,6 +1,6 @@ ;;; ring.el --- handle rings of items -;; Copyright (C) 1992, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: extensions diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 774c6cd2c38..e578298106d 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1,6 +1,6 @@ ;;; rx.el --- sexp notation for regular expressions -;; Copyright (C) 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 2001-2013 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: FSF diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 286c4937b5b..d0e3c5763b5 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -1,6 +1,6 @@ ;;; shadow.el --- locate Emacs Lisp file shadowings -;; Copyright (C) 1995, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2001-2013 Free Software Foundation, Inc. ;; Author: Terry Jones <terry@santafe.edu> ;; Keywords: lisp @@ -158,8 +158,14 @@ See the documentation for `list-load-path-shadows' for further information." (eq 0 (call-process "cmp" nil nil nil "-s" f1 f2)))))))) (defvar load-path-shadows-font-lock-keywords + ;; The idea is that shadows of files supplied with Emacs are more + ;; serious than various versions of external packages shadowing each + ;; other. `((,(format "hides \\(%s.*\\)" - (file-name-directory (locate-library "simple.el"))) + (file-name-directory + (or (locate-library "simple") + (file-name-as-directory + (expand-file-name "../lisp" data-directory))))) . (1 font-lock-warning-face))) "Keywords to highlight in `load-path-shadows-mode'.") @@ -201,101 +207,79 @@ the earlier. For example, suppose `load-path' is set to -\(\"/usr/gnu/emacs/site-lisp\" \"/usr/gnu/emacs/share/emacs/19.30/lisp\"\) +\(\"/usr/share/emacs/site-lisp\" \"/usr/share/emacs/24.3/lisp\") and that each of these directories contains a file called XXX.el. Then XXX.el in the site-lisp directory is referred to by all of: -\(require 'XXX\), \(autoload .... \"XXX\"\), \(load-library \"XXX\"\) etc. +\(require 'XXX), (autoload .... \"XXX\"), (load-library \"XXX\") etc. -The first XXX.el file prevents Emacs from seeing the second \(unless -the second is loaded explicitly via `load-file'\). +The first XXX.el file prevents Emacs from seeing the second (unless +the second is loaded explicitly via `load-file'). When not intended, such shadowings can be the source of subtle problems. For example, the above situation may have arisen because the XXX package was not distributed with versions of Emacs prior to -19.30. An Emacs maintainer downloaded XXX from elsewhere and installed +24.3. A system administrator downloaded XXX from elsewhere and installed it. Later, XXX was updated and included in the Emacs distribution. -Unless the Emacs maintainer checks for this, the new version of XXX -will be hidden behind the old \(which may no longer work with the new -Emacs version\). +Unless the system administrator checks for this, the new version of XXX +will be hidden behind the old (which may no longer work with the new +Emacs version). This function performs these checks and flags all possible shadowings. Because a .el file may exist without a corresponding .elc -\(or vice-versa\), these suffixes are essentially ignored. A file -XXX.elc in an early directory \(that does not contain XXX.el\) is +\(or vice-versa), these suffixes are essentially ignored. A file +XXX.elc in an early directory (that does not contain XXX.el) is considered to shadow a later file XXX.el, and vice-versa. Shadowings are located by calling the (non-interactive) companion function, `load-path-shadows-find'." (interactive) - (let* ((path (copy-sequence load-path)) - (tem path) - toplevs) - ;; If we can find simple.el in two places, - (dolist (tt tem) - (if (or (file-exists-p (expand-file-name "simple.el" tt)) - (file-exists-p (expand-file-name "simple.el.gz" tt))) - (setq toplevs (cons tt toplevs)))) - (if (> (length toplevs) 1) - ;; Cut off our copy of load-path right before - ;; the last directory which has simple.el in it. - ;; This avoids loads of duplications between the source dir - ;; and the dir where these files were copied by installation. - (let ((break (car toplevs))) - (setq tem path) - (while tem - (if (eq (nth 1 tem) break) - (progn - (setcdr tem nil) - (setq tem nil))) - (setq tem (cdr tem))))) - - (let* ((shadows (load-path-shadows-find path)) - (n (/ (length shadows) 2)) - (msg (format "%s Emacs Lisp load-path shadowing%s found" - (if (zerop n) "No" (concat "\n" (number-to-string n))) - (if (= n 1) " was" "s were")))) - (with-temp-buffer - (while shadows - (insert (format "%s hides %s\n" (car shadows) - (car (cdr shadows)))) - (setq shadows (cdr (cdr shadows)))) - (if stringp - (buffer-string) - (if (called-interactively-p 'interactive) - ;; We are interactive. - ;; Create the *Shadows* buffer and display shadowings there. - (let ((string (buffer-string))) - (with-current-buffer (get-buffer-create "*Shadows*") - (display-buffer (current-buffer)) - (load-path-shadows-mode) ; run after-change-major-mode-hook - (let ((inhibit-read-only t)) - (erase-buffer) - (insert string) - (insert msg "\n") - (while (re-search-backward "\\(^.*\\) hides \\(.*$\\)" - nil t) - (dotimes (i 2) - (make-button (match-beginning (1+ i)) - (match-end (1+ i)) - 'type 'load-path-shadows-find-file - 'shadow-file - (match-string (1+ i))))) - (goto-char (point-max))))) - ;; We are non-interactive, print shadows via message. - (unless (zerop n) - (message "This site has duplicate Lisp libraries with the same name. + (let* ((shadows (load-path-shadows-find load-path)) + (n (/ (length shadows) 2)) + (msg (format "%s Emacs Lisp load-path shadowing%s found" + (if (zerop n) "No" (concat "\n" (number-to-string n))) + (if (= n 1) " was" "s were")))) + (with-temp-buffer + (while shadows + (insert (format "%s hides %s\n" (car shadows) + (car (cdr shadows)))) + (setq shadows (cdr (cdr shadows)))) + (if stringp + (buffer-string) + (if (called-interactively-p 'interactive) + ;; We are interactive. + ;; Create the *Shadows* buffer and display shadowings there. + (let ((string (buffer-string))) + (with-current-buffer (get-buffer-create "*Shadows*") + (display-buffer (current-buffer)) + (load-path-shadows-mode) ; run after-change-major-mode-hook + (let ((inhibit-read-only t)) + (erase-buffer) + (insert string) + (insert msg "\n") + (while (re-search-backward "\\(^.*\\) hides \\(.*$\\)" + nil t) + (dotimes (i 2) + (make-button (match-beginning (1+ i)) + (match-end (1+ i)) + 'type 'load-path-shadows-find-file + 'shadow-file + (match-string (1+ i))))) + (goto-char (point-max))))) + ;; We are non-interactive, print shadows via message. + (unless (zerop n) + (message "This site has duplicate Lisp libraries with the same name. If a locally-installed Lisp library overrides a library in the Emacs release, that can cause trouble, and you should probably remove the locally-installed version unless you know what you are doing.\n") - (goto-char (point-min)) - ;; Mimic the previous behavior of using lots of messages. - ;; I think one single message would look better... - (while (not (eobp)) - (message "%s" (buffer-substring (line-beginning-position) - (line-end-position))) - (forward-line 1)) - (message "%s" msg)))))))) + (goto-char (point-min)) + ;; Mimic the previous behavior of using lots of messages. + ;; I think one single message would look better... + (while (not (eobp)) + (message "%s" (buffer-substring (line-beginning-position) + (line-end-position))) + (forward-line 1)) + (message "%s" msg))))))) (provide 'shadow) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 9fa8a108236..f9d0fd9366b 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1,6 +1,6 @@ ;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*- -;; Copyright (C) 2010-2012 Free Software Foundation, Inc. +;; Copyright (C) 2010-2013 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: languages, lisp, internal, parsing, indentation @@ -957,7 +957,7 @@ If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\" (let ((ender (funcall smie-backward-token-function))) (cond ((not (and ender (rassoc ender smie-closer-alist))) - ;; This not is one of the begin..end we know how to check. + ;; This is not one of the begin..end we know how to check. (blink-matching-check-mismatch start end)) ((not start) t) ((eq t (car (rassoc ender smie-closer-alist))) nil) @@ -1012,6 +1012,9 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. (or (eq (char-before) last-command-event) (not (memq (char-before) smie-blink-matching-triggers))) + ;; FIXME: For octave's "switch ... case ... case" we flash + ;; `switch' at the end of the first `case' and we burp + ;; "mismatch" at the end of the second `case'. (or smie-blink-matching-inners (not (numberp (nth 2 (assoc token smie-grammar)))))) ;; The major mode might set blink-matching-check-function @@ -1021,6 +1024,91 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. (let ((blink-matching-check-function #'smie-blink-matching-check)) (blink-matching-open)))))))) +(defvar-local smie--matching-block-data-cache nil) + +(defun smie--opener/closer-at-point () + "Return (OPENER TOKEN START END) or nil. +OPENER is non-nil if TOKEN is an opener and nil if it's a closer." + (let* ((start (point)) + ;; Move to a previous position outside of a token. + (_ (funcall smie-backward-token-function)) + ;; Move to the end of the token before point. + (btok (funcall smie-forward-token-function)) + (bend (point))) + (cond + ;; Token before point is a closer? + ((and (>= bend start) (rassoc btok smie-closer-alist)) + (funcall smie-backward-token-function) + (when (< (point) start) + (prog1 (list nil btok (point) bend) + (goto-char bend)))) + ;; Token around point is an opener? + ((and (> bend start) (assoc btok smie-closer-alist)) + (funcall smie-backward-token-function) + (when (<= (point) start) (list t btok (point) bend))) + ((<= bend start) + (let ((atok (funcall smie-forward-token-function)) + (aend (point))) + (cond + ((< aend start) nil) ;Hopefully shouldn't happen. + ;; Token after point is a closer? + ((assoc atok smie-closer-alist) + (funcall smie-backward-token-function) + (when (<= (point) start) + (list t atok (point) aend))))))))) + +(defun smie--matching-block-data (orig &rest args) + "A function suitable for `show-paren-data-function' (which see)." + (if (or (null smie-closer-alist) + (eq (point) (car smie--matching-block-data-cache))) + (or (cdr smie--matching-block-data-cache) + (apply orig args)) + (setq smie--matching-block-data-cache (list (point))) + (unless (nth 8 (syntax-ppss)) + (condition-case nil + (let ((here (smie--opener/closer-at-point))) + (when (and here + (or smie-blink-matching-inners + (not (numberp + (nth (if (nth 0 here) 1 2) + (assoc (nth 1 here) smie-grammar)))))) + (let ((there + (cond + ((car here) ; Opener. + (let ((data (smie-forward-sexp 'halfsexp)) + (tend (point))) + (unless (car data) + (funcall smie-backward-token-function) + (list (member (cons (nth 1 here) (nth 2 data)) + smie-closer-alist) + (point) tend)))) + (t ;Closer. + (let ((data (smie-backward-sexp 'halfsexp)) + (htok (nth 1 here))) + (if (car data) + (let* ((hprec (nth 2 (assoc htok smie-grammar))) + (ttok (nth 2 data)) + (tprec (nth 1 (assoc ttok smie-grammar)))) + (when (and (numberp hprec) ;Here is an inner. + (eq hprec tprec)) + (goto-char (nth 1 data)) + (let ((tbeg (point))) + (funcall smie-forward-token-function) + (list t tbeg (point))))) + (let ((tbeg (point))) + (funcall smie-forward-token-function) + (list (member (cons (nth 2 data) htok) + smie-closer-alist) + tbeg (point))))))))) + ;; Update the cache. + (setcdr smie--matching-block-data-cache + (list (nth 2 here) (nth 3 here) + (nth 1 there) (nth 2 there) + (not (nth 0 there))))))) + (scan-error nil)) + (goto-char (car smie--matching-block-data-cache))) + (apply #'smie--matching-block-data orig args))) + ;;; The indentation engine. (defcustom smie-indent-basic 4 @@ -1067,9 +1155,10 @@ the beginning of a line." (save-excursion (<= (line-end-position) (progn - (when (zerop (length (funcall smie-forward-token-function))) - ;; Could be an open-paren. - (forward-char 1)) + (and (zerop (length (funcall smie-forward-token-function))) + (not (eobp)) + ;; Could be an open-paren. + (forward-char 1)) (skip-chars-forward " \t") (or (eolp) (and (looking-at comment-start-skip) @@ -1277,7 +1366,12 @@ BASE-POS is the position relative to which offsets should be applied." ((looking-at "\\s(\\|\\s)\\(\\)") (forward-char 1) (cons (buffer-substring (1- (point)) (point)) - (if (match-end 1) '(0 nil) '(nil 0))))))) + (if (match-end 1) '(0 nil) '(nil 0)))) + ((looking-at "\\s\"") + (forward-sexp 1) + nil) + ((eobp) nil) + (t (error "Bumped into unknown token"))))) (defun smie-indent-backward-token () "Skip token backward and return it, along with its levels." @@ -1289,7 +1383,12 @@ BASE-POS is the position relative to which offsets should be applied." ((memq (setq class (syntax-class (syntax-after (1- (point))))) '(4 5)) (forward-char -1) (cons (buffer-substring (point) (1+ (point))) - (if (eq class 4) '(nil 0) '(0 nil))))))) + (if (eq class 4) '(nil 0) '(0 nil)))) + ((eq class 7) + (backward-sexp 1) + nil) + ((bobp) nil) + (t (error "Bumped into unknown token"))))) (defun smie-indent-virtual () ;; We used to take an optional arg (with value :not-hanging) to specify that @@ -1350,8 +1449,11 @@ should not be computed on the basis of the following token." (if (and (< pos (line-beginning-position)) ;; Make sure `token' also *starts* on another line. (save-excursion - (smie-indent-backward-token) - (< pos (line-beginning-position)))) + (let ((endpos (point))) + (goto-char pos) + (forward-line 1) + (and (equal res (smie-indent-forward-token)) + (eq (point) endpos))))) nil (goto-char pos) res))))) @@ -1473,13 +1575,21 @@ should not be computed on the basis of the following token." (save-excursion (forward-comment (point-max)) (skip-chars-forward " \t\r\n") - ;; FIXME: We assume here that smie-indent-calculate will compute the - ;; indentation of the next token based on text before the comment, but - ;; this is not guaranteed, so maybe we should let - ;; smie-indent-calculate return some info about which buffer position - ;; was used as the "indentation base" and check that this base is - ;; before `pos'. - (smie-indent-calculate)))) + (unless + ;; Don't align with a closer, since the comment is "within" the + ;; closed element. Don't align with EOB either. + (save-excursion + (let ((next (funcall smie-forward-token-function))) + (or (if (zerop (length next)) + (or (eobp) (eq (car (syntax-after (point))) 5))) + (rassoc next smie-closer-alist)))) + ;; FIXME: We assume here that smie-indent-calculate will compute the + ;; indentation of the next token based on text before the comment, + ;; but this is not guaranteed, so maybe we should let + ;; smie-indent-calculate return some info about which buffer + ;; position was used as the "indentation base" and check that this + ;; base is before `pos'. + (smie-indent-calculate))))) (defun smie-indent-comment-continue () ;; indentation of comment-continue lines. @@ -1628,34 +1738,45 @@ to which that point should be aligned, if we were to reindent it.") (save-excursion (indent-line-to indent)) (indent-line-to indent))))) -(defun smie-auto-fill () +(defun smie-auto-fill (do-auto-fill) (let ((fc (current-fill-column))) - (while (and fc (> (current-column) fc)) - (cond - ((not (or (nth 8 (save-excursion - (syntax-ppss (line-beginning-position)))) - (nth 8 (syntax-ppss)))) - (save-excursion - (beginning-of-line) - (smie-indent-forward-token) - (let ((bsf (point)) - (gain 0) - curcol) - (while (<= (setq curcol (current-column)) fc) - ;; FIXME? `smie-indent-calculate' can (and often will) - ;; return a result that actually depends on the presence/absence - ;; of a newline, so the gain computed here may not be accurate, - ;; but in practice it seems to works well enough. - (let* ((newcol (smie-indent-calculate)) - (newgain (- curcol newcol))) - (when (> newgain gain) - (setq gain newgain) - (setq bsf (point)))) - (smie-indent-forward-token)) - (when (> gain 0) - (goto-char bsf) - (newline-and-indent))))) - (t (do-auto-fill)))))) + (when (and fc (> (current-column) fc)) + ;; The loop below presumes BOL is outside of strings or comments. Also, + ;; sometimes we prefer to fill the comment than the code around it. + (unless (or (nth 8 (save-excursion + (syntax-ppss (line-beginning-position)))) + (nth 4 (save-excursion + (move-to-column fc) + (syntax-ppss)))) + (while + (and (with-demoted-errors + (save-excursion + (let ((end (point)) + (bsf nil) ;Best-so-far. + (gain 0)) + (beginning-of-line) + (while (progn + (smie-indent-forward-token) + (and (<= (point) end) + (<= (current-column) fc))) + ;; FIXME? `smie-indent-calculate' can (and often + ;; does) return a result that actually depends on the + ;; presence/absence of a newline, so the gain computed + ;; here may not be accurate, but in practice it seems + ;; to work well enough. + (skip-chars-forward " \t") + (let* ((newcol (smie-indent-calculate)) + (newgain (- (current-column) newcol))) + (when (> newgain gain) + (setq gain newgain) + (setq bsf (point))))) + (when (> gain 0) + (goto-char bsf) + (newline-and-indent) + 'done)))) + (> (current-column) fc)))) + (when (> (current-column) fc) + (funcall do-auto-fill))))) (defun smie-setup (grammar rules-function &rest keywords) @@ -1665,12 +1786,11 @@ RULES-FUNCTION is a set of indentation rules for use on `smie-rules-function'. KEYWORDS are additional arguments, which can use the following keywords: - :forward-token FUN - :backward-token FUN" - (set (make-local-variable 'smie-rules-function) rules-function) - (set (make-local-variable 'smie-grammar) grammar) - (set (make-local-variable 'indent-line-function) 'smie-indent-line) - (set (make-local-variable 'normal-auto-fill-function) 'smie-auto-fill) - (set (make-local-variable 'forward-sexp-function) - 'smie-forward-sexp-command) + (setq-local smie-rules-function rules-function) + (setq-local smie-grammar grammar) + (setq-local indent-line-function #'smie-indent-line) + (add-function :around (local 'normal-auto-fill-function) #'smie-auto-fill) + (setq-local forward-sexp-function #'smie-forward-sexp-command) (while keywords (let ((k (pop keywords)) (v (pop keywords))) @@ -1682,29 +1802,27 @@ KEYWORDS are additional arguments, which can use the following keywords: (_ (message "smie-setup: ignoring unknown keyword %s" k))))) (let ((ca (cdr (assq :smie-closer-alist grammar)))) (when ca - (set (make-local-variable 'smie-closer-alist) ca) + (setq-local smie-closer-alist ca) ;; Only needed for interactive calls to blink-matching-open. - (set (make-local-variable 'blink-matching-check-function) - #'smie-blink-matching-check) + (setq-local blink-matching-check-function #'smie-blink-matching-check) (add-hook 'post-self-insert-hook #'smie-blink-matching-open 'append 'local) - (set (make-local-variable 'smie-blink-matching-triggers) - (append smie-blink-matching-triggers - ;; Rather than wait for SPC to blink, try to blink as - ;; soon as we type the last char of a block ender. - (let ((closers (sort (mapcar #'cdr smie-closer-alist) - #'string-lessp)) - (triggers ()) - closer) - (while (setq closer (pop closers)) - (unless (and closers - ;; FIXME: this eliminates prefixes of other - ;; closers, but we should probably - ;; eliminate prefixes of other keywords - ;; as well. - (string-prefix-p closer (car closers))) - (push (aref closer (1- (length closer))) triggers))) - (delete-dups triggers))))))) + (add-function :around (local 'show-paren-data-function) + #'smie--matching-block-data) + ;; Setup smie-blink-matching-triggers. Rather than wait for SPC to + ;; blink, try to blink as soon as we type the last char of a block ender. + (let ((closers (sort (mapcar #'cdr smie-closer-alist) #'string-lessp)) + (triggers ()) + closer) + (while (setq closer (pop closers)) + (unless + ;; FIXME: this eliminates prefixes of other closers, but we + ;; should probably eliminate prefixes of other keywords as well. + (and closers (string-prefix-p closer (car closers))) + (push (aref closer (1- (length closer))) triggers))) + (setq-local smie-blink-matching-triggers + (append smie-blink-matching-triggers + (delete-dups triggers))))))) (provide 'smie) diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index c3d78b3444b..3e850320133 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -1,6 +1,6 @@ ;;; syntax.el --- helper functions to find syntactic context -*- lexical-binding: t -*- -;; Copyright (C) 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 2000-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal @@ -55,12 +55,19 @@ ;; have to flush that cache between each function, and we couldn't use ;; syntax-ppss-flush-cache since that would not only flush the cache but also ;; reset syntax-propertize--done which should not be done in this case). - "Mode-specific function to apply the syntax-table properties. -Called with two arguments: START and END. -This function can call `syntax-ppss' on any position before END, but it -should not call `syntax-ppss-flush-cache', which means that it should not -call `syntax-ppss' on some position and later modify the buffer on some -earlier position.") + "Mode-specific function to apply `syntax-table' text properties. +It is the work horse of `syntax-propertize', which is called by things like +Font-Lock and indentation. + +It is given two arguments, START and END: the start and end of the text to +which `syntax-table' might need to be applied. Major modes can use this to +override the buffer's syntax table for special syntactic constructs that +cannot be handled just by the buffer's syntax-table. + +The specified function may call `syntax-ppss' on any position +before END, but it should not call `syntax-ppss-flush-cache', +which means that it should not call `syntax-ppss' on some +position and later modify the buffer on some earlier position.") (defvar syntax-propertize-chunk-size 500) @@ -93,7 +100,7 @@ Put first the functions more likely to cause a change and cheaper to compute.") (setq beg (or (previous-single-property-change beg 'syntax-multiline) (point-min)))) ;; - (when (get-text-property end 'font-lock-multiline) + (when (get-text-property end 'syntax-multiline) (setq end (or (text-property-any end (point-max) 'syntax-multiline nil) (point-max)))) @@ -118,7 +125,7 @@ The arg RULES can be of the same form as in `syntax-propertize-rules'. The return value is an object that can be passed as a rule to `syntax-propertize-rules'. I.e. this is useful only when you want to share rules among several -syntax-propertize-functions." +`syntax-propertize-function's." (declare (debug syntax-propertize-rules)) ;; Precompile? Yeah, right! ;; Seriously, tho, this is a macro for 2 reasons: diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index a56a7619ea9..5660ac8c4cc 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -1,16 +1,17 @@ ;;; tabulated-list.el --- generic major mode for tabulated lists -*- lexical-binding: t -*- -;; Copyright (C) 2011-2012 Free Software Foundation, Inc. +;; Copyright (C) 2011-2013 Free Software Foundation, Inc. ;; Author: Chong Yidong <cyd@stupidchicken.com> ;; Keywords: extensions, lisp +;; Version: 1.0 ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs 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, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -379,7 +380,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. @@ -517,12 +520,11 @@ printer is `tabulated-list-print-entry', but a mode that keeps data in an ewoc may instead specify a printer function (e.g., one that calls `ewoc-enter-last'), with `tabulated-list-print-entry' as the ewoc pretty-printer." - (setq truncate-lines t) - (setq buffer-read-only t) - (set (make-local-variable 'revert-buffer-function) - 'tabulated-list-revert) - (set (make-local-variable 'glyphless-char-display) - tabulated-list-glyphless-char-display)) + (setq-local truncate-lines t) + (setq-local buffer-read-only t) + (setq-local buffer-undo-list t) + (setq-local revert-buffer-function #'tabulated-list-revert) + (setq-local glyphless-char-display tabulated-list-glyphless-char-display)) (put 'tabulated-list-mode 'mode-class 'special) diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 79251bfd6e1..02023b957a5 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,6 +1,6 @@ ;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -;; Copyright (C) 2002-2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index 2de6e6c5bc0..e557e1c30c1 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -1,6 +1,6 @@ ;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage -;; Copyright (C) 2002-2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 3999529f7ac..a5619583145 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -1,6 +1,6 @@ ;;;; testcover.el -- Visual code-coverage tool -;; Copyright (C) 2002-2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> @@ -100,14 +100,14 @@ current global map. The macro `lambda' is self-evaluating, hence always returns the same value (the function it defines may return varying values when called)." :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-noreturn-functions '(error noreturn throw signal) "Subset of `testcover-1value-functions' -- these never return. We mark them as having returned nil just before calling them." :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-compose-functions '(+ - * / = append length list make-keymap make-sparse-keymap @@ -118,7 +118,7 @@ calls to one of the `testcover-1value-functions', so if that's true then no brown splotch is shown for these. This list is quite incomplete! Most side-effect-free functions should be here." :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-progn-functions '(define-key fset function goto-char mapc overlay-put progn @@ -132,7 +132,7 @@ brown splotch is shown for these if the last argument is a constant or a call to one of the `testcover-1value-functions'. This list is probably incomplete!" :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-prog1-functions '(prog1 unwind-protect) @@ -140,7 +140,7 @@ incomplete!" brown splotch is shown for these if the first argument is a constant or a call to one of the `testcover-1value-functions'." :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-potentially-1value-functions '(add-hook and beep or remove-hook unless when) @@ -270,9 +270,9 @@ value, 'maybe if either is acceptable." (setq id (nth 2 form)) (setcdr form (nthcdr 2 form)) (setq val (testcover-reinstrument (nth 2 form))) - (if (eq val t) - (setcar form 'testcover-1value) - (setcar form 'testcover-after)) + (setcar form (if (eq val t) + 'testcover-1value + 'testcover-after)) (when val ;;1-valued or potentially 1-valued (aset testcover-vector id '1value)) @@ -359,9 +359,9 @@ value, 'maybe if either is acceptable." ,(nth 3 (cadr form)))) t) (t - (if (eq (car (cadr form)) 'edebug-after) - (setq id (car (nth 3 (cadr form)))) - (setq id (car (cadr form)))) + (setq id (car (if (eq (car (cadr form)) 'edebug-after) + (nth 3 (cadr form)) + (cadr form)))) (let ((testcover-1value-functions (cons id testcover-1value-functions))) (testcover-reinstrument (cadr form)))))) @@ -379,9 +379,9 @@ value, 'maybe if either is acceptable." ,(nth 3 (cadr form)))) 'maybe) (t - (if (eq (car (cadr form)) 'edebug-after) - (setq id (car (nth 3 (cadr form)))) - (setq id (car (cadr form)))) + (setq id (car (if (eq (car (cadr form)) 'edebug-after) + (nth 3 (cadr form)) + (cadr form)))) (let ((testcover-noreturn-functions (cons id testcover-noreturn-functions))) (testcover-reinstrument (cadr form)))))) @@ -447,6 +447,12 @@ binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM (defun testcover-after (idx val) "Internal function for coverage testing. Returns VAL after installing it in `testcover-vector' at offset IDX." + (declare (gv-expander (lambda (do) + (gv-letplace (getter setter) val + (funcall do getter + (lambda (store) + `(progn (testcover-after ,idx ,getter) + ,(funcall setter store)))))))) (cond ((eq (aref testcover-vector idx) 'unknown) (aset testcover-vector idx val)) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index a66d5972d82..0aa31f717ed 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -1,6 +1,6 @@ ;;; timer.el --- run a function with args at some time in future -;; Copyright (C) 1996, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Package: emacs @@ -27,27 +27,34 @@ ;;; Code: -;; Layout of a timer vector: -;; [triggered-p high-seconds low-seconds usecs psecs repeat-delay -;; function args idle-delay] -;; triggered-p is nil if the timer is active (waiting to be triggered), -;; t if it is inactive ("already triggered", in theory) - (eval-when-compile (require 'cl-lib)) (cl-defstruct (timer - (:constructor nil) - (:copier nil) - (:constructor timer-create ()) - (:type vector) - (:conc-name timer--)) + (:constructor nil) + (:copier nil) + (:constructor timer-create ()) + (:type vector) + (:conc-name timer--)) + ;; nil if the timer is active (waiting to be triggered), + ;; non-nil if it is inactive ("already triggered", in theory). (triggered t) - high-seconds low-seconds usecs psecs repeat-delay function args idle-delay) + ;; Time of next trigger: for normal timers, absolute time, for idle timers, + ;; time relative to idle-start. + high-seconds low-seconds usecs + ;; For normal timers, time between repetitions, or nil. For idle timers, + ;; non-nil iff repeated. + repeat-delay + function args ;What to do when triggered. + idle-delay ;If non-nil, this is an idle-timer. + psecs) (defun timerp (object) "Return t if OBJECT is a timer." (and (vectorp object) (= (length object) 9))) +(defsubst timer--check (timer) + (or (timerp timer) (signal 'wrong-type-argument (list #'timerp timer)))) + ;; Pseudo field `time'. (defun timer--time (timer) (list (timer--high-seconds timer) @@ -57,17 +64,17 @@ (gv-define-simple-setter timer--time (lambda (timer time) - (or (timerp timer) (error "Invalid timer")) + (timer--check timer) (setf (timer--high-seconds timer) (pop time)) (let ((low time) (usecs 0) (psecs 0)) (if (consp time) - (progn - (setq low (pop time)) - (if time - (progn - (setq usecs (pop time)) - (if time - (setq psecs (car time))))))) + (progn + (setq low (pop time)) + (if time + (progn + (setq usecs (pop time)) + (if time + (setq psecs (car time))))))) (setf (timer--low-seconds timer) low) (setf (timer--usecs timer) usecs) (setf (timer--psecs timer) psecs)))) @@ -83,15 +90,13 @@ fire repeatedly that many seconds apart." timer) (defun timer-set-idle-time (timer secs &optional repeat) + ;; FIXME: Merge with timer-set-time. "Set the trigger idle time of TIMER to SECS. SECS may be an integer, floating point number, or the internal time format returned by, e.g., `current-idle-time'. If optional third argument REPEAT is non-nil, make the timer fire each time Emacs is idle for that many seconds." - (if (consp secs) - (setf (timer--time timer) secs) - (setf (timer--time timer) '(0 0 0)) - (timer-inc-time timer secs)) + (setf (timer--time timer) (if (consp secs) secs (seconds-to-time secs))) (setf (timer--repeat-delay timer) repeat) timer) @@ -119,7 +124,7 @@ of SECS seconds since the epoch. SECS may be a fraction." (floor (mod next-sec-psec 1000000))))) (defun timer-relative-time (time secs &optional usecs psecs) - "Advance TIME by SECS seconds and optionally USECS nanoseconds + "Advance TIME by SECS seconds and optionally USECS microseconds and PSECS picoseconds. SECS may be either an integer or a floating point number." (let ((delta (if (floatp secs) @@ -134,7 +139,7 @@ floating point number." (time-less-p (timer--time t1) (timer--time t2))) (defun timer-inc-time (timer secs &optional usecs psecs) - "Increment the time set in TIMER by SECS seconds, USECS nanoseconds, + "Increment the time set in TIMER by SECS seconds, USECS microseconds, and PSECS picoseconds. SECS may be a fraction. If USECS or PSECS are omitted, they are treated as zero." (setf (timer--time timer) @@ -146,19 +151,17 @@ TIME must be in the internal format returned by, e.g., `current-time'. The microsecond count from TIME is ignored, and USECS is used instead. If optional fourth argument DELTA is a positive number, make the timer fire repeatedly that many seconds apart." + (declare (obsolete "use `timer-set-time' and `timer-inc-time' instead." + "22.1")) (setf (timer--time timer) time) (setf (timer--usecs timer) usecs) (setf (timer--psecs timer) 0) (setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta)) timer) -(make-obsolete 'timer-set-time-with-usecs - "use `timer-set-time' and `timer-inc-time' instead." - "22.1") (defun timer-set-function (timer function &optional args) "Make TIMER call FUNCTION with optional ARGS when triggering." - (or (timerp timer) - (error "Invalid timer")) + (timer--check timer) (setf (timer--function timer) function) (setf (timer--args timer) args) timer) @@ -182,9 +185,10 @@ fire repeatedly that many seconds apart." (setcdr reuse-cell timers)) (setq reuse-cell (cons timer timers))) ;; Insert new timer after last which possibly means in front of queue. - (cond (last (setcdr last reuse-cell)) - (idle (setq timer-idle-list reuse-cell)) - (t (setq timer-list reuse-cell))) + (setf (cond (last (cdr last)) + (idle timer-idle-list) + (t timer-list)) + reuse-cell) (setf (timer--triggered timer) triggered-p) (setf (timer--idle-delay timer) idle) nil) @@ -205,20 +209,26 @@ timers). If nil, allocate a new cell." "Insert TIMER into `timer-idle-list'. This arranges to activate TIMER whenever Emacs is next idle. If optional argument DONT-WAIT is non-nil, set TIMER to activate -immediately, or at the right time, if Emacs is already idle. +immediately \(see below\), or at the right time, if Emacs is +already idle. REUSE-CELL, if non-nil, is a cons cell to reuse when inserting TIMER into `timer-idle-list' (usually a cell removed from that list by `cancel-timer-internal'; using this reduces consing for -repeat timers). If nil, allocate a new cell." +repeat timers). If nil, allocate a new cell. + +Using non-nil DONT-WAIT is not recommended when activating an +idle timer from an idle timer handler, if the timer being +activated has an idleness time that is smaller or equal to +the time of the current timer. That's because the activated +timer will fire right away." (timer--activate timer (not dont-wait) reuse-cell 'idle)) (defalias 'disable-timeout 'cancel-timer) (defun cancel-timer (timer) "Remove TIMER from the list of active timers." - (or (timerp timer) - (error "Invalid timer")) + (timer--check timer) (setq timer-list (delq timer timer-list)) (setq timer-idle-list (delq timer timer-idle-list)) nil) @@ -277,40 +287,47 @@ This function is called, by name, directly by the C code." (setq timer-event-last-1 timer-event-last) (setq timer-event-last timer) (let ((inhibit-quit t)) - (if (timerp timer) - (let (retrigger cell) - ;; Delete from queue. Record the cons cell that was used. - (setq cell (cancel-timer-internal timer)) - ;; Re-schedule if requested. - (if (timer--repeat-delay timer) - (if (timer--idle-delay timer) - (timer-activate-when-idle timer nil cell) - (timer-inc-time timer (timer--repeat-delay timer) 0) - ;; If real time has jumped forward, - ;; perhaps because Emacs was suspended for a long time, - ;; limit how many times things get repeated. - (if (and (numberp timer-max-repeats) - (< 0 (timer-until timer (current-time)))) - (let ((repeats (/ (timer-until timer (current-time)) - (timer--repeat-delay timer)))) - (if (> repeats timer-max-repeats) - (timer-inc-time timer (* (timer--repeat-delay timer) - repeats))))) - (timer-activate timer t cell) - (setq retrigger t))) - ;; Run handler. - ;; We do this after rescheduling so that the handler function - ;; can cancel its own timer successfully with cancel-timer. - (condition-case nil - ;; 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)) - (if retrigger - (setf (timer--triggered timer) nil))) - (error "Bogus timer event")))) + (timer--check timer) + (let ((retrigger nil) + (cell + ;; Delete from queue. Record the cons cell that was used. + (cancel-timer-internal timer))) + ;; Re-schedule if requested. + (if (timer--repeat-delay timer) + (if (timer--idle-delay timer) + (timer-activate-when-idle timer nil cell) + (timer-inc-time timer (timer--repeat-delay timer) 0) + ;; If real time has jumped forward, + ;; perhaps because Emacs was suspended for a long time, + ;; limit how many times things get repeated. + (if (and (numberp timer-max-repeats) + (< 0 (timer-until timer (current-time)))) + (let ((repeats (/ (timer-until timer (current-time)) + (timer--repeat-delay timer)))) + (if (> repeats timer-max-repeats) + (timer-inc-time timer (* (timer--repeat-delay timer) + repeats))))) + ;; Place it back on the timer-list before running + ;; timer--function, so it can cancel-timer itself. + (timer-activate timer t cell) + (setq retrigger t))) + ;; Run handler. + (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 (message "Error running timer%s: %S" + (if (symbolp (timer--function timer)) + (format " `%s'" (timer--function timer)) "") + err))) + (when (and retrigger + ;; If the timer's been canceled, don't "retrigger" it + ;; since it might still be in the copy of timer-list kept + ;; by keyboard.c:timer_check (bug#14156). + (memq timer timer-list)) + (setf (timer--triggered timer) nil))))) ;; This function is incompatible with the one in levents.el. (defun timeout-event-p (event) @@ -403,7 +420,9 @@ The action is to call FUNCTION with arguments ARGS. SECS may be an integer, a floating point number, or the internal time format returned by, e.g., `current-idle-time'. If Emacs is currently idle, and has been idle for N seconds (N < SECS), -then it will call FUNCTION in SECS - N seconds from now. +then it will call FUNCTION in SECS - N seconds from now. Using +SECS <= N is not recommended if this function is invoked from an idle +timer, because FUNCTION will then be called immediately. If REPEAT is non-nil, do the action each time Emacs has been idle for exactly SECS seconds (that is, only once for each time Emacs becomes idle). @@ -442,7 +461,7 @@ be detected. (with-timeout-timers (cons -with-timeout-timer- with-timeout-timers))) (unwind-protect - ,@body + (progn ,@body) (cancel-timer -with-timeout-timer-)))))) ;; It is tempting to avoid the `if' altogether and instead run ;; timeout-forms in the timer, just before throwing `timeout'. @@ -519,6 +538,12 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." secs (if (string-match-p "\\`[0-9.]+\\'" string) (string-to-number string))))) + +(defun internal-timer-start-idle () + "Mark all idle-time timers as once again candidates for running." + (dolist (timer timer-idle-list) + (if (timerp timer) ;; FIXME: Why test? + (setf (timer--triggered timer) nil)))) (provide 'timer) diff --git a/lisp/emacs-lisp/tq.el b/lisp/emacs-lisp/tq.el index 0d13a3caed0..d308ce694d2 100644 --- a/lisp/emacs-lisp/tq.el +++ b/lisp/emacs-lisp/tq.el @@ -1,6 +1,7 @@ ;;; tq.el --- utility to maintain a transaction queue -;; Copyright (C) 1985-1987, 1992, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 1992, 2001-2013 Free Software Foundation, +;; Inc. ;; Author: Scott Draves <spot@cs.cmu.edu> ;; Maintainer: FSF diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index c6fff7aa443..f605c2865c0 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -1,6 +1,6 @@ -;;; trace.el --- tracing facility for Emacs Lisp functions +;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*- -;; Copyright (C) 1993, 1998, 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1998, 2000-2013 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: FSF @@ -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,108 +157,158 @@ (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)) +;;;###autoload +(defun trace-values (&rest values) + "Helper function to get internal values. +You can call this function to add internal values in the trace buffer." + (unless inhibit-trace + (with-current-buffer trace-buffer + (goto-char (point-max)) + (insert + (trace-entry-message + 'trace-values trace-level values ""))))) + +(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--display-buffer (buf) + (unless (or trace--timer + (get-buffer-window buf '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 buf nil 0)))))) + + +(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 background (trace--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 (trace--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 + (let ((default (function-called-at-point)) + (beg (string-match ":[ \t]*\\'" prompt))) + (intern (completing-read (if default + (format + "%s (default %s)%s" + (substring prompt 0 beg) + default + (if beg (substring prompt beg) ": ")) + prompt) + obarray 'fboundp t nil nil + (if default (symbol-name default))))) + (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 trace advice for FUNCTION and activates it together with any other advice there might be!! The trace BUFFER will popup whenever FUNCTION is called. Do not use this to trace functions that switch buffers or do any other -display oriented stuff, use `trace-function-background' instead." - (interactive - (list - (intern (completing-read "Trace function: " obarray 'fboundp t)) - (read-buffer "Output to buffer: " trace-buffer))) - (trace-function-internal function buffer nil)) +display oriented stuff, use `trace-function-background' instead. + +To untrace a function, use `untrace-function' or `untrace-all'." + (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'." - (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)) +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)) + +;;;###autoload +(defalias 'trace-function 'trace-function-foreground) (defun untrace-function (function) "Untraces FUNCTION and possibly activates all remaining advice. @@ -285,16 +316,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) diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 11256c294d9..699392fb349 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -1,6 +1,6 @@ ;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate -;; Copyright (C) 2002-2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index ab35d8f3d8f..4c20a0974d1 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -1,6 +1,6 @@ ;;; warnings.el --- log and display warnings -;; Copyright (C) 2002-2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal |