diff options
Diffstat (limited to 'lisp/emacs-lisp')
38 files changed, 0 insertions, 28980 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el deleted file mode 100644 index dabff28ae3a..00000000000 --- a/lisp/emacs-lisp/advice.el +++ /dev/null @@ -1,3960 +0,0 @@ -;;; advice.el --- an overloading mechanism for Emacs Lisp functions - -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Author: Hans Chalupsky <hans@cs.buffalo.edu> -;; Created: 12 Dec 1992 -;; Version: advice.el,v 2.14 1994/08/05 03:42:04 hans Exp -;; Keywords: extensions, lisp, tools - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; LCD Archive Entry: -;; advice|Hans Chalupsky|hans@cs.buffalo.edu| -;; Overloading mechanism for Emacs Lisp functions| -;; 1994/08/05 03:42:04|2.14|~/packages/advice.el.Z| - - -;;; 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. 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). - -;; @ Introduction: -;; =============== -;; This package implements a full-fledged Lisp-style advice mechanism -;; for Emacs Lisp. Advice is a clean and efficient way to modify the -;; behavior of Emacs Lisp functions without having to keep personal -;; modified copies of such functions around. A great number of such -;; modifications can be achieved by treating the original function as a -;; black box and specifying a different execution environment for it -;; with a piece of advice. Think of a piece of advice as a kind of fancy -;; hook that you can attach to any function/macro/subr. - -;; @ Highlights: -;; ============= -;; - Clean definition of multiple, named before/around/after advices -;; for functions, macros, subrs and special forms -;; - 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. -;; - 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 -;; efficient, via access macros -;; - Allows the specification of a different argument list for the advised -;; 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 -;; - 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. -;; - Forward redefinition is possible because around advice can be used to -;; completely redefine a function. -;; - A caching mechanism for advised definition provides for cheap deactivation -;; and reactivation of advised functions. -;; - Preactivation allows efficient construction and compilation of advised -;; definitions at file compile time without giving up the flexibility of -;; the advice mechanism. -;; - 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. - -;; @ 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 `";; @+"'). -;; -;; The four major sections of this file are: -;; -;; @ This initial information ...installation, customization etc. -;; @ Advice documentation: ...general documentation -;; @ Foo games: An advice tutorial ...teaches about Advice by example -;; @ Advice implementation: ...actual code, yeah!! -;; -;; The latter three are actual headings which you can search for -;; directly in case `outline-mode' doesn't work for you. - -;; @ 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: -;; + advised subrs that are called directly from other subrs or C-code -;; + advised subrs that got replaced with their byte-code during -;; byte-compilation (e.g., car) -;; + advised macros which were expanded during byte-compilation before -;; their advice was activated. - -;; @ Credits: -;; ========== -;; This package is an extension and generalization of packages such as -;; insert-hooks.el written by Noah S. Friedman, and advise.el written by -;; Raul J. Acevedo. Some ideas used in here come from these packages, -;; 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'. -;; -;; If you experience any strange behavior/errors etc. that you attribute to -;; Advice or to some ill-advised function do one of the following: - -;; - 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 problem you can reactivate advised functions with either `ad-activate', -;; `ad-activate-all', or `ad-start-advice'. `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. - -;; @ 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 -;; 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 -;; advised definitions during activation in case the byte-compiler is already -;; 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 -;; is just a joke: - -;;(defadvice switch-to-buffer (before existing-buffers-only activate) -;; "When called interactively switch to existing buffers only, unless -;;when called with a prefix argument." -;; (interactive -;; (list (read-buffer "Switch to buffer: " (other-buffer) -;; (null current-prefix-arg))))) -;; -;;(defadvice switch-to-buffer (around confirm-non-existing-buffers activate) -;; "Switch to non-existing buffers only upon confirmation." -;; (interactive "BSwitch to buffer: ") -;; (if (or (get-buffer (ad-get-arg 0)) -;; (y-or-n-p (format "`%s' does not exist, create? " (ad-get-arg 0)))) -;; ad-do-it)) -;; -;;(defadvice find-file (before existing-files-only activate) -;; "Find existing files only" -;; (interactive "fFind file: ")) -;; -;;(defadvice car (around interactive activate) -;; "Make `car' an interactive function." -;; (interactive "xCar of list: ") -;; ad-do-it -;; (if (interactive-p) -;; (message "%s" ad-return-value))) - - -;; @ Advice documentation: -;; ======================= -;; 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: FSF's version of Emacs with major version 19 -;; - 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 - keeper of Lemacs and creator of the optimizing -;; byte-compiler used in v19s. -;; - Advice: The name of this package. -;; - advices: Short for "pieces of advice". - -;; @@ Defining a piece of advice with `defadvice': -;; =============================================== -;; The main means of defining a piece of advice is the macro `defadvice', -;; there is no interactive way of specifying a piece of advice. A call to -;; `defadvice' has the following syntax which is similar to the syntax of -;; `defun/defmacro': -;; -;; (defadvice <function> (<class> <name> [<position>] [<arglist>] {<flags>}*) -;; [ [<documentation-string>] [<interactive-form>] ] -;; {<body-form>}* ) - -;; <function> is the name of the function/macro/subr to be advised. - -;; <class> is the class of the advice which has to be one of `before', -;; `around', `after', `activation' or `deactivation' (the last two allow -;; definition of special act/deactivation hooks). - -;; <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 -;; 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 -;; 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 -;; 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 -;; 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 then the first one (the one with the smallest position) -;; found in the list of before/around/after advices will be used. - -;; <flags> is a list of symbols that specify further information about the -;; advice. All flags can be specified with unambiguous initial substrings. -;; `activate': Specifies that the advice information of the advised -;; function should be activated right after this advice has been -;; defined. In forward advices `activate' will be ignored. -;; `protect': Specifies that this advice should be protected against -;; non-local exits and errors in preceding code/advices. -;; `compile': Specifies that the advised function should be byte-compiled. -;; This flag will be ignored unless `activate' is also specified. -;; `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 -;; 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). - -;; 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 -;; 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, -;; 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 -;; 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): - -;; ([macro] lambda <arglist> -;; [ [<advised-docstring>] [(interactive ...)] ] -;; (let (ad-return-value) -;; {<before-0-body-form>}* -;; .... -;; {<before-N-1-body-form>}* -;; {<around-0-body-form>}* -;; {<around-1-body-form>}* -;; .... -;; {<around-M-1-body-form>}* -;; (setq ad-return-value -;; <apply original definition to <arglist>>) -;; {<other-around-M-1-body-form>}* -;; .... -;; {<other-around-1-body-form>}* -;; {<other-around-0-body-form>}* -;; {<after-0-body-form>}* -;; .... -;; {<after-K-1-body-form>}* -;; ad-return-value)) - -;; Macros and special forms will be redefined as macros, hence the optional -;; [macro] in the beginning of the definition. - -;; <arglist> is either the argument list of the original function or the -;; first argument list defined in the list of before/around/after advices. -;; The values of <arglist> variables can be accessed/changed in the body of -;; an advice by simply referring to them by their original name, however, -;; more portable argument access macros are also provided (see below). For -;; subrs/special-forms for which neither explicit argument list definitions -;; are available, nor their documentation strings contain such definitions -;; (as they do v19s), `(&rest ad-subr-args)' will be used. - -;; <advised-docstring> is an optional, special documentation string which will -;; 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 -;; 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 -;; 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 -;; before/around/after advice to gain control over argument values that -;; were supplied interactively. -;; -;; 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 -;; 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. - -;; 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 -;; 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 -;; 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 -;; 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 -;; argument variables of the original function, or the names used in the -;; 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 -;; 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. - -;; 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 -;; by position regardless of how these actual argument get distributed onto -;; 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). - -;; Suppose the function `foo' is defined as -;; -;; (defun foo (x y &optional z &rest r) ....) -;; -;; and is then called with -;; -;; (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 -;; can access these arguments in a piece of advice with some of the -;; following macros (the arrows indicate what value they will return): - -;; (ad-get-arg 0) -> 0 -;; (ad-get-arg 1) -> 1 -;; (ad-get-arg 2) -> 2 -;; (ad-get-arg 3) -> 3 -;; (ad-get-args 2) -> (2 3 4 5 6) -;; (ad-get-args 4) -> (4 5 6) - -;; `(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 -;; 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, -;; -;; (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 -;; the list of actual arguments starting at <position> to <value-list-form>. -;; For example, -;; -;; (ad-set-args 0 '(5 4 3 2 1 0)) -;; -;; 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 -;; 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 -;; variable names directly. - -;; @@@ Accessing argument bindings of arbitrary functions: -;; ======================================================= -;; 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 -;; 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 -;; specifications can then be examined in the body of the advice. For -;; example, somewhere in an advice we could do this: -;; -;; (let* ((bindings ad-arg-bindings) -;; (firstarg (car bindings)) -;; (secondarg (car (cdr bindings)))) -;; ;; Print info about first argument -;; (print (format "%s=%s (%s)" -;; (ad-arg-binding-field firstarg 'name) -;; (ad-arg-binding-field firstarg 'value) -;; (ad-arg-binding-field firstarg 'type))) -;; ....) -;; -;; The `type' of an argument is either `required', `optional' or `rest'. -;; Wherever `ad-arg-bindings' appears a form will be inserted that evaluates -;; to the list of bindings, hence, in order to avoid multiple unnecessary -;; evaluations one should always bind it to some variable. - -;; @@@ Argument list mapping: -;; ========================== -;; 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. For example, somebody might specify -;; `(sym newdef)' as the argument list of `fset', while advice might use -;; `(&rest ad-subr-args)' as the argument list of the original function -;; (depending on what Emacs version is used). 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 list without having to know about the -;; exact structure of the original argument list as long as the new argument -;; list takes a compatible number/magnitude of actual arguments. - -;; @@@ Definition of subr argument lists: -;; ====================================== -;; When advice constructs the advised definition of a function it has to -;; know the argument list of the original function. For functions and macros -;; the argument list can be determined from the actual definition, however, -;; for subrs there is no such direct access available. In Lemacs and for some -;; subrs in Emacs-19 the argument list of a subr can be determined from -;; its documentation string, in a v18 Emacs even that is not possible. If -;; advice cannot at all determine the argument list of a subr it uses -;; `(&rest ad-subr-args)' which will always work but is inefficient because -;; it conses up arguments. The macro `ad-define-subr-args' can be used by -;; the advice programmer to explicitly tell advice about the argument list -;; of a certain subr, for example, -;; -;; (ad-define-subr-args 'fset '(sym newdef)) -;; -;; is used by advice itself to tell a v18 Emacs about the arguments of `fset'. -;; The following can be used to undo such a definition: -;; -;; (ad-undefine-subr-args 'fset) -;; -;; The argument list definition is stored on the property list of the subr -;; name symbol. When an argument list could be determined from the -;; documentation string it will be cached under that property. The general -;; mechanism for looking up the argument list of a subr is the following: -;; 1) look for a definition stored on the property list -;; 2) if that failed try to infer it from the documentation string and -;; if successful cache it on the property list -;; 3) otherwise use `(&rest ad-subr-args)' - -;; @@ 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' -;; 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. - -;; When a function gets first activated its original definition gets saved, -;; all defined and enabled pieces of advice will get combined with the -;; original definition, the resulting definition might get compiled depending -;; on some conditions described below, and then the function will get -;; redefined with the advised definition. This also means that undefined -;; functions cannot get activated even though they might be already advised. - -;; The advised definition will get compiled either if `ad-activate' was called -;; interactively with a prefix argument, or called explicitly with its second -;; argument as t, or, if `ad-default-compilation-action' justifies it according -;; to the current system state. If the advised definition was -;; constructed during "preactivation" (see below) then that definition will -;; be already compiled because it was constructed during byte-compilation of -;; 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 -;; `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 -;; definition, see the section on caching below). - -;; `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 -;; 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 -;; (temporarily) return to an un/advised state. - -;; @@@ Reasons for the separation of advice definition and activation: -;; =================================================================== -;; As already mentioned, advising happens in two stages: - -;; 1) definition of various pieces of advice -;; 2) activation of all advice currently defined and enabled - -;; 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 -;; 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 -;; 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). - -;; @@ 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 -;; 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. - -;; 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 - -;; at least in my opinion - these overloads would all be done with advice, -;; 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 -;; 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 -;; dependent on what pieces of advice are currently enabled. - -;; 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 -;; 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 -;; 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 -;; would disable a particular advice of the function `foo': -;; -;; (ad-disable-advice 'foo 'before 'my-advice) -;; -;; This call by itself only changes the flag, to get the proper effect in -;; the advised definition too one has to activate `foo' with -;; -;; (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 -;; 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-") -;; -;; and the following call would put that actually into effect: -;; -;; (ad-activate-regexp "^ange-ftp-") -;; -;; A saver way would have been to use -;; -;; (ad-update-regexp "^ange-ftp-") -;; -;; instead which would have only reactivated currently actively advised -;; functions, but not functions that were currently deactivated. 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 -;; `ad-enable-regexp' and then activate or update again. - -;; @@ Forward advice, automatic advice activation: -;; =============================================== -;; Because most Emacs Lisp packages are loaded on demand via an autoload -;; mechanism it is essential to be able to "forward advise" functions. -;; Otherwise, proper advice definition and activation would make it necessary -;; to preload every file that defines a certain function before it can be -;; advised, which would partly defeat the purpose of the advice mechanism. - -;; In the following, "forward advice" always implies its automatic activation -;; once a function gets defined, and not just the accumulation of advice -;; information for a possibly undefined function. - -;; 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. - -;; Automatic advice activation means, that whenever a function gets defined -;; with either `defun', `defmacro', `fset' 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 by -;; doint `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 -;; 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 -;; - see below). - -;; 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 -;; 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 -;; 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 -;; of compiled advised definitions that can be activated cheaply during -;; 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 -;; function plus the advice specified in this `defadvice' (even if it is -;; 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 -;; precompiled advised definition will be cached on the advised function's -;; 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. - -;; 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 -;; 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 -;; perfectly ok to load a file with a preactivating `defadvice' before the -;; 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 -;; file with the preactivating `defadvice' got compiled the original function -;; definition was available. - -;; TIPS: Here are some indications that a preactivation did not work the way -;; you intended it to work: -;; - Activation of the advised function takes longer than usual/expected -;; - The byte-compiler gets loaded while an advised function gets -;; activated -;; - `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 -;; 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 -;; activated check whether all calls to `ad-cache-id-verification-code' -;; 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 -;; 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 -;; that is available when the preconstructed definition gets activated, and -;; that was the only definition of that advice so far (`ad-add-advice' -;; catches advice redefinitions and clears the cache in such a case). -;; Catching that would make the cache verification too expensive. - -;; 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. - -;; @@ Advising macros and special forms 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. - -;; @@ Adding a piece of advice with `ad-add-advice': -;; ================================================= -;; The non-interactive function `ad-add-advice' can be used to add a piece of -;; advice to some function without using `defadvice'. This is useful if advice -;; has to be added somewhere by a function (also look at `ad-make-advice'). - -;; @@ 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 -;; 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). -;; 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: -;; -;; (defadvice file-x-last-fn (activation file-x-load-hook) -;; "Executed whenever file-x is loaded" -;; (if load-in-progress (message "Loaded file-x"))) -;; -;; 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 -;; 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'. - -;; @@ Summary of main advice concepts: -;; =================================== -;; - Definition: -;; A piece of advice gets defined with `defadvice' and added to the -;; `advice-info' property of a function. -;; - Enablement: -;; Every piece of advice has an enablement flag associated with it. Only -;; enabled advices are considered during construction of an advised -;; definition. -;; - Activation: -;; 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 -;; to date with the current state of advice without also activating -;; currently deactivated functions. -;; - Caching: -;; Is the saving of an advised definition and an identifying cache-id so -;; it can be reused, for example, for activation after deactivation. -;; - 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 -;; during activation without having to construct an advised definition -;; from scratch at runtime. - -;; @@ Summary of interactive advice manipulation functions: -;; ======================================================== -;; The following interactive functions can be used to manipulate the state -;; of advised functions (all of them support completion on function names, -;; advice classes and advice names): - -;; - ad-activate to activate the advice of a FUNCTION -;; - ad-deactivate to deactivate the advice of a FUNCTION -;; - ad-update to activate the advice of a FUNCTION unless it was not -;; yet activated or is currently deactivated. -;; - ad-unadvise deactivates a FUNCTION and removes all of its advice -;; information, hence, it cannot be activated again -;; - ad-recover tries to redefine a FUNCTION to its original definition and -;; discards all advice information (a low-level `ad-unadvise'). -;; Use only in emergencies. - -;; - ad-remove-advice removes a particular piece of advice of a FUNCTION. -;; You still have to do call `ad-activate' or `ad-update' to -;; activate the new state of advice. -;; - ad-enable-advice enables a particular piece of advice of a FUNCTION. -;; - ad-disable-advice disables a particular piece of advice of a FUNCTION. -;; - ad-enable-regexp maps over all currently advised functions and enables -;; every advice whose name contains a match for a regular -;; expression. -;; - ad-disable-regexp disables matching advices. - -;; - ad-activate-regexp activates all advised function with a matching advice -;; - ad-deactivate-regexp deactivates all advised function with matching advice -;; - ad-update-regexp updates all advised function with a matching advice -;; - ad-activate-all activates all advised functions -;; - ad-deactivate-all deactivates all advised functions -;; - ad-update-all updates all advised functions -;; - ad-unadvise-all unadvises all advised functions -;; - ad-recover-all recovers all advised functions - -;; - ad-compile byte-compiles a function/macro if it is compilable. - -;; @@ Summary of forms with special meanings when used within an advice: -;; ===================================================================== -;; ad-return-value name of the return value variable (get/settable) -;; ad-subr-args name of &rest argument variable used for advised -;; subrs whose actual argument list cannot be -;; determined (get/settable) -;; (ad-get-arg <pos>), (ad-get-args <pos>), -;; (ad-set-arg <pos> <value>), (ad-set-args <pos> <value-list>) -;; argument access text macros to get/set the values of -;; actual arguments at a certain position -;; ad-arg-bindings text macro that returns the actual names, values -;; and types of the arguments as a list of bindings. The -;; order of the bindings corresponds to the order of the -;; arguments. The individual fields of every binding (name, -;; value and type) can be accessed with the function -;; `ad-arg-binding-field' (see example above). -;; ad-do-it text macro that identifies the place where the original -;; or wrapped definition should go in an around advice - - -;; @ Foo games: An advice tutorial -;; =============================== -;; 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: -;; -;; (defun foo (x) -;; "Add 1 to X." -;; (1+ x)) -;; foo -;; -;; (foo 3) -;; 4 -;; -;; @@ Defining a simple piece of advice: -;; ===================================== -;; Now let's define the first piece of advice for `foo'. To do that we -;; use the macro `defadvice' which takes a function name, a list of advice -;; specifiers and a list of body forms as arguments. The first element of -;; the advice specifiers is the class of the advice, the second is its name, -;; the third its position and the rest are some flags. The class of our -;; first advice is `before', its name is `fg-add2', its position among the -;; currently defined before advices (none so far) is `first', and the advice -;; will be `activate'ed immediately. Advice names are global symbols, hence, -;; the name space conventions used for function names should be applied. All -;; advice names in this tutorial will be prefixed with `fg' for `Foo Games' -;; (because everybody has the right to be inconsistent all the function names -;; used in this tutorial do NOT follow this convention). -;; -;; In the body of an advice we can refer to the argument variables of the -;; original function by name. Here we add 1 to X so the effect of calling -;; `foo' will be to actually add 2. All of the advice definitions below only -;; have one body form for simplicity, but there is no restriction to that -;; extent. Every piece of advice can have a documentation string which will -;; be combined with the documentation of the original function. -;; -;; (defadvice foo (before fg-add2 first activate) -;; "Add 2 to X." -;; (setq x (1+ x))) -;; foo -;; -;; (foo 3) -;; 5 -;; -;; @@ Specifying the position of an advice: -;; ======================================== -;; Now we define the second before advice which will cancel the effect of -;; the previous advice. This time we specify the position as 0 which is -;; equivalent to `first'. A number can be used to specify the zero-based -;; position of an advice among the list of advices in the same class. This -;; time we already have one before advice hence the position specification -;; actually has an effect. So, after the following definition the position -;; of the previous advice will be 1 even though we specified it with `first' -;; above, the reason for this is that the position argument is relative to -;; the currently defined pieces of advice which by now has changed. -;; -;; (defadvice foo (before fg-cancel-add2 0 activate) -;; "Again only add 1 to X." -;; (setq x (1- x))) -;; foo -;; -;; (foo 3) -;; 4 -;; -;; @@ Redefining a piece of advice: -;; ================================ -;; Now we define an advice with the same class and same name but with a -;; different position. Defining an advice in a class in which an advice with -;; that name already exists is interpreted as a redefinition of that -;; particular advice, in which case the position argument will be ignored -;; and the previous position of the redefined piece of advice is used. -;; Advice flags can be specified with non-ambiguous initial substrings, hence, -;; from now on we'll use `act' instead of the verbose `activate'. -;; -;; (defadvice foo (before fg-cancel-add2 last act) -;; "Again only add 1 to X." -;; (setq x (1- x))) -;; foo -;; -;; @@ Assembly of advised documentation: -;; ===================================== -;; The documentation strings of the various pieces of advice are assembled -;; in order which shows that advice `fg-cancel-add2' is still the first -;; `before' advice even though we specified position `last' above: -;; -;; (documentation 'foo) -;; "Add 1 to X. -;; -;; This function is advised with the following advice(s): -;; -;; fg-cancel-add2 (before): -;; Again only add 1 to X. -;; -;; fg-add2 (before): -;; Add 2 to X." -;; -;; @@ Advising interactive behavior: -;; ================================= -;; We can make a function interactive (or change its interactive behavior) -;; by specifying an interactive form in one of the before or around -;; advices (there could also be body forms in this advice). The particular -;; definition always assigns 5 as an argument to X which gives us 6 as a -;; result when we call foo interactively: -;; -;; (defadvice foo (before fg-inter last act) -;; "Use 5 as argument when called interactively." -;; (interactive (list 5))) -;; foo -;; -;; (call-interactively 'foo) -;; 6 -;; -;; If more than one advice have an interactive declaration, then the one of -;; the advice with the smallest position will be used (before advices go -;; before around and after advices), hence, the declaration below does -;; not have any effect: -;; -;; (defadvice foo (before fg-inter2 last act) -;; (interactive (list 6))) -;; foo -;; -;; (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 -;; the original definition. It can shadow or establish bindings for the -;; original definition, and it can look at and manipulate the value returned -;; by the original function. The position of the special keyword `ad-do-it' -;; specifies where the code of the original function will be executed. The -;; keyword can appear multiple times which will result in multiple calls of -;; the original function in the resulting advised code. Note, that if we don't -;; specify a position argument (i.e., `first', `last' or a number), then -;; `first' (or 0) is the default): -;; -;; (defadvice foo (around fg-times-2 act) -;; "First double X." -;; (let ((x (* x 2))) -;; ad-do-it)) -;; foo -;; -;; (foo 3) -;; 7 -;; -;; Around advices are assembled like onion skins where the around advice -;; with position 0 is the outermost skin and the advice at the last position -;; is the innermost skin which is directly wrapped around the call of the -;; original definition of the function. Hence, after the next `defadvice' we -;; will first multiply X by 2 then add 1 and then call the original -;; definition (i.e., add 1 again): -;; -;; (defadvice foo (around fg-add-1 last act) -;; "Add 1 to X." -;; (let ((x (1+ x))) -;; ad-do-it)) -;; foo -;; -;; (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 -;; the advice immediately after its definition, and that's what we want in -;; most cases. However, if we define multiple pieces of advice for a single -;; function then activating every advice immediately is inefficient. A -;; better way to do this is to only activate the last defined advice. -;; For example: -;; -;; (defadvice foo (after fg-times-x) -;; "Multiply the result with X." -;; (setq ad-return-value (* ad-return-value x))) -;; foo -;; -;; This still yields the same result as before: -;; (foo 3) -;; 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 -;; `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 advised function will be changed accordingly: -;; -;; (defadvice foo (after fg-times-x-again act) -;; "Again multiply the result with X." -;; (setq ad-return-value (* ad-return-value x))) -;; foo -;; -;; Now the advices have an effect: -;; -;; (foo 3) -;; 72 -;; -;; @@ Protecting advice execution: -;; =============================== -;; Once in a while we define an advice to perform some cleanup action, -;; for example: -;; -;; (defadvice foo (after fg-cleanup last act) -;; "Do some cleanup." -;; (print "Let's clean up now!")) -;; foo -;; -;; However, in case of an error the cleanup won't be performed: -;; -;; (condition-case error -;; (foo t) -;; (error 'error-in-foo)) -;; error-in-foo -;; -;; To make sure a certain piece of advice gets executed even if some error or -;; non-local exit occurred in any preceding code, we can protect it by using -;; the `protect' keyword. (if any of the around advices is protected then the -;; whole around advice onion will be protected): -;; -;; (defadvice foo (after fg-cleanup prot act) -;; "Do some protected cleanup." -;; (print "Let's clean up now!")) -;; foo -;; -;; Now the cleanup form will be executed even in case of an error: -;; -;; (condition-case error -;; (foo t) -;; (error 'error-in-foo)) -;; "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 -;; that we want the resulting advised function to be byte-compiled -;; (`compile' will be ignored unless we also specified `activate'): -;; -;; (defadvice foo (after fg-cleanup prot act comp) -;; "Do some protected cleanup." -;; (print "Let's clean up now!")) -;; foo -;; -;; Now `foo' 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)) -;; -;; (foo 3) -;; "Let's clean up now!" -;; 72 -;; -;; @@ Enabling and disabling pieces of advice: -;; =========================================== -;; Once in a while it is desirable to temporarily disable a piece of advice -;; so that it won't be considered during activation, for example, if two -;; different packages advise the same function and one wants to temporarily -;; neutralize the effect of the advice of one of the packages. -;; -;; The following disables the after advice `fg-times-x' in the function `foo'. -;; All that does is to change a flag for this particular advice. All the -;; other information defining it will be left unchanged (e.g., its relative -;; position in this advice class, etc.). -;; -;; (ad-disable-advice 'foo 'after 'fg-times-x) -;; nil -;; -;; For this to have an effect we have to activate `foo': -;; -;; (ad-activate 'foo) -;; foo -;; -;; (foo 3) -;; "Let's clean up now!" -;; 24 -;; -;; If we want to disable all multiplication advices in `foo' we can use a -;; regular expression that matches the names of such advices. Actually, any -;; advice name that contains a match for the regular expression will be -;; called a match. A special advice class `any' can be used to consider -;; all advice classes: -;; -;; (ad-disable-advice 'foo 'any "^fg-.*times") -;; nil -;; -;; (ad-activate 'foo) -;; foo -;; -;; (foo 3) -;; "Let's clean up now!" -;; 5 -;; -;; To enable the disabled advice we could use either `ad-enable-advice' -;; similar to `ad-disable-advice', or as an alternative `ad-enable-regexp' -;; which will enable matching advices in ALL currently advised functions. -;; Hence, this can be used to dis/enable advices made by a particular -;; package to a set of functions as long as that package obeys standard -;; advice name conventions. We prefixed all advice names with `fg-', hence -;; the following will do the trick (`ad-enable-regexp' returns the number -;; of matched advices): -;; -;; (ad-enable-regexp "^fg-") -;; 9 -;; -;; The following will activate all currently active advised functions that -;; contain some advice matched by the regular expression. This is a save -;; way to update the activation of advised functions whose advice changed -;; in some way or other without accidentally also activating currently -;; deactivated functions: -;; -;; (ad-update-regexp "^fg-") -;; nil -;; -;; (foo 3) -;; "Let's clean up now!" -;; 72 -;; -;; Another use for the dis/enablement mechanism is to define a piece of advice -;; and keep it "dormant" until a particular condition is satisfied, i.e., until -;; then the advice will not be used during activation. The `disable' flag lets -;; one do that with `defadvice': -;; -;; (defadvice foo (before fg-1-more dis) -;; "Add yet 1 more." -;; (setq x (1+ x))) -;; foo -;; -;; (ad-activate 'foo) -;; foo -;; -;; (foo 3) -;; "Let's clean up now!" -;; 72 -;; -;; (ad-enable-advice 'foo 'before 'fg-1-more) -;; nil -;; -;; (ad-activate 'foo) -;; foo -;; -;; (foo 3) -;; "Let's clean up now!" -;; 160 -;; -;; @@ Caching: -;; =========== -;; Advised definitions get cached to allow efficient activation/deactivation -;; without having to reconstruct them if nothing in the advice-info of a -;; function has changed. The following idiom can be used to temporarily -;; 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)) -;; (lambda (x) ....) -;; -;; (ad-deactivate-regexp "^fg-") -;; nil -;; -;; (foo 3) -;; 4 -;; -;; (ad-activate-regexp "^fg-") -;; nil -;; -;; (eq old-definition (symbol-function 'foo)) -;; t -;; -;; (foo 3) -;; "Let's clean up now!" -;; 160 -;; -;; @@ 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: -;; -;; (defadvice bar (before fg-sub-1-more act) -;; "Subtract one more from X." -;; (setq x (1- x))) -;; bar -;; -;; `bar' is not yet defined: -;; (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'): -;; -;; (defun bar (x) -;; "Subtract 1 from X." -;; (1- x)) -;; bar -;; -;; (bar 4) -;; 2 -;; -;; Redefinition will activate any available advice if the value of -;; `ad-redefinition-action' is either `warn', `accept' or `discard': -;; -;; (defun bar (x) -;; "Subtract 2 from X." -;; (- x 2)) -;; bar -;; -;; (bar 4) -;; 1 -;; -;; @@ Preactivation: -;; ================= -;; Constructing advised definitions is moderately expensive, hence, it is -;; desirable to have a way to construct them at byte-compile time. -;; Preactivation is a mechanism that allows one to do that. -;; -;; (defun fie (x) -;; "Multiply X by 2." -;; (* x 2)) -;; fie -;; -;; (defadvice fie (before fg-times-4 preact) -;; "Multiply X by 4." -;; (setq x (* x 2))) -;; fie -;; -;; This advice did not affect `fie'... -;; -;; (fie 2) -;; 4 -;; -;; ...but it constructed a cached definition that will be used once `fie' gets -;; activated as long as its current advice state is the same as it was during -;; preactivation: -;; -;; (setq cached-definition (ad-get-cache-definition 'fie)) -;; (lambda (x) ....) -;; -;; (ad-activate 'fie) -;; fie -;; -;; (eq cached-definition (symbol-function 'fie)) -;; t -;; -;; (fie 2) -;; 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 -;; top-level forms other than `defun' or `defmacro', for example, -;; -;; (defun fg-defadvice-fum () -;; (defadvice fum (before fg-times-4 preact act) -;; "Multiply X by 4." -;; (setq x (* x 2)))) -;; fg-defadvice-fum -;; -;; So far, no `defadvice' for `fum' got executed, but when we compile -;; `fg-defadvice-fum' the `defadvice' will be expanded by the byte compiler. -;; In order for preactivation to be effective we have to have a proper -;; definition of `fum' around at preactivation time, hence, we define it now: -;; -;; (defun fum (x) -;; "Multiply X by 2." -;; (* x 2)) -;; fum -;; -;; Now we compile the defining function which will construct an advised -;; definition during expansion of the `defadvice', compile it and store it -;; as part of the compiled `fg-defadvice-fum': -;; -;; (ad-compile-function 'fg-defadvice-fum) -;; (lambda nil (byte-code ...)) -;; -;; `fum' is still completely unaffected: -;; -;; (fum 2) -;; 4 -;; -;; (ad-get-advice-info 'fum) -;; nil -;; -;; (fg-defadvice-fum) -;; fum -;; -;; Now the advised version of `fum' is compiled because the compiled definition -;; 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)) -;; -;; (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 -;; 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': -;; -;; (ad-unadvise 'fum) -;; (("fie") ("bar") ("foo") ...) -;; -;; And now define a new piece of advice: -;; -;; (defadvice fum (before fg-interactive act) -;; "Make fum interactive." -;; (interactive "nEnter x: ")) -;; 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 -;; is no tragedy, everything will work as expected just not as efficient, -;; because a new advised definition has to be constructed from scratch: -;; -;; (fg-defadvice-fum) -;; fum -;; -;; A new uncompiled advised definition got constructed: -;; -;; (ad-compiled-p (symbol-function 'fum)) -;; nil -;; -;; (fum 2) -;; 8 -;; -;; 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 -;; that's necessary is that the definition of the forward advised function is -;; available when the `defadvice' with the preactivation gets compiled. -;; -;; @@ Portable argument access: -;; ============================ -;; So far, we always used the actual argument variable names to access an -;; argument in a piece of advice. For many advice applications this is -;; perfectly ok and keeps advices simple. However, it decreases portability -;; of advices because it assumes specific argument variable names. For example, -;; 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. -;; -;; Argument access text macros allow one to access arguments of an advised -;; function in a portable way without having to worry about all these -;; possibilities. These macros will be translated into the proper access forms -;; at activation time, hence, argument access will be as efficient as if -;; the arguments had been used directly in the definition of the advice. -;; -;; (defun fuu (x y z) -;; "Add 3 numbers." -;; (+ x y z)) -;; fuu -;; -;; (fuu 1 1 1) -;; 3 -;; -;; Argument access macros specify actual arguments at a certain position. -;; Position 0 access the first actual argument, position 1 the second etc. -;; For example, the following advice adds 1 to each of the 3 arguments: -;; -;; (defadvice fuu (before fg-add-1-to-all act) -;; "Adds 1 to all arguments." -;; (ad-set-arg 0 (1+ (ad-get-arg 0))) -;; (ad-set-arg 1 (1+ (ad-get-arg 1))) -;; (ad-set-arg 2 (1+ (ad-get-arg 2)))) -;; fuu -;; -;; (fuu 1 1 1) -;; 6 -;; -;; Now suppose somebody redefines `fuu' with a rest argument. Our advice -;; will still work because we used access macros (note, that automatic -;; advice activation is still in effect, hence, the redefinition of `fuu' -;; will automatically activate all its advice): -;; -;; (defun fuu (&rest numbers) -;; "Add NUMBERS." -;; (apply '+ numbers)) -;; fuu -;; -;; (fuu 1 1 1) -;; 6 -;; -;; (fuu 1 1 1 1 1 1) -;; 9 -;; -;; What's important to notice is that argument access macros access actual -;; arguments regardless of how they got distributed onto argument variables. -;; In Emacs Lisp the semantics of an actual argument is determined purely -;; by position, hence, as long as nobody changes the semantics of what a -;; certain actual argument at a certain position means the access macros -;; will do the right thing. -;; -;; Because of &rest arguments we need a second kind of access macro that -;; can access all actual arguments starting from a certain position: -;; -;; (defadvice fuu (before fg-print-args act) -;; "Print all arguments." -;; (print (ad-get-args 0))) -;; fuu -;; -;; (fuu 1 2 3 4 5) -;; (1 2 3 4 5) -;; 18 -;; -;; (defadvice fuu (before fg-set-args act) -;; "Swaps 2nd and 3rd arg and discards all the rest." -;; (ad-set-args 1 (list (ad-get-arg 2) (ad-get-arg 1)))) -;; fuu -;; -;; (fuu 1 2 3 4 4 4 4 4 4) -;; (1 3 2) -;; 9 -;; -;; (defun fuu (x y z) -;; "Add 3 numbers." -;; (+ x y z)) -;; -;; (fuu 1 2 3) -;; (1 3 2) -;; 9 -;; -;; @@ Defining the argument list of an advised function: -;; ===================================================== -;; Once in a while it might be desirable to advise a function and additionally -;; give it an extra argument that controls the advised code, for example, one -;; might want to make an interactive function sensitive to a prefix argument. -;; For such cases `defadvice' allows the specification of an argument list -;; for the advised function. Similar to the redefinition of interactive -;; behavior, the first argument list specification found in the list of before/ -;; around/after advices will be used. Of course, the specified argument list -;; should be downward compatible with the original argument list, otherwise -;; functions that call the advised function with the original argument list -;; in mind will break. -;; -;; (defun fii (x) -;; "Add 1 to X." -;; (1+ x)) -;; fii -;; -;; Now we advise `fii' to use an optional second argument that controls the -;; amount of incrementation. A list following the (optional) position -;; argument of the advice will be interpreted as an argument list -;; specification. This means you cannot specify an empty argument list, and -;; why would you want to anyway? -;; -;; (defadvice fii (before fg-inc-x (x &optional incr) act) -;; "Increment X by INCR (default is 1)." -;; (setq x (+ x (1- (or incr 1))))) -;; fii -;; -;; (fii 3) -;; 4 -;; -;; (fii 3 2) -;; 5 -;; -;; @@ Specifying argument lists of subrs: -;; ====================================== -;; The argument lists of subrs cannot be determined directly from Lisp. -;; This means that Advice has to use `(&rest ad-subr-args)' as the -;; argument list of the advised subr which is not very efficient. In Lemacs -;; subr argument lists can be determined from their documentation string, in -;; Emacs-19 this is the case for some but not all subrs. To accommodate -;; for the cases where the argument lists cannot be determined (e.g., in a -;; v18 Emacs) Advice comes with a specification mechanism that allows the -;; advice programmer to tell advice what the argument list of a certain subr -;; really is. -;; -;; In a v18 Emacs the following will return the &rest idiom: -;; -;; (ad-arglist (symbol-function 'car)) -;; (&rest ad-subr-args) -;; -;; To tell advice what the argument list of `car' really is we -;; can do the following: -;; -;; (ad-define-subr-args 'car '(list)) -;; ((list)) -;; -;; Now `ad-arglist' will return the proper argument list (this method is -;; actually used by advice itself for the advised definition of `fset'): -;; -;; (ad-arglist (symbol-function 'car)) -;; (list) -;; -;; The defined argument list will be stored on the property list of the -;; subr name symbol. When advice looks for a subr argument list it first -;; checks for a definition on the property list, if that fails it tries -;; to infer it from the documentation string and caches it on the property -;; list if it was successful, otherwise `(&rest ad-subr-args)' will be used. -;; -;; @@ Advising interactive subrs: -;; ============================== -;; For the most part there is no difference between advising functions and -;; advising subrs. There is one situation though where one might have to write -;; slightly different advice code for subrs than for functions. This case -;; arises when one wants to access subr arguments in a before/around advice -;; when the arguments were determined by an interactive call to the subr. -;; Advice cannot determine what `interactive' form determines the interactive -;; behavior of the subr, hence, when it calls the original definition in an -;; interactive subr invocation it has to use `call-interactively' to generate -;; the proper interactive behavior. Thus up to that call the arguments of the -;; interactive subr will be nil. For example, the following advice for -;; `kill-buffer' will not work in an interactive invocation... -;; -;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp) -;; (my-before-kill-buffer-hook (ad-get-arg 0))) -;; kill-buffer -;; -;; ...because the buffer argument will be nil in that case. The way out of -;; this dilemma is to provide an `interactive' specification that mirrors -;; the interactive behavior of the unadvised subr, for example, the following -;; will do the right thing even when `kill-buffer' is called interactively: -;; -;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp) -;; (interactive "bKill buffer: ") -;; (my-before-kill-buffer-hook (ad-get-arg 0))) -;; kill-buffer -;; -;; @@ Advising macros: -;; =================== -;; Advising macros is slightly different because there are two significant -;; time points in the invocation of a macro: Expansion and evaluation time. -;; For an advised macro instead of evaluating the original definition we -;; use `macroexpand', that is, changing argument values and binding -;; environments by pieces of advice has an affect during macro expansion -;; but not necessarily during evaluation. In particular, any side effects -;; of pieces of advice will occur during macro expansion. To also affect -;; the behavior during evaluation time one has to change the value of -;; `ad-return-value' in a piece of after advice. For example: -;; -;; (defmacro foom (x) -;; (` (list (, x)))) -;; foom -;; -;; (foom '(a)) -;; ((a)) -;; -;; (defadvice foom (before fg-print-x act) -;; "Print the value of X." -;; (print x)) -;; foom -;; -;; The following works as expected because evaluation immediately follows -;; macro expansion: -;; -;; (foom '(a)) -;; (quote (a)) -;; ((a)) -;; -;; However, the printing happens during expansion (or byte-compile) time: -;; -;; (macroexpand '(foom '(a))) -;; (quote (a)) -;; (list (quote (a))) -;; -;; If we want it to happen during evaluation time we have to do the -;; following (first remove the old advice): -;; -;; (ad-remove-advice 'foom 'before 'fg-print-x) -;; nil -;; -;; (defadvice foom (after fg-print-x act) -;; "Print the value of X." -;; (setq ad-return-value -;; (` (progn (print (, x)) -;; (, ad-return-value))))) -;; foom -;; -;; (macroexpand '(foom '(a))) -;; (progn (print (quote (a))) (list (quote (a)))) -;; -;; (foom '(a)) -;; (a) -;; ((a)) -;; -;; While this method might seem somewhat cumbersome, it is very general -;; because it allows one to influence macro expansion as well as evaluation. -;; In general, advising macros should be a rather rare activity anyway, in -;; particular, because compile-time macro expansion takes away a lot of the -;; flexibility and effectiveness of the advice mechanism. Macros that were -;; compile-time expanded before the advice was activated will of course never -;; exhibit the advised behavior. -;; -;; @@ Advising special forms: -;; ========================== -;; Now for something that should be even more rare than advising macros: -;; Advising special forms. Because special forms are irregular in their -;; argument evaluation behavior (e.g., `setq' evaluates the second but not -;; the first argument) they have to be advised into macros. A dangerous -;; consequence of this is that the byte-compiler will not recognize them -;; as special forms anymore (well, in most cases) and use their expansion -;; rather than the proper byte-code. Also, because the original definition -;; of a special form cannot be `funcall'ed, `eval' has to be used instead -;; which is less efficient. -;; -;; MORAL: Do not advise special forms unless you are completely sure about -;; what you are doing (some of the forward advice behavior is -;; implemented via advice of the special forms `defun' and `defmacro'). -;; As a safety measure one should always do `ad-deactivate-all' before -;; one byte-compiles a file to avoid any interference of advised -;; special forms. -;; -;; Apart from the safety concerns advising special forms is not any different -;; from advising plain functions or subrs. - - -;;; Code: - -;; @ Advice implementation: -;; ======================== - -;; @@ 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") - - -(defmacro ad-lemacs-p () - ;;Expands into Non-nil constant if we run Lucid's version of Emacs-19. - ;;Unselected conditional code will be optimized away during compilation. - (string-match "Lucid" emacs-version)) - - -;; @@ Variable definitions: -;; ======================== - -(defconst ad-version "2.14") - -;;;###autoload -(defvar ad-redefinition-action 'warn - "*Defines what to do with redefinitions during Advice de/activation. -Redefinition occurs if a previously activated function that already has an -original definition associated with it gets redefined and then de/activated. -In such a case we can either accept the current definition as the new -original definition, discard the current definition and replace it with the -old original, or keep it and raise an error. The values `accept', `discard', -`error' or `warn' govern what will be done. `warn' is just like `accept' but -it additionally prints a warning message. All other values will be -interpreted as `error'.") - -;;;###autoload -(defvar ad-default-compilation-action 'maybe - "*Defines whether to compile advised definitions during activation. -A value of `always' will result in unconditional compilation, `never' will -always avoid compilation, `maybe' will compile if the byte-compiler is already -loaded, and `like-original' will compile if the original definition of the -advised function is compiled or a built-in function. Every other value will -be interpreted as `maybe'. This variable will only be considered if the -COMPILE argument of `ad-activate' was supplied as nil.") - - -;; @@ Some utilities: -;; ================== - -;; We don't want the local arguments to interfere with anything -;; referenced in the supplied functions => the cryptic casing: -(defun ad-substitute-tree (sUbTrEe-TeSt fUnCtIoN tReE) - ;;"Substitutes qualifying subTREEs with result of FUNCTION(subTREE). - ;;Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4) - ;;then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are - ;;allowed too. Once a qualifying subtree has been found its subtrees will - ;;not be considered anymore. (ad-substitute-tree 'atom 'identity tree) - ;;generates a copy of TREE." - (cond ((consp tReE) - (cons (if (funcall sUbTrEe-TeSt (car tReE)) - (funcall fUnCtIoN (car tReE)) - (if (consp (car tReE)) - (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN (car tReE)) - (car tReE))) - (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN (cdr tReE)))) - ((funcall sUbTrEe-TeSt tReE) - (funcall fUnCtIoN tReE)) - (t tReE))) - -;; this is just faster than `ad-substitute-tree': -(defun ad-copy-tree (tree) - ;;"Returns 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: -;; ========================== - -;; Advice information for a particular function is stored on the -;; advice-info property of the function symbol. It is stored as an -;; alist of the following format: -;; -;; ((active . t/nil) -;; (before adv1 adv2 ...) -;; (around adv1 adv2 ...) -;; (after adv1 adv2 ...) -;; (activation adv1 adv2 ...) -;; (deactivation adv1 adv2 ...) -;; (origname . <symbol fbound to origdef>) -;; (cache . (<advised-definition> . <id>))) - -;; List of currently advised though not necessarily activated functions -;; (this list is maintained as a completion table): -(defvar ad-advised-functions nil) - -(defmacro ad-pushnew-advised-function (function) - ;;"Add FUNCTION to `ad-advised-functions' unless its already there." - (` (if (not (assoc (symbol-name (, function)) ad-advised-functions)) - (setq ad-advised-functions - (cons (list (symbol-name (, function))) - ad-advised-functions))))) - -(defmacro ad-pop-advised-function (function) - ;;"Remove FUNCTION from `ad-advised-functions'." - (` (setq ad-advised-functions - (delq (assoc (symbol-name (, function)) ad-advised-functions) - 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]) - ;; BODY-FORM...) - ;;Also see `ad-dolist'. 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)) - -(defmacro ad-get-advice-info (function) - (` (get (, function) 'ad-advice-info))) - -(defmacro ad-set-advice-info (function advice-info) - (` (put (, function) 'ad-advice-info (, advice-info)))) - -(defmacro ad-copy-advice-info (function) - (` (ad-copy-tree (get (, function) 'ad-advice-info)))) - -(defmacro ad-is-advised (function) - ;;"Returns 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 function)) - -(defun ad-initialize-advice-info (function) - ;;"Initializes the advice info for FUNCTION. - ;;Assumes that FUNCTION has not yet been advised." - (ad-pushnew-advised-function function) - (ad-set-advice-info function (list (cons 'active nil)))) - -(defmacro ad-get-advice-info-field (function field) - ;;"Retrieves the value of the advice info FIELD of FUNCTION." - (` (cdr (assq (, field) (ad-get-advice-info (, function)))))) - -(defun ad-set-advice-info-field (function field value) - ;;"Destructively modifies VALUE of the advice info FIELD of FUNCTION." - (and (ad-is-advised function) - (cond ((assq field (ad-get-advice-info function)) - ;; A field with that name is already present: - (rplacd (assq field (ad-get-advice-info function)) value)) - (t;; otherwise, create a new field with that name: - (nconc (ad-get-advice-info function) - (list (cons field value))))))) - -;; Don't make this a macro so we can use it as a predicate: -(defun ad-is-active (function) - ;;"non-nil if FUNCTION is advised and activated." - (ad-get-advice-info-field function 'active)) - - -;; @@ Access fns for single pieces of advice and related predicates: -;; ================================================================= - -(defun ad-make-advice (name protect enable definition) - "Constructs single piece of advice to be stored in some advice-info. -NAME should be a non-nil symbol, PROTECT and ENABLE should each be -either t or nil, and DEFINITION should be a list of the form -`(advice lambda ARGLIST [DOCSTRING] [INTERACTIVE-FORM] BODY...)'." - (list name protect enable definition)) - -;; 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)) - -(defun ad-advice-set-enabled (advice flag) - (rplaca (cdr (cdr advice)) flag)) - -(defun ad-class-p (thing) - (memq thing ad-advice-classes)) -(defun ad-name-p (thing) - (and thing (symbolp thing))) -(defun ad-position-p (thing) - (or (natnump thing) - (memq thing '(first last)))) - - -;; @@ 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)))) - -(defun ad-has-redefining-advice (function) - ;;"True if FUNCTION's advice info defines at least 1 redefining advice. - ;;Redefining advices affect the construction of an advised definition." - (and (ad-is-advised function) - (or (ad-has-enabled-advice function 'before) - (ad-has-enabled-advice function 'around) - (ad-has-enabled-advice function 'after)))) - -(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) - (if (ad-get-advice-info-field function class) - (ad-do-return t))))) - -(defun ad-get-enabled-advices (function class) - ;;"Returns the list of enabled advices of FUNCTION in CLASS." - (let (enabled-advices) - (ad-dolist (advice (ad-get-advice-info-field function class)) - (if (ad-advice-enabled advice) - (setq enabled-advices (cons advice enabled-advices)))) - (reverse enabled-advices))) - - -;; @@ 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'. - -;; The functionality of the new `fset' is as follows: -;; -;; fset(sym,newdef) -;; assign NEWDEF to SYM -;; if (get SYM 'ad-advice-info) -;; ad-activate(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' 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' 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-on' by using `ad-with-auto-activation-disabled' where -;; appropriate, especially in a safe version of `fset'. - -;; For now define `ad-activate' to the dummy definition: -(defun ad-activate (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-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-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' 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 legal re/definition. If the -;; original was defined via fcell indirection then `origname' will be defined -;; just so. Hence, to get hold of the actual original definition of a function -;; we need to use `ad-real-orig-definition'. - -(defun ad-make-origname (function) - ;;"Makes name to be used to call the original FUNCTION." - (intern (format "ad-Orig-%s" function))) - -(defmacro ad-get-orig-definition (function) - (` (let ((origname (ad-get-advice-info-field (, function) 'origname))) - (if (fboundp origname) - (symbol-function origname))))) - -(defmacro ad-set-orig-definition (function definition) - (` (ad-safe-fset - (ad-get-advice-info-field function 'origname) (, definition)))) - -(defmacro ad-clear-orig-definition (function) - (` (fmakunbound (ad-get-advice-info-field (, function) 'origname)))) - - -;; @@ Interactive input functions: -;; =============================== - -(defun ad-read-advised-function (&optional prompt predicate default) - ;;"Reads name of advised function with completion from the minibuffer. - ;;An optional PROMPT will be used to prompt for the function. PREDICATE - ;;plays the same role as for `try-completion' (which see). DEFAULT will - ;;be returned on empty input (defaults to the first advised function for - ;;which PREDICATE returns non-nil)." - (if (null ad-advised-functions) - (error "ad-read-advised-function: There are no advised functions")) - (setq default - (or default - (ad-do-advised-functions (function) - (if (or (null predicate) - (funcall predicate function)) - (ad-do-return function))) - (error "ad-read-advised-function: %s" - "There are no qualifying advised functions"))) - (let* ((ad-pReDiCaTe predicate) - (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)))))) - t))) - (if (equal function "") - (if (ad-is-advised default) - default - (error "ad-read-advised-function: `%s' is not advised" default)) - (intern function)))) - -(defvar ad-advice-class-completion-table - (mapcar '(lambda (class) (list (symbol-name class))) - ad-advice-classes)) - -(defun ad-read-advice-class (function &optional prompt default) - ;;"Reads a legal advice class with completion from the minibuffer. - ;;An optional PROMPT will be used to prompt for the class. DEFAULT will - ;;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) - (if (ad-get-advice-info-field function class) - (ad-do-return class))) - (error "ad-read-advice-class: `%s' has no advices" function))) - (let ((class (completing-read - (format "%s(default %s) " (or prompt "Class: ") default) - ad-advice-class-completion-table nil t))) - (if (equal class "") - default - (intern class)))) - -(defun ad-read-advice-name (function class &optional prompt) - ;;"Reads name of existing advice of CLASS for FUNCTION with completion. - ;;An optional PROMPT is used to prompt for the name." - (let* ((name-completion-table - (mapcar (function (lambda (advice) - (list (symbol-name (ad-advice-name advice))))) - (ad-get-advice-info-field function class))) - (default - (if (null name-completion-table) - (error "ad-read-advice-name: `%s' has no %s advice" - function class) - (car (car name-completion-table)))) - (prompt (format "%s(default %s) " (or prompt "Name: ") default)) - (name (completing-read prompt name-completion-table nil t))) - (if (equal name "") - (intern default) - (intern name)))) - -(defun ad-read-advice-specification (&optional prompt) - ;;"Reads a complete function/class/name specification from minibuffer. - ;;The list of read symbols will be returned. The optional PROMPT will - ;;be used to prompt for the function." - (let* ((function (ad-read-advised-function prompt)) - (class (ad-read-advice-class function)) - (name (ad-read-advice-name function class))) - (list function class name))) - -;; Use previous regexp as a default: -(defvar ad-last-regexp "") - -(defun ad-read-regexp (&optional prompt) - ;;"Reads a regular expression from the minibuffer." - (let ((regexp (read-from-minibuffer - (concat (or prompt "Regular expression: ") - (if (equal ad-last-regexp "") "" - (format "(default \"%s\") " ad-last-regexp)))))) - (setq ad-last-regexp - (if (equal regexp "") ad-last-regexp regexp)))) - - -;; @@ Finding, enabling, adding and removing pieces of advice: -;; =========================================================== - -(defmacro ad-find-advice (function class name) - ;;"Finds the first advice of FUNCTION in CLASS with NAME." - (` (assq (, name) (ad-get-advice-info-field (, function) (, class))))) - -(defun ad-advice-position (function class name) - ;;"Returns position of first advice of FUNCTION in CLASS with NAME." - (let* ((found-advice (ad-find-advice function class name)) - (advices (ad-get-advice-info-field function class))) - (if found-advice - (- (length advices) (length (memq found-advice advices)))))) - -(defun ad-find-some-advice (function class name) - "Finds the first of FUNCTION's advices in CLASS matching NAME. -NAME can be a symbol or a regular expression matching part of an advice name. -If CLASS is `any' all legal advice classes will be checked." - (if (ad-is-advised function) - (let (found-advice) - (ad-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 - 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)))))) - -(defun ad-enable-advice-internal (function class name flag) - ;;"Sets enable FLAG of FUNCTION's advices in CLASS matching NAME. - ;;If NAME is a string rather than a symbol then it's interpreted as a regular - ;;expression and all advices whose name contain a match for it will be - ;;affected. If CLASS is `any' advices in all legal advice classes will be - ;;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) - (if (or (eq class 'any) (eq advice-class class)) - (ad-dolist (advice (ad-get-advice-info-field - function advice-class)) - (cond ((or (and (stringp name) - (string-match - name (symbol-name (ad-advice-name advice)))) - (eq name (ad-advice-name advice))) - (setq matched-advices (1+ matched-advices)) - (ad-advice-set-enabled advice flag)))))) - matched-advices))) - -(defun ad-enable-advice (function class name) - "Enables the advice of FUNCTION with CLASS and NAME." - (interactive (ad-read-advice-specification "Enable advice of: ")) - (if (ad-is-advised function) - (if (eq (ad-enable-advice-internal function class name t) 0) - (error "ad-enable-advice: `%s' has no %s advice matching `%s'" - function class name)) - (error "ad-enable-advice: `%s' is not advised" function))) - -(defun ad-disable-advice (function class name) - "Disables the advice of FUNCTION with CLASS and NAME." - (interactive (ad-read-advice-specification "Disable advice of: ")) - (if (ad-is-advised function) - (if (eq (ad-enable-advice-internal function class name nil) 0) - (error "ad-disable-advice: `%s' has no %s advice matching `%s'" - function class name)) - (error "ad-disable-advice: `%s' is not advised" function))) - -(defun ad-enable-regexp-internal (regexp class flag) - ;;"Sets enable FLAGs of all CLASS advices whose name contains a REGEXP match. - ;;If CLASS is `any' all legal advice classes are considered. The number of - ;;affected advices will be returned." - (let ((matched-advices 0)) - (ad-do-advised-functions (advised-function) - (setq matched-advices - (+ matched-advices - (or (ad-enable-advice-internal - advised-function class regexp flag) - 0)))) - matched-advices)) - -(defun ad-enable-regexp (regexp) - "Enables all advices with names that contain a match for REGEXP. -All currently advised functions will be considered." - (interactive - (list (ad-read-regexp "Enable advices via regexp: "))) - (let ((matched-advices (ad-enable-regexp-internal regexp 'any t))) - (if (interactive-p) - (message "%d matching advices enabled" matched-advices)) - matched-advices)) - -(defun ad-disable-regexp (regexp) - "Disables all advices with names that contain a match for REGEXP. -All currently advised functions will be considered." - (interactive - (list (ad-read-regexp "Disable advices via regexp: "))) - (let ((matched-advices (ad-enable-regexp-internal regexp 'any nil))) - (if (interactive-p) - (message "%d matching advices disabled" matched-advices)) - matched-advices)) - -(defun ad-remove-advice (function class name) - "Removes FUNCTION's advice with NAME from its advices in CLASS. -If such an advice was found it will be removed from the list of advices -in that CLASS." - (interactive (ad-read-advice-specification "Remove advice of: ")) - (if (ad-is-advised function) - (let* ((advice-to-remove (ad-find-advice function class name))) - (if advice-to-remove - (ad-set-advice-info-field - function class - (delq advice-to-remove (ad-get-advice-info-field function class))) - (error "ad-remove-advice: `%s' has no %s advice `%s'" - function class name))) - (error "ad-remove-advice: `%s' is not advised" function))) - -;;;###autoload -(defun ad-add-advice (function advice class position) - "Adds a piece of ADVICE to FUNCTION's list of advices in CLASS. -If FUNCTION already has one or more pieces of advice of the specified -CLASS then POSITION determines where the new piece will go. The value -of POSITION can either be `first', `last' or a number where 0 corresponds -to `first'. Numbers outside the range will be mapped to the closest -extreme position. If there was already a piece of ADVICE with the same -name, then the position argument will be ignored and the old advice -will be overwritten with the new one. - If the FUNCTION was not advised already, then its advice info will be -initialized. Redefining a piece of advice whose name is part of the cache-id -will clear the cache." - (cond ((not (ad-is-advised function)) - (ad-initialize-advice-info function) - (ad-set-advice-info-field - function 'origname (ad-make-origname function)))) - (let* ((previous-position - (ad-advice-position function class (ad-advice-name advice))) - (advices (ad-get-advice-info-field function class)) - ;; Determine a numerical position for the new advice: - (position (cond (previous-position) - ((eq position 'first) 0) - ((eq position 'last) (length advices)) - ((numberp position) - (max 0 (min position (length advices)))) - (t 0)))) - ;; Check whether we have to clear the cache: - (if (memq (ad-advice-name advice) (ad-get-cache-class-id function class)) - (ad-clear-cache function)) - (if previous-position - (setcar (nthcdr position advices) advice) - (if (= position 0) - (ad-set-advice-info-field function class (cons advice advices)) - (setcdr (nthcdr (1- position) advices) - (cons advice (nthcdr position advices))))))) - - -;; @@ Accessing and manipulating function definitions: -;; =================================================== - -(defmacro ad-macrofy (definition) - ;;"Takes a lambda function DEFINITION and makes a macro out of it." - (` (cons 'macro (, definition)))) - -(defmacro ad-lambdafy (definition) - ;;"Takes a macro function DEFINITION and makes a lambda out of it." - (` (cdr (, definition)))) - -;; There is no way to determine whether some subr is a special form or not, -;; hence we need this list (which is probably out of date): -(defvar ad-special-forms - (mapcar 'symbol-function - '(and catch cond condition-case defconst defmacro - defun defvar function if interactive let let* - or prog1 prog2 progn quote save-excursion - save-restriction save-window-excursion setq - setq-default unwind-protect while - with-output-to-temp-buffer))) - -(defmacro ad-special-form-p (definition) - ;;"non-nil if DEFINITION is a special form." - (list 'memq definition 'ad-special-forms)) - -(defmacro ad-interactive-p (definition) - ;;"non-nil if DEFINITION can be called interactively." - (list 'commandp definition)) - -(defmacro ad-subr-p (definition) - ;;"non-nil if DEFINITION is a subr." - (list 'subrp definition)) - -(defmacro ad-macro-p (definition) - ;;"non-nil if DEFINITION is a macro." - (` (eq (car-safe (, definition)) 'macro))) - -(defmacro ad-lambda-p (definition) - ;;"non-nil if DEFINITION is a lambda expression." - (` (eq (car-safe (, definition)) 'lambda))) - -;; see ad-make-advice for the format of advice definitions: -(defmacro ad-advice-p (definition) - ;;"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) - ;;"non-nil if DEFINITION is a compiled byte-code object." - (` (or (byte-code-function-p (, definition)) - (and (ad-macro-p (, definition)) - (byte-code-function-p (ad-lambdafy (, definition))))))) - -(defmacro ad-compiled-code (compiled-definition) - ;;"Returns the byte-code object of a COMPILED-DEFINITION." - (` (if (ad-macro-p (, compiled-definition)) - (ad-lambdafy (, compiled-definition)) - (, compiled-definition)))) - -(defun ad-lambda-expression (definition) - ;;"Returns the lambda expression of a function/macro/advice DEFINITION." - (cond ((ad-lambda-p definition) - definition) - ((ad-macro-p definition) - (ad-lambdafy definition)) - ((ad-advice-p definition) - (cdr definition)) - (t nil))) - -(defun ad-arglist (definition &optional name) - ;;"Returns 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." - (cond ((ad-compiled-p definition) - (aref (ad-compiled-code definition) 0)) - ((consp definition) - (car (cdr (ad-lambda-expression definition)))) - ((ad-subr-p definition) - (if name - (ad-subr-arglist name) - ;; otherwise get it from its printed representation: - (setq name (format "%s" definition)) - (string-match "^#<subr \\([^>]+\\)>$" name) - (ad-subr-arglist - (intern (substring name (match-beginning 1) (match-end 1)))))))) - -;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish -;; a defined empty arglist `(nil)' from an undefined arglist: -(defmacro ad-define-subr-args (subr arglist) - (` (put (, subr) 'ad-subr-arglist (list (, arglist))))) -(defmacro ad-undefine-subr-args (subr) - (` (put (, subr) 'ad-subr-arglist nil))) -(defmacro ad-subr-args-defined-p (subr) - (` (get (, subr) 'ad-subr-arglist))) -(defmacro ad-get-subr-args (subr) - (` (car (get (, subr) 'ad-subr-arglist)))) - -(defun ad-subr-arglist (subr-name) - ;;"Retrieve arglist of the subr with SUBR-NAME. - ;;Either use the one stored under the `ad-subr-arglist' property, - ;;or try to retrieve it from the docstring and cache it under - ;;that property, or otherwise use `(&rest ad-subr-args)'." - (cond ((ad-subr-args-defined-p subr-name) - (ad-get-subr-args subr-name)) - ;; says jwz: Should use this for Lemacs 19.8 and above: - ;;((fboundp 'subr-min-args) - ;; ...) - ;; says hans: I guess what Jamie means is that I should use the values - ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist - ;; without having to look it up via parsing the docstring, e.g., - ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an - ;; argument list. However, that won't work because there is no - ;; way to distinguish a subr with args `(a &optional b &rest c)' from - ;; one with args `(a &rest c)' using that mechanism. Also, the argument - ;; names from the docstring are more meaningful. Hence, I'll stick with - ;; the old way of doing things. - (t (let ((doc (or (ad-real-documentation subr-name t) ""))) - (cond ((string-match "^\\(([^\)]+)\\)\n?\\'" doc) - (ad-define-subr-args - subr-name - (cdr (car (read-from-string - (downcase - (substring doc - (match-beginning 1) - (match-end 1))))))) - (ad-get-subr-args subr-name)) - ;; this is the old format used before Emacs 19.24: - ((string-match - "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'" doc) - (ad-define-subr-args - subr-name - (car (read-from-string - doc (match-beginning 1) (match-end 1)))) - (ad-get-subr-args subr-name)) - (t '(&rest ad-subr-args))))))) - -(defun ad-docstring (definition) - ;;"Returns the unexpanded docstring of DEFINITION." - (let ((docstring - (if (ad-compiled-p definition) - (ad-real-documentation definition t) - (car (cdr (cdr (ad-lambda-expression definition))))))) - (if (or (stringp docstring) - (natnump docstring)) - docstring))) - -(defun ad-interactive-form (definition) - ;;"Returns the interactive form of DEFINITION." - (cond ((ad-compiled-p definition) - (and (commandp definition) - (list 'interactive (aref (ad-compiled-code definition) 5)))) - ((or (ad-advice-p definition) - (ad-lambda-p definition)) - (commandp (ad-lambda-expression definition))))) - -(defun ad-body-forms (definition) - ;;"Returns the list of body forms of DEFINITION." - (cond ((ad-compiled-p definition) - nil) - ((consp definition) - (nthcdr (+ (if (ad-docstring definition) 1 0) - (if (ad-interactive-form definition) 1 0)) - (cdr (cdr (ad-lambda-expression definition))))))) - -;; Matches the docstring of an advised definition. -;; The first group of the regexp matches the function name: -(defvar ad-advised-definition-docstring-regexp "^\\$ad-doc: \\(.+\\)\\$$") - -(defun ad-make-advised-definition-docstring (function) - ;; Makes 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 (also see the defadvice for `documentation'): - (format "$ad-doc: %s$" (prin1-to-string function))) - -(defun ad-advised-definition-p (definition) - ;;"non-nil if DEFINITION was generated from advice information." - (if (or (ad-lambda-p definition) - (ad-macro-p definition) - (ad-compiled-p definition)) - (let ((docstring (ad-docstring definition))) - (and (stringp docstring) - (string-match - ad-advised-definition-docstring-regexp docstring))))) - -(defun ad-definition-type (definition) - ;;"Returns symbol that describes the type of DEFINITION." - (if (ad-macro-p definition) - 'macro - (if (ad-subr-p definition) - (if (ad-special-form-p definition) - 'special-form - 'subr) - (if (or (ad-lambda-p definition) - (ad-compiled-p definition)) - 'function - (if (ad-advice-p definition) - 'advice))))) - -(defun ad-has-proper-definition (function) - ;;"True if FUNCTION is a symbol with a proper definition. - ;;For that it has to be fbound with a non-autoload definition." - (and (symbolp function) - (fboundp function) - (not (eq (car-safe (symbol-function function)) 'autoload)))) - -;; The following two are necessary for the sake of packages such as -;; ange-ftp which redefine functions via fcell indirection: -(defun ad-real-definition (function) - ;;"Finds FUNCTION's definition at the end of function cell indirection." - (if (ad-has-proper-definition function) - (let ((definition (symbol-function function))) - (if (symbolp definition) - (ad-real-definition definition) - definition)))) - -(defun ad-real-orig-definition (function) - ;;"Finds FUNCTION's real original definition starting from its `origname'." - (if (ad-is-advised function) - (ad-real-definition (ad-get-advice-info-field function 'origname)))) - -(defun ad-is-compilable (function) - ;;"True if FUNCTION has an interpreted definition that can be compiled." - (and (ad-has-proper-definition function) - (or (ad-lambda-p (symbol-function function)) - (ad-macro-p (symbol-function function))) - (not (ad-compiled-p (symbol-function function))))) - -(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 - (byte-compile function)))) - - -;; @@ Constructing advised definitions: -;; ==================================== -;; -;; Main design decisions about the form of advised definitions: -;; -;; A) How will original definitions be called? -;; B) What will argument lists of advised functions look like? -;; -;; Ad A) -;; I chose to use function indirection for all four types of original -;; definitions (functions, macros, subrs and special forms), i.e., create -;; a unique symbol `ad-Orig-<name>' which is fbound to the original -;; definition and call it according to type and arguments. Functions and -;; subrs that don't have any &rest arguments can be called directly in a -;; `(ad-Orig-<name> ....)' form. If they have a &rest argument we have to -;; use `apply'. Macros will be called with -;; `(macroexpand '(ad-Orig-<name> ....))', and special forms also need a -;; form like that with `eval' instead of `macroexpand'. -;; -;; Ad B) -;; Use original arguments where possible and `(&rest ad-subr-args)' -;; otherwise, even though this seems to be more complicated and less -;; uniform than a general `(&rest args)' approach. My reason to still -;; do it that way is that in most cases my approach leads to the more -;; efficient form for the advised function, and portability (e.g., to -;; make the same advice work regardless of whether something is a -;; function or a subr) can still be achieved with argument access macros. - - -(defun ad-prognify (forms) - (cond ((<= (length forms) 1) - (car forms)) - (t (cons 'progn forms)))) - -;; @@@ Accessing argument lists: -;; ============================= - -(defun ad-parse-arglist (arglist) - ;;"Parses ARGLIST into its required, optional and rest parameters. - ;;A three-element list is returned, where the 1st element is the list of - ;;required arguments, the 2nd is the list of optional arguments, and the 3rd - ;;is the name of an optional rest parameter (or nil)." - (let* (required optional rest) - (setq rest (car (cdr (memq '&rest arglist)))) - (if rest (setq arglist (reverse (cdr (memq '&rest (reverse arglist)))))) - (setq optional (cdr (memq '&optional arglist))) - (if optional - (setq required (reverse (cdr (memq '&optional (reverse arglist))))) - (setq required arglist)) - (list required optional rest))) - -(defun ad-retrieve-args-form (arglist) - ;;"Generates a form which evaluates into names/values/types of ARGLIST. - ;;When the form gets evaluated within a function with that argument list - ;;it will result in a list with one entry for each argument, where the - ;;first element of each entry is the name of the argument, the second - ;;element is its actual current value, and the third element is either - ;;`required', `optional' or `rest' depending on the type of the argument." - (let* ((parsed-arglist (ad-parse-arglist arglist)) - (rest (nth 2 parsed-arglist))) - (` (list - (,@ (mapcar (function - (lambda (req) - (` (list '(, req) (, req) 'required)))) - (nth 0 parsed-arglist))) - (,@ (mapcar (function - (lambda (opt) - (` (list '(, opt) (, opt) 'optional)))) - (nth 1 parsed-arglist))) - (,@ (if rest (list (` (list '(, rest) (, rest) 'rest))))) - )))) - -(defun ad-arg-binding-field (binding field) - (cond ((eq field 'name) (car binding)) - ((eq field 'value) (car (cdr binding))) - ((eq field 'type) (car (cdr (cdr binding)))))) - -(defun ad-list-access (position list) - (cond ((= position 0) list) - ((= position 1) (list 'cdr list)) - (t (list 'nthcdr position list)))) - -(defun ad-element-access (position list) - (cond ((= position 0) (list 'car list)) - ((= position 1) (` (car (cdr (, list))))) - (t (list 'nth position list)))) - -(defun ad-access-argument (arglist index) - ;;"Tells how to access ARGLIST's actual argument at position INDEX. - ;;For a required/optional arg it simply returns it, if a rest argument has - ;;to be accessed, it returns a list with the index and name." - (let* ((parsed-arglist (ad-parse-arglist arglist)) - (reqopt-args (append (nth 0 parsed-arglist) - (nth 1 parsed-arglist))) - (rest-arg (nth 2 parsed-arglist))) - (cond ((< index (length reqopt-args)) - (nth index reqopt-args)) - (rest-arg - (list (- index (length reqopt-args)) rest-arg))))) - -(defun ad-get-argument (arglist index) - ;;"Returns form to access ARGLIST's actual argument at position INDEX." - (let ((argument-access (ad-access-argument arglist index))) - (cond ((consp argument-access) - (ad-element-access - (car argument-access) (car (cdr argument-access)))) - (argument-access)))) - -(defun ad-set-argument (arglist index value-form) - ;;"Returns form to set ARGLIST's actual arg at INDEX to VALUE-FORM." - (let ((argument-access (ad-access-argument arglist index))) - (cond ((consp argument-access) - ;; should this check whether there actually is something to set? - (` (setcar (, (ad-list-access - (car argument-access) (car (cdr argument-access)))) - (, value-form)))) - (argument-access - (` (setq (, argument-access) (, value-form)))) - (t (error "ad-set-argument: No argument at position %d of `%s'" - index arglist))))) - -(defun ad-get-arguments (arglist index) - ;;"Returns form to access all actual arguments starting at position INDEX." - (let* ((parsed-arglist (ad-parse-arglist arglist)) - (reqopt-args (append (nth 0 parsed-arglist) - (nth 1 parsed-arglist))) - (rest-arg (nth 2 parsed-arglist)) - args-form) - (if (< index (length reqopt-args)) - (setq args-form (` (list (,@ (nthcdr index reqopt-args)))))) - (if rest-arg - (if args-form - (setq args-form (` (nconc (, args-form) (, rest-arg)))) - (setq args-form (ad-list-access (- index (length reqopt-args)) - rest-arg)))) - args-form)) - -(defun ad-set-arguments (arglist index values-form) - ;;"Makes form to assign elements of VALUES-FORM as actual ARGLIST args. - ;;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)) - (setq index (1+ index)) - (setq values-index (1+ values-index))) - (if (null set-forms) - (error "ad-set-arguments: No argument at position %d of `%s'" - index arglist) - (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)) - (car set-forms)) - ;; ...if we have more we have to bind it to a variable: - (` (let ((ad-vAlUeS (, values-form))) - (,@ (reverse set-forms)) - ;; work around the old backquote bug: - (, 'ad-vAlUeS))))))) - -(defun ad-insert-argument-access-forms (definition arglist) - ;;"Expands arg-access text macros in DEFINITION according to ARGLIST." - (ad-substitute-tree - (function - (lambda (form) - (or (eq form 'ad-arg-bindings) - (and (memq (car-safe form) - '(ad-get-arg ad-get-args ad-set-arg ad-set-args)) - (integerp (car-safe (cdr form))))))) - (function - (lambda (form) - (if (eq form 'ad-arg-bindings) - (ad-retrieve-args-form arglist) - (let ((accessor (car form)) - (index (car (cdr form))) - (val (car (cdr (ad-insert-argument-access-forms - (cdr form) arglist))))) - (cond ((eq accessor 'ad-get-arg) - (ad-get-argument arglist index)) - ((eq accessor 'ad-set-arg) - (ad-set-argument arglist index val)) - ((eq accessor 'ad-get-args) - (ad-get-arguments arglist index)) - ((eq accessor 'ad-set-args) - (ad-set-arguments arglist index val))))))) - definition)) - -;; @@@ Mapping argument lists: -;; =========================== -;; Here is the problem: -;; Suppose function foo was called with (foo 1 2 3 4 5), and foo has the -;; argument list (x y &rest z), and we want to call the function bar which -;; has argument list (a &rest b) with a combination of x, y and z so that -;; the effect is just as if we had called (bar 1 2 3 4 5) directly. -;; The mapping should work for any two argument lists. - -(defun ad-map-arglists (source-arglist target-arglist) - "Makes `funcall/apply' form to map SOURCE-ARGLIST to TARGET-ARGLIST. -The arguments supplied to TARGET-ARGLIST will be taken from SOURCE-ARGLIST just -as if they had been supplied to a function with TARGET-ARGLIST directly. -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))'." - (let* ((parsed-source-arglist (ad-parse-arglist source-arglist)) - (source-reqopt-args (append (nth 0 parsed-source-arglist) - (nth 1 parsed-source-arglist))) - (source-rest-arg (nth 2 parsed-source-arglist)) - (parsed-target-arglist (ad-parse-arglist target-arglist)) - (target-reqopt-args (append (nth 0 parsed-target-arglist) - (nth 1 parsed-target-arglist))) - (target-rest-arg (nth 2 parsed-target-arglist)) - (need-apply (and source-rest-arg target-rest-arg)) - (target-arg-index -1)) - ;; 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) - (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))) - (append target-reqopt-args - (and target-rest-arg - ;; If we have a rest arg gobble up - ;; remaining source args: - (nthcdr (length target-reqopt-args) - source-reqopt-args))))))))) - -(defun ad-make-mapped-call (source-arglist target-arglist target-function) - ;;"Makes 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: -;; =========================================== -;; New policy: The documentation string for an advised function will be built -;; at the time the advised `documentation' function is called. This has the -;; following advantages: -;; 1) command-key substitutions will automatically be correct -;; 2) No wasted string space due to big advised docstrings in caches or -;; compiled files that contain preactivations -;; The overall overhead for this should be negligible because people normally -;; don't lookup documentation for the same function over and over again. - -(defun ad-make-single-advice-docstring (advice class &optional style) - (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 (format "%s-advice `%s':%s%s" - (capitalize (symbol-name class)) (ad-advice-name advice) - (if advice-docstring "\n" "") - (or advice-docstring "")))))) - -(defun ad-make-advised-docstring (function &optional style) - ;;"Constructs 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 - ;;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)) - paragraphs advice-docstring) - (if origdoc (setq paragraphs (list origdoc))) - (if (not (eq style 'plain)) - (setq paragraphs (cons (concat "This " origtype " is advised.") - paragraphs))) - (ad-dolist (class ad-advice-classes) - (ad-dolist (advice (ad-get-enabled-advices function class)) - (setq advice-docstring - (ad-make-single-advice-docstring advice class style)) - (if advice-docstring - (setq paragraphs (cons advice-docstring paragraphs))))) - (if paragraphs - ;; separate paragraphs with blank lines: - (mapconcat 'identity (nreverse paragraphs) "\n\n")))) - -(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) - ;;"Finds first defined arglist in FUNCTION's redefining advices." - (ad-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))))) - -(defun ad-advised-interactive-form (function) - ;;"Finds first interactive form in FUNCTION's redefining advices." - (ad-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))))) - -;; @@@ Putting it all together: -;; ============================ - -(defun ad-make-advised-definition (function) - ;;"Generates an advised definition of FUNCTION from its advice info." - (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 (ad-interactive-p 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)) - (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) - ((ad-interactive-form origdef)) - ;; Otherwise we must have a subr: make it interactive if - ;; we have to and initialize required arguments in case - ;; it is called interactively: - (orig-interactive-p - (let ((reqargs (car (ad-parse-arglist advised-arglist)))) - (if reqargs - (` (interactive - '(, (make-list (length reqargs) nil)))) - '(interactive)))))) - (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 advised-interactive-form)) - ;; Check whether we were called interactively - ;; in order to do proper prompting: - (` (if (interactive-p) - (call-interactively '(, origname)) - (, (ad-make-mapped-call - orig-arglist advised-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))))) - - ;; 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 - orig-form - (ad-get-enabled-advices function 'before) - (ad-get-enabled-advices function 'around) - (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, - ;;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)))))) - - (setq after-forms - (if (and around-form-protected before-forms) - (` ((unwind-protect - (, (ad-prognify 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))))))) - - (setq definition - (` ((,@ (if (memq type '(macro special-form)) '(macro))) - lambda - (, 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-insert-argument-access-forms definition args))) - -;; This is needed for activation/deactivation hooks: -(defun ad-make-hook-form (function hook-name) - ;;"Makes hook-form from FUNCTION's advice bodies in class HOOK-NAME." - (let ((hook-forms - (mapcar (function (lambda (advice) - (ad-body-forms (ad-advice-definition advice)))) - (ad-get-enabled-advices function hook-name)))) - (if hook-forms - (ad-prognify (apply 'append hook-forms))))) - - -;; @@ Caching: -;; =========== -;; Generating an advised definition of a function is moderately expensive, -;; hence, it makes sense to cache it so we can reuse it in appropriate -;; circumstances. Of course, it only makes sense to reuse a cached -;; definition if the current advice and function definition state is the -;; same as it was at the time when the cached definition was generated. -;; For that purpose we associate every cache with an id so we can verify -;; if it is still valid at a certain point in time. This id mechanism -;; makes it possible to preactivate advised functions, write the compiled -;; advised definitions to a file and reuse them during the actual -;; activation without having to risk that the resulting definition will be -;; incorrect, well, almost. -;; -;; A cache id is a list with six elements: -;; 1) the list of names of enabled before advices -;; 2) the list of names of enabled around advices -;; 3) the list of names of enabled after advices -;; 4) the type of the original function (macro, subr, etc.) -;; 5) the arglist of the original definition (or t if it was equal to the -;; arglist of the cached definition) -;; 6) t if the interactive form of the original definition was equal to the -;; interactive form of the cached definition -;; -;; Here's how a cache can get invalidated or be incorrect: -;; A) a piece of advice used in the cache gets redefined -;; B) the current list of enabled advices is different from the ones used -;; for the cache -;; C) the type of the original function changed, e.g., a function became a -;; macro, or a subr became a function -;; D) the arglist of the original function changed -;; E) the interactive form of the original function changed -;; F) a piece of advice used in the cache got redefined before the -;; defadvice with the cached definition got loaded: This is a PROBLEM! -;; -;; Cases A and B are the normal ones. A is taken care of by `ad-add-advice' -;; which clears the cache in such a case, B is easily checked during -;; verification at activation time. -;; -;; Cases C, D and E have to be considered if one is slightly paranoid, i.e., -;; if one considers the case that the original function could be different -;; from the one available at caching time (e.g., for forward advice of -;; functions that get redefined by some packages - such as `eval-region' gets -;; redefined by edebug). All these cases can be easily checked during -;; verification. Element 4 of the id lets one check case C, element 5 takes -;; care of case D (using t in the equality case saves some space, because the -;; arglist can be recovered at validation time from the cached definition), -;; and element 6 takes care of case E which is only a problem if the original -;; was actually a function whose interactive form was not overridden by a -;; piece of advice. -;; -;; Case F is the only one which will lead to an incorrect advised function. -;; There is no way to avoid this without storing the complete advice definition -;; in the cache-id which is not feasible. -;; -;; The cache-id of a typical advised function with one piece of advice and -;; no arglist redefinition takes 7 conses which is a small price to pay for -;; the added efficiency. The validation itself is also pretty cheap, certainly -;; a lot cheaper than reconstructing an advised definition. - -(defmacro ad-get-cache-definition (function) - (` (car (ad-get-advice-info-field (, function) 'cache)))) - -(defmacro ad-get-cache-id (function) - (` (cdr (ad-get-advice-info-field (, function) 'cache)))) - -(defmacro ad-set-cache (function definition id) - (` (ad-set-advice-info-field - (, function) 'cache (cons (, definition) (, id))))) - -(defun ad-clear-cache (function) - "Clears a previously cached advised definition of FUNCTION. -Clear the cache if you want to force `ad-activate' to construct a new -advised definition from scratch." - (interactive - (list (ad-read-advised-function "Clear cached definition of: "))) - (ad-set-advice-info-field function 'cache nil)) - -(defun ad-make-cache-id (function) - ;;"Generates 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))) - (ad-get-enabled-advices function 'before)) - (mapcar (function (lambda (advice) (ad-advice-name advice))) - (ad-get-enabled-advices function 'around)) - (mapcar (function (lambda (advice) (ad-advice-name advice))) - (ad-get-enabled-advices function 'after)) - (ad-definition-type original-definition) - (if (equal (ad-arglist original-definition function) - (ad-arglist cached-definition)) - t - (ad-arglist original-definition function)) - (if (eq (ad-definition-type original-definition) 'function) - (equal (ad-interactive-form original-definition) - (ad-interactive-form cached-definition)))))) - -(defun ad-get-cache-class-id (function class) - ;;"Returns the part of FUNCTION's cache id that identifies CLASS." - (let ((cache-id (ad-get-cache-id function))) - (if (eq class 'before) - (car cache-id) - (if (eq class 'around) - (nth 1 cache-id) - (nth 2 cache-id))))) - -(defun ad-verify-cache-class-id (cache-class-id advices) - (ad-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))))) - -;; 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 -;; not. Right now the only way to find out is to trace -;; `ad-cache-id-verification-code'. The code it returns indicates where the -;; verification failed. Tracing `ad-verify-cache-class-id' might provide -;; some additional useful information. - -(defun ad-cache-id-verification-code (function) - (let ((cache-id (ad-get-cache-id function)) - (code 'before-advice-mismatch)) - (and (ad-verify-cache-class-id - (car cache-id) (ad-get-advice-info-field function 'before)) - (setq code 'around-advice-mismatch) - (ad-verify-cache-class-id - (nth 1 cache-id) (ad-get-advice-info-field function 'around)) - (setq code 'after-advice-mismatch) - (ad-verify-cache-class-id - (nth 2 cache-id) (ad-get-advice-info-field function 'after)) - (setq code 'definition-type-mismatch) - (let ((original-definition (ad-real-orig-definition function)) - (cached-definition (ad-get-cache-definition function))) - (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) - (nth 4 cache-id) ) - (ad-arglist cached-definition)) - (setq code 'interactive-form-mismatch) - (or (null (nth 5 cache-id)) - (equal (ad-interactive-form original-definition) - (ad-interactive-form cached-definition))) - (setq code 'verified)))) - code)) - -(defun ad-verify-cache-id (function) - ;;"True if FUNCTION's cache-id is compatible with its current advices." - (eq (ad-cache-id-verification-code function) 'verified)) - - -;; @@ Preactivation: -;; ================= -;; Preactivation can be used to generate compiled advised definitions -;; at compile time without having to give up the dynamic runtime flexibility -;; of the advice mechanism. Preactivation is a special feature of `defadvice', -;; it involves the following steps: -;; - remembering the function's current state (definition and advice-info) -;; - advising it with the defined piece of advice -;; - clearing its cache -;; - generating an interpreted advised definition by activating it, this will -;; make use of all its current active advice and its current definition -;; - saving the so generated cached definition and id -;; - resetting the function's advice and definition state to what it was -;; before the preactivation -;; - Returning the saved definition and its id to be used in the expansion of -;; `defadvice' to assign it as an initial cache, hence it will be compiled -;; at time the `defadvice' gets compiled. -;; Naturally, for preactivation to be effective it has to be applied/compiled -;; at the right time, i.e., when the current state of advices and function -;; definition exactly reflects the state at activation time. Should that not -;; be the case, the precompiled definition will just be discarded and a new -;; advised definition will be generated. - -(defun ad-preactivate-advice (function advice class position) - ;;"Preactivates FUNCTION and returns the constructed cache." - (let* ((function-defined-p (fboundp function)) - (old-definition - (if function-defined-p - (symbol-function function))) - (old-advice-info (ad-copy-advice-info function)) - (ad-advised-functions ad-advised-functions)) - (unwind-protect - (progn - (ad-add-advice function advice class position) - (ad-enable-advice function class (ad-advice-name advice)) - (ad-clear-cache function) - (ad-activate-on function -1) - (if (and (ad-is-active function) - (ad-get-cache-definition function)) - (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)))))))) - - -;; @@ Activation and definition handling: -;; ====================================== - -(defun ad-should-compile (function compile) - ;;"Returns non-nil if the advised FUNCTION should be compiled. - ;;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)))))) - -(defun ad-activate-advised-definition (function compile) - ;;"Redefines 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))) - (if (ad-should-compile function compile) - (ad-compile-function function)) - (if verified-cached-definition - (if (not (eq verified-cached-definition (symbol-function function))) - ;; we must have compiled, cache the compiled definition: - (ad-set-cache - function (symbol-function function) (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 function) (ad-make-cache-id function))))) - -(defun ad-handle-definition (function) - "Handles 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 -original definition. If no current definition is available (even in the -case of undefinition) nothing will be done. In the case of redefinition -the action taken depends on the value of `ad-redefinition-action' (which -see). Redefinition occurs when FUNCTION already has an original definition -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)))) - (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 (memq ad-redefinition-action '(accept discard warn))) - (error "ad-handle-definition (see its doc): `%s' %s" - function "illegally redefined") - (if (eq ad-redefinition-action 'discard) - (ad-safe-fset function original-definition) - (ad-set-orig-definition function current-definition) - (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)))) - - -;; @@ The top-level advice interface: -;; ================================== - -(defun ad-activate-on (function &optional compile) - "Activates all the advice information of an advised FUNCTION. -If FUNCTION has a proper original definition then an advised -definition will be generated from FUNCTION's advice info and the -definition of FUNCTION will be replaced with it. If a previously -cached advised definition was available, it will be used. -The optional COMPILE argument determines whether the resulting function -or a compilable cached definition will be compiled. If it is negative -no compilation will be performed, if it is positive or otherwise non-nil -the resulting function will be compiled, if it is nil the behavior depends -on the value of `ad-default-compilation-action' (which see). -Activation of an advised function that has an advice info but no actual -pieces of advice is equivalent to a call to `ad-unadvise'. Activation of -an advised function that has actual pieces of advice but none of them are -enabled is equivalent to a call to `ad-deactivate'. The current advised -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-on': - (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))))))))) - -(defun ad-deactivate (function) - "Deactivates the advice of an actively advised FUNCTION. -If FUNCTION has a proper original definition, then the current -definition of FUNCTION will be replaced with it. All the advice -information will still be available so it can be activated again with -a call to `ad-activate'." - (interactive - (list (ad-read-advised-function "Deactivate advice of: " 'ad-is-active))) - (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-set-advice-info-field function 'active nil) - (eval (ad-make-hook-form function 'deactivation)) - function))))) - -(defun ad-update (function &optional compile) - "Update the advised definition of FUNCTION if its advice is active. -See `ad-activate-on' for documentation on the optional COMPILE argument." - (interactive - (list (ad-read-advised-function - "Update advised definition of: " 'ad-is-active))) - (if (ad-is-active function) - (ad-activate-on function compile))) - -(defun ad-unadvise (function) - "Deactivates FUNCTION and then removes all its advice information. -If FUNCTION was not advised this will be a noop." - (interactive - (list (ad-read-advised-function "Unadvise function: "))) - (cond ((ad-is-advised function) - (if (ad-is-active function) - (ad-deactivate function)) - (ad-clear-orig-definition function) - (ad-set-advice-info function nil) - (ad-pop-advised-function function)))) - -(defun ad-recover (function) - "Tries to recover FUNCTION's original definition and unadvises it. -This is more low-level than `ad-unadvise' because it does not do any -deactivation which might run hooks and get into other trouble. -Use in emergencies." - ;; Use more primitive interactive behavior here: Accept any symbol that's - ;; currently defined in obarray, not necessarily with a function definition: - (interactive - (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-set-advice-info function nil) - (ad-pop-advised-function function)))) - -(defun ad-activate-regexp (regexp &optional compile) - "Activates functions with an advice name containing a REGEXP match. -See `ad-activate-on' for documentation on the optional COMPILE argument." - (interactive - (list (ad-read-regexp "Activate via advice regexp: ") - current-prefix-arg)) - (ad-do-advised-functions (function) - (if (ad-find-some-advice function 'any regexp) - (ad-activate-on function compile)))) - -(defun ad-deactivate-regexp (regexp) - "Deactivates functions with an advice name containing REGEXP match." - (interactive - (list (ad-read-regexp "Deactivate via advice regexp: "))) - (ad-do-advised-functions (function) - (if (ad-find-some-advice function 'any regexp) - (ad-deactivate function)))) - -(defun ad-update-regexp (regexp &optional compile) - "Updates functions with an advice name containing a REGEXP match. -See `ad-activate-on' for documentation on the optional COMPILE argument." - (interactive - (list (ad-read-regexp "Update via advice regexp: ") - current-prefix-arg)) - (ad-do-advised-functions (function) - (if (ad-find-some-advice function 'any regexp) - (ad-update function compile)))) - -(defun ad-activate-all (&optional compile) - "Activates all currently advised functions. -See `ad-activate-on' for documentation on the optional COMPILE argument." - (interactive "P") - (ad-do-advised-functions (function) - (ad-activate-on function compile))) - -(defun ad-deactivate-all () - "Deactivates all currently advised functions." - (interactive) - (ad-do-advised-functions (function) - (ad-deactivate function))) - -(defun ad-update-all (&optional compile) - "Updates all currently advised functions. -With prefix argument compiles resulting advised definitions." - (interactive "P") - (ad-do-advised-functions (function) - (ad-update function compile))) - -(defun ad-unadvise-all () - "Unadvises all currently advised functions." - (interactive) - (ad-do-advised-functions (function) - (ad-unadvise function))) - -(defun ad-recover-all () - "Recovers all currently advised functions. Use in emergencies." - (interactive) - (ad-do-advised-functions (function) - (condition-case nil - (ad-recover function) - (error nil)))) - - -;; Completion alist of legal `defadvice' flags -(defvar ad-defadvice-flags - '(("protect") ("disable") ("activate") - ("compile") ("preactivate") ("freeze"))) - -;;;###autoload -(defmacro defadvice (function args &rest body) - "Defines a piece of advice for FUNCTION (a symbol). -The syntax of `defadvice' is as follows: - - (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) - [DOCSTRING] [INTERACTIVE-FORM] - BODY... ) - -FUNCTION ::= Name of the function to be advised. -CLASS ::= `before' | `around' | `after' | `activation' | `deactivation'. -NAME ::= Non-nil symbol that names this piece of advice. -POSITION ::= `first' | `last' | NUMBER. Optional, defaults to `first', - see also `ad-add-advice'. -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'. - 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 - function. The first one found in before/around/after-advices will be used. -BODY ::= Any s-expression. - -Semantics of the various flags: -`protect': The piece of advice will be protected against non-local exits in -any code that precedes it. If any around-advice of a function is protected -then automatically all around-advices will be protected (the complete onion). - -`activate': All advice of FUNCTION will be activated immediately if -FUNCTION has been properly defined prior to this application of `defadvice'. - -`compile': In conjunction with `activate' specifies that the resulting -advised function should be compiled. - -`disable': The defined advice will be disabled, hence, it will not be used -during activation until somebody enables it. - -`preactivate': Preactivates the advised FUNCTION at macro-expansion/compile -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. - -Look at the file `advice.el' for comprehensive documentation." - (if (not (ad-name-p function)) - (error "defadvice: Illegal function name: %s" function)) - (let* ((class (car args)) - (name (if (not (ad-class-p class)) - (error "defadvice: Illegal advice class: %s" class) - (nth 1 args))) - (position (if (not (ad-name-p name)) - (error "defadvice: Illegal advice name: %s" name) - (setq args (nthcdr 2 args)) - (if (ad-position-p (car args)) - (prog1 (car args) - (setq args (cdr args)))))) - (arglist (if (listp (car args)) - (prog1 (car args) - (setq args (cdr args))))) - (flags - (mapcar - (function - (lambda (flag) - (let ((completion - (try-completion (symbol-name flag) ad-defadvice-flags))) - (cond ((eq completion t) flag) - ((assoc completion ad-defadvice-flags) - (intern completion)) - (t (error "defadvice: Illegal or ambiguous flag: %s" - flag)))))) - args)) - (advice (ad-make-advice - name (memq 'protect flags) - (not (memq 'disable flags)) - (` (advice lambda (, arglist) (,@ body))))) - (preactivation (if (memq 'preactivate flags) - (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-on '(, function) - (, (if (memq 'compile flags) t))))))) - '(, function)))))) - - -;; @@ Tools: -;; ========= - -(defmacro ad-with-originals (functions &rest body) - "Binds FUNCTIONS to their original definitions and executes BODY. -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." - (let* ((index -1) - ;; Make let-variables to store current definitions: - (current-bindings - (mapcar (function - (lambda (function) - (setq index (1+ index)) - (list (intern (format "ad-oRiGdEf-%d" index)) - (` (symbol-function '(, function)))))) - functions))) - (` (let (, current-bindings) - (unwind-protect - (progn - (,@ (progn - ;; 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))) - (,@ 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)) - - -;; @@ Advising `documentation': -;; ============================ -;; Use the advice mechanism to advise `documentation' to make it -;; generate proper documentation strings for advised definitions: - -(defadvice documentation (after ad-advised-docstring first disable preact) - "Builds an advised docstring if FUNCTION is advised." - ;; Because we get the function name from the advised docstring - ;; this will work for function names as well as for definitions: - (if (and (stringp ad-return-value) - (string-match - ad-advised-definition-docstring-regexp ad-return-value)) - (let ((function - (car (read-from-string - ad-return-value (match-beginning 1) (match-end 1))))) - (cond ((ad-is-advised function) - (setq ad-return-value (ad-make-advised-docstring function)) - ;; Handle optional `raw' argument: - (if (not (ad-get-arg 1)) - (setq ad-return-value - (substitute-command-keys ad-return-value)))))))) - - -;; @@ Starting, stopping and recovering from the advice package magic: -;; =================================================================== - -(defun ad-start-advice () - "Starts the automatic advice handling magic." - (interactive) - ;; Advising `ad-activate' means death!! - (ad-set-advice-info 'ad-activate nil) - (ad-safe-fset 'ad-activate 'ad-activate-on) - (ad-enable-advice 'documentation 'after 'ad-advised-docstring) - (ad-activate-on 'documentation 'compile)) - -(defun ad-stop-advice () - "Stops the automatic advice handling magic. -You should only need this in case of Advice-related emergencies." - (interactive) - ;; Advising `ad-activate' means death!! - (ad-set-advice-info 'ad-activate nil) - (ad-disable-advice 'documentation 'after 'ad-advised-docstring) - (ad-update 'documentation) - (ad-safe-fset 'ad-activate 'ad-activate-off)) - -(defun ad-recover-normality () - "Undoes all advice related redefinitions and unadvises everything. -Use only in REAL emergencies." - (interactive) - ;; Advising `ad-activate' means death!! - (ad-set-advice-info 'ad-activate nil) - (ad-safe-fset 'ad-activate 'ad-activate-off) - (ad-recover-all) - (setq ad-advised-functions nil)) - -;; Until the Advice-related changes to `data.c' are part of Lemacs we -;; have to load the old implementation of advice activation hooks: -(if (ad-lemacs-p) - (require 'ad-hooks)) - -(ad-start-advice) - -(provide 'advice) - -;;; advice.el ends here diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el deleted file mode 100644 index 997badc1732..00000000000 --- a/lisp/emacs-lisp/assoc.el +++ /dev/null @@ -1,140 +0,0 @@ -;;; assoc.el --- insert/delete/sort functions on association lists - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: Barry A. Warsaw <bwarsaw@cen.com> -;; Keywords: extensions - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Association list utilities providing insertion, deletion, sorting -;; fetching off key-value pairs in association lists. - -;;; Code: - -(defun asort (alist-symbol key) - "Move a specified key-value pair to the head of an alist. -The alist is referenced by ALIST-SYMBOL. Key-value pair to move to -head is one matching KEY. Returns the sorted list and doesn't affect -the order of any other key-value pair. Side effect sets alist to new -sorted list." - (set alist-symbol - (sort (copy-alist (eval alist-symbol)) - (function (lambda (a b) (equal (car a) key)))))) - - -(defun aelement (key value) - "Makes a list of a cons cell containing car of KEY and cdr of VALUE. -The returned list is suitable as an element of an alist." - (list (cons key value))) - - -(defun aheadsym (alist) - "Return the key symbol at the head of ALIST." - (car (car alist))) - - -(defun anot-head-p (alist key) - "Find out if a specified key-value pair is not at the head of an alist. -The alist to check is specified by ALIST and the key-value pair is the -one matching the supplied KEY. Returns nil if ALIST is nil, or if -key-value pair is at the head of the alist. Returns t if key-value -pair is not at the head of alist. ALIST is not altered." - (not (equal (aheadsym alist) key))) - - -(defun aput (alist-symbol key &optional value) - "Inserts a key-value pair into an alist. -The alist is referenced by ALIST-SYMBOL. The key-value pair is made -from KEY and optionally, VALUE. Returns the altered alist or nil if -ALIST is nil. - -If the key-value pair referenced by KEY can be found in the alist, and -VALUE is supplied non-nil, then the value of KEY will be set to VALUE. -If VALUE is not supplied, or is nil, the key-value pair will not be -modified, but will be moved to the head of the alist. If the key-value -pair cannot be found in the alist, it will be inserted into the head -of the alist (with value nil if VALUE is nil or not supplied)." - (let ((elem (aelement key value)) - alist) - (asort alist-symbol key) - (setq alist (eval alist-symbol)) - (cond ((null alist) (set alist-symbol elem)) - ((anot-head-p alist key) (set alist-symbol (nconc elem alist))) - (value (setcar alist (car elem))) - (t alist)))) - - -(defun adelete (alist-symbol key) - "Delete a key-value pair from the alist. -Alist is referenced by ALIST-SYMBOL and the key-value pair to remove -is pair matching KEY. Returns the altered alist." - (asort alist-symbol key) - (let ((alist (eval alist-symbol))) - (cond ((null alist) nil) - ((anot-head-p alist key) alist) - (t (set alist-symbol (cdr alist)))))) - - -(defun aget (alist key &optional keynil-p) - "Returns the value in ALIST that is associated with KEY. -Optional KEYNIL-P describes what to do if the value associated with -KEY is nil. If KEYNIL-P is not supplied or is nil, and the value is -nil, then KEY is returned. If KEYNIL-P is non-nil, then nil would be -returned. - -If no key-value pair matching KEY could be found in ALIST, or ALIST is -nil then nil is returned. ALIST is not altered." - (let ((copy (copy-alist alist))) - (cond ((null alist) nil) - ((progn (asort 'copy key) - (anot-head-p copy key)) nil) - ((cdr (car copy))) - (keynil-p nil) - ((car (car copy))) - (t nil)))) - - -(defun amake (alist-symbol keylist &optional valuelist) - "Make an association list. -The association list is attached to the alist referenced by -ALIST-SYMBOL. Each element in the KEYLIST becomes a key and is -associated with the value in VALUELIST with the same index. If -VALUELIST is not supplied or is nil, then each key in KEYLIST is -associated with nil. - -KEYLIST and VALUELIST should have the same number of elements, but -this isn't enforced. If VALUELIST is smaller than KEYLIST, remaining -keys are associated with nil. If VALUELIST is larger than KEYLIST, -extra values are ignored. Returns the created alist." - (let ((keycar (car keylist)) - (keycdr (cdr keylist)) - (valcar (car valuelist)) - (valcdr (cdr valuelist))) - (cond ((null keycdr) - (aput alist-symbol keycar valcar)) - (t - (amake alist-symbol keycdr valcdr) - (aput alist-symbol keycar valcar)))) - (eval alist-symbol)) - -(provide 'assoc) - -;;; assoc.el ends here diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el deleted file mode 100644 index 4614a5c42cb..00000000000 --- a/lisp/emacs-lisp/autoload.el +++ /dev/null @@ -1,416 +0,0 @@ -;;; autoload.el --- maintain autoloads in loaddefs.el. - -;; Copyright (C) 1991, 92, 93, 94, 95, 96 Free Software Foundation, Inc. - -;; Author: Roland McGrath <roland@gnu.ai.mit.edu> -;; Keywords: maint - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This code helps GNU Emacs maintainers keep the loaddefs.el file up to -;; date. It interprets magic cookies of the form ";;;###autoload" in -;; lisp source files in various useful ways. To learn more, read the -;; source; if you're going to use this, you'd better be able to. - -;;; Code: - -(defun make-autoload (form file) - "Turn FORM, a defun or defmacro, into an autoload for source file FILE. -Returns nil if FORM is not a defun, define-skeleton or defmacro." - (let ((car (car-safe form))) - (if (memq car '(defun define-skeleton defmacro)) - (let ((macrop (eq car 'defmacro)) - name doc) - (setq form (cdr form) - name (car form) - ;; Ignore the arguments. - form (cdr (if (eq car 'define-skeleton) - form - (cdr form))) - doc (car form)) - (if (stringp doc) - (setq form (cdr form)) - (setq doc nil)) - (list 'autoload (list 'quote name) file doc - (or (eq car 'define-skeleton) - (eq (car-safe (car form)) 'interactive)) - (if macrop (list 'quote 'macro) nil))) - nil))) - -(put 'define-skeleton 'doc-string-elt 3) - -(defconst generate-autoload-cookie ";;;###autoload" - "Magic comment indicating the following form should be autoloaded. -Used by \\[update-file-autoloads]. This string should be -meaningless to Lisp (e.g., a comment). - -This string is used: - -;;;###autoload -\(defun function-to-be-autoloaded () ...) - -If this string appears alone on a line, the following form will be -read and an autoload made for it. If there is further text on the line, -that text will be copied verbatim to `generated-autoload-file'.") - -(defconst generate-autoload-section-header "\f\n;;;### " - "String inserted before the form identifying -the section of autoloads for a file.") - -(defconst generate-autoload-section-trailer "\n;;;***\n" - "String which indicates the end of the section of autoloads for a file.") - -;;; Forms which have doc-strings which should be printed specially. -;;; A doc-string-elt property of ELT says that (nth ELT FORM) is -;;; the doc-string in FORM. -;;; -;;; There used to be the following note here: -;;; ;;; Note: defconst and defvar should NOT be marked in this way. -;;; ;;; We don't want to produce defconsts and defvars that -;;; ;;; make-docfile can grok, because then it would grok them twice, -;;; ;;; once in foo.el (where they are given with ;;;###autoload) and -;;; ;;; once in loaddefs.el. -;;; -;;; Counter-note: Yes, they should be marked in this way. -;;; make-docfile only processes those files that are loaded into the -;;; dumped Emacs, and those files should never have anything -;;; autoloaded here. The above-feared problem only occurs with files -;;; which have autoloaded entries *and* are processed by make-docfile; -;;; there should be no such files. - -(put 'autoload 'doc-string-elt 3) -(put 'defun 'doc-string-elt 3) -(put 'defvar 'doc-string-elt 3) -(put 'defconst 'doc-string-elt 3) -(put 'defmacro 'doc-string-elt 3) - -(defun autoload-trim-file-name (file) - ;; Returns a relative pathname of FILE - ;; starting from the directory that loaddefs.el is in. - ;; That is normally a directory in load-path, - ;; which means Emacs will be able to find FILE when it looks. - ;; Any extra directory names here would prevent finding the file. - (setq file (expand-file-name file)) - (file-relative-name file - (file-name-directory generated-autoload-file))) - -(defun generate-file-autoloads (file) - "Insert at point a loaddefs autoload section for FILE. -autoloads are generated for defuns and defmacros in FILE -marked by `generate-autoload-cookie' (which see). -If FILE is being visited in a buffer, the contents of the buffer -are used." - (interactive "fGenerate autoloads for file: ") - (let ((outbuf (current-buffer)) - (autoloads-done '()) - (load-name (let ((name (file-name-nondirectory file))) - (if (string-match "\\.elc?$" name) - (substring name 0 (match-beginning 0)) - name))) - (print-length nil) - (print-readably t) ; This does something in Lucid Emacs. - (float-output-format nil) - (done-any nil) - (visited (get-file-buffer file)) - output-end) - - ;; If the autoload section we create here uses an absolute - ;; pathname for FILE in its header, and then Emacs is installed - ;; under a different path on another system, - ;; `update-autoloads-here' won't be able to find the files to be - ;; autoloaded. So, if FILE is in the same directory or a - ;; subdirectory of the current buffer's directory, we'll make it - ;; relative to the current buffer's directory. - (setq file (expand-file-name file)) - (let* ((source-truename (file-truename file)) - (dir-truename (file-name-as-directory - (file-truename default-directory))) - (len (length dir-truename))) - (if (and (< len (length source-truename)) - (string= dir-truename (substring source-truename 0 len))) - (setq file (substring source-truename len)))) - - (message "Generating autoloads for %s..." file) - (save-excursion - (unwind-protect - (progn - (if visited - (set-buffer visited) - ;; It is faster to avoid visiting the file. - (set-buffer (get-buffer-create " *generate-autoload-file*")) - (kill-all-local-variables) - (erase-buffer) - (setq buffer-undo-list t - buffer-read-only nil) - (emacs-lisp-mode) - (insert-file-contents file nil)) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n\f") - (cond - ((looking-at (regexp-quote generate-autoload-cookie)) - (search-forward generate-autoload-cookie) - (skip-chars-forward " \t") - (setq done-any t) - (if (eolp) - ;; Read the next form and make an autoload. - (let* ((form (prog1 (read (current-buffer)) - (or (bolp) (forward-line 1)))) - (autoload (make-autoload form load-name)) - (doc-string-elt (get (car-safe form) - 'doc-string-elt))) - (if autoload - (setq autoloads-done (cons (nth 1 form) - autoloads-done)) - (setq autoload form)) - (if (and doc-string-elt - (stringp (nth doc-string-elt autoload))) - ;; We need to hack the printing because the - ;; doc-string must be printed specially for - ;; make-docfile (sigh). - (let* ((p (nthcdr (1- doc-string-elt) - autoload)) - (elt (cdr p))) - (setcdr p nil) - (princ "\n(" outbuf) - (let ((print-escape-newlines t)) - (mapcar (function (lambda (elt) - (prin1 elt outbuf) - (princ " " outbuf))) - autoload)) - (princ "\"\\\n" outbuf) - (let ((begin (save-excursion - (set-buffer outbuf) - (point)))) - (princ (substring - (prin1-to-string (car elt)) 1) - outbuf) - ;; Insert a backslash before each ( that - ;; appears at the beginning of a line in - ;; the doc string. - (save-excursion - (set-buffer outbuf) - (save-excursion - (while (search-backward "\n(" begin t) - (forward-char 1) - (insert "\\")))) - (if (null (cdr elt)) - (princ ")" outbuf) - (princ " " outbuf) - (princ (substring - (prin1-to-string (cdr elt)) - 1) - outbuf)) - (terpri outbuf))) - (let ((print-escape-newlines t)) - (print autoload outbuf)))) - ;; Copy the rest of the line to the output. - (princ (buffer-substring - (progn - ;; Back up over whitespace, to preserve it. - (skip-chars-backward " \f\t") - (if (= (char-after (1+ (point))) ? ) - ;; Eat one space. - (forward-char 1)) - (point)) - (progn (forward-line 1) (point))) - outbuf))) - ((looking-at ";") - ;; Don't read the comment. - (forward-line 1)) - (t - (forward-sexp 1) - (forward-line 1))))))) - (or visited - ;; We created this buffer, so we should kill it. - (kill-buffer (current-buffer))) - (set-buffer outbuf) - (setq output-end (point-marker)))) - (if done-any - (progn - (insert generate-autoload-section-header) - (prin1 (list 'autoloads autoloads-done load-name - (autoload-trim-file-name file) - (nth 5 (file-attributes file))) - outbuf) - (terpri outbuf) - (insert ";;; Generated autoloads from " - (autoload-trim-file-name file) "\n") - ;; Warn if we put a line in loaddefs.el - ;; that is long enough to cause trouble. - (while (< (point) output-end) - (let ((beg (point))) - (end-of-line) - (if (> (- (point) beg) 900) - (progn - (message "A line is too long--over 900 characters") - (sleep-for 2) - (goto-char output-end)))) - (forward-line 1)) - (goto-char output-end) - (insert generate-autoload-section-trailer))) - (message "Generating autoloads for %s...done" file))) - -(defconst generated-autoload-file "loaddefs.el" - "*File \\[update-file-autoloads] puts autoloads into. -A .el file can set this in its local variables section to make its -autoloads go somewhere else.") - -;;;###autoload -(defun update-file-autoloads (file) - "Update the autoloads for FILE in `generated-autoload-file' -\(which FILE might bind in its local variables)." - (interactive "fUpdate autoloads for file: ") - (let ((load-name (let ((name (file-name-nondirectory file))) - (if (string-match "\\.elc?$" name) - (substring name 0 (match-beginning 0)) - name))) - (found nil) - (existing-buffer (get-file-buffer file))) - (save-excursion - ;; We want to get a value for generated-autoload-file from - ;; the local variables section if it's there. - (if existing-buffer - (set-buffer existing-buffer)) - (set-buffer (find-file-noselect generated-autoload-file)) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - ;; Look for the section for LOAD-NAME. - (while (and (not found) - (search-forward generate-autoload-section-header nil t)) - (let ((form (condition-case () - (read (current-buffer)) - (end-of-file nil)))) - (cond ((string= (nth 2 form) load-name) - ;; We found the section for this file. - ;; Check if it is up to date. - (let ((begin (match-beginning 0)) - (last-time (nth 4 form)) - (file-time (nth 5 (file-attributes file)))) - (if (and (or (null existing-buffer) - (not (buffer-modified-p existing-buffer))) - (listp last-time) (= (length last-time) 2) - (or (> (car last-time) (car file-time)) - (and (= (car last-time) (car file-time)) - (>= (nth 1 last-time) - (nth 1 file-time))))) - (progn - (if (interactive-p) - (message "\ -Autoload section for %s is up to date." - file)) - (setq found 'up-to-date)) - (search-forward generate-autoload-section-trailer) - (delete-region begin (point)) - (setq found t)))) - ((string< load-name (nth 2 form)) - ;; We've come to a section alphabetically later than - ;; LOAD-NAME. We assume the file is in order and so - ;; there must be no section for LOAD-NAME. We will - ;; insert one before the section here. - (goto-char (match-beginning 0)) - (setq found 'new))))) - (or found - (progn - (setq found 'new) - ;; No later sections in the file. Put before the last page. - (goto-char (point-max)) - (search-backward "\f" nil t))) - (or (eq found 'up-to-date) - (and (eq found 'new) - ;; Check that FILE has any cookies before generating a - ;; new section for it. - (save-excursion - (if existing-buffer - (set-buffer existing-buffer) - ;; It is faster to avoid visiting the file. - (set-buffer (get-buffer-create " *autoload-file*")) - (kill-all-local-variables) - (erase-buffer) - (setq buffer-undo-list t - buffer-read-only nil) - (emacs-lisp-mode) - (insert-file-contents file nil)) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (prog1 - (if (search-forward - (concat "\n" generate-autoload-cookie) - nil t) - nil - (if (interactive-p) - (message "%s has no autoloads" file)) - t) - (or existing-buffer - (kill-buffer (current-buffer)))))))) - (generate-file-autoloads file)))) - (if (interactive-p) (save-buffer))))) - -;;;###autoload -(defun update-autoloads-from-directory (dir) - "\ -Update loaddefs.el with all the current autoloads from DIR, and no old ones. -This uses `update-file-autoloads' (which see) do its work." - (interactive "DUpdate autoloads from directory: ") - (setq dir (expand-file-name dir)) - (let ((files (directory-files dir nil "^[^=].*\\.el$"))) - (save-excursion - (set-buffer (find-file-noselect - (if (file-exists-p generated-autoload-file) - generated-autoload-file - (expand-file-name generated-autoload-file - dir)))) - (save-excursion - (goto-char (point-min)) - (while (search-forward generate-autoload-section-header nil t) - (let* ((form (condition-case () - (read (current-buffer)) - (end-of-file nil))) - (file (nth 3 form))) - (cond ((not (stringp file))) - ((not (file-exists-p (expand-file-name file dir))) - ;; Remove the obsolete section. - (let ((begin (match-beginning 0))) - (search-forward generate-autoload-section-trailer) - (delete-region begin (point)))) - (t - (update-file-autoloads file))) - (setq files (delete file files))))) - ;; Elements remaining in FILES have no existing autoload sections. - (mapcar 'update-file-autoloads files) - (save-buffer)))) - -;;;###autoload -(defun batch-update-autoloads () - "Update loaddefs.el autoloads in batch mode. -Calls `update-autoloads-from-directory' on each command line argument." - (mapcar 'update-autoloads-from-directory command-line-args-left) - (setq command-line-args-left nil)) - -(provide 'autoload) - -;;; autoload.el ends here diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el deleted file mode 100644 index 807b4bd1c50..00000000000 --- a/lisp/emacs-lisp/backquote.el +++ /dev/null @@ -1,212 +0,0 @@ -;;; backquote.el --- implement the ` Lisp construct - -;;; Copyright (C) 1990, 1992, 1994 Free Software Foundation, Inc. - -;; Author: Rick Sladkey <jrs@world.std.com> -;; Maintainer: FSF -;; Keywords: extensions, internal - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This backquote will generate calls to the backquote-list* form. -;; Both a function version and a macro version are included. -;; The macro version is used by default because it is faster -;; and needs no run-time support. It should really be a subr. - -;;; Code: - -(provide 'backquote) - -;; function and macro versions of backquote-list* - -(defun backquote-list*-function (first &rest list) - "Like `list' but the last argument is the tail of the new list. - -For example (backquote-list* 'a 'b 'c) => (a b . c)" - (if list - (let* ((rest list) (newlist (cons first nil)) (last newlist)) - (while (cdr rest) - (setcdr last (cons (car rest) nil)) - (setq last (cdr last) - rest (cdr rest))) - (setcdr last (car rest)) - newlist) - first)) - -(defmacro backquote-list*-macro (first &rest list) - "Like `list' but the last argument is the tail of the new list. - -For example (backquote-list* 'a 'b 'c) => (a b . c)" - (setq list (reverse (cons first list)) - first (car list) - list (cdr list)) - (if list - (let* ((second (car list)) - (rest (cdr list)) - (newlist (list 'cons second first))) - (while rest - (setq newlist (list 'cons (car rest) newlist) - rest (cdr rest))) - newlist) - first)) - -(defalias 'backquote-list* (symbol-function 'backquote-list*-macro)) - -;; A few advertised variables that control which symbols are used -;; to represent the backquote, unquote, and splice operations. - -(defvar backquote-backquote-symbol '\` - "*Symbol used to represent a backquote or nested backquote (e.g. `).") - -(defvar backquote-unquote-symbol ', - "*Symbol used to represent an unquote (e.g. `,') inside a backquote.") - -(defvar backquote-splice-symbol ',@ - "*Symbol used to represent a splice (e.g. `,@') inside a backquote.") - -;;;###autoload -(defmacro backquote (arg) - "Argument STRUCTURE describes a template to build. - -The whole structure acts as if it were quoted except for certain -places where expressions are evaluated and inserted or spliced in. - -For example: - -b => (ba bb bc) ; assume b has this value -`(a b c) => (a b c) ; backquote acts like quote -`(a ,b c) => (a (ba bb bc) c) ; insert the value of b -`(a ,@b c) => (a ba bb bc c) ; splice in the value of b - -Vectors work just like lists. Nested backquotes are permitted." - (cdr (backquote-process arg))) - -;; GNU Emacs has no reader macros - -;;;###autoload -(defalias '\` (symbol-function 'backquote)) - -;; backquote-process returns a dotted-pair of a tag (0, 1, or 2) and -;; the backquote-processed structure. 0 => the structure is -;; constant, 1 => to be unquoted, 2 => to be spliced in. -;; The top-level backquote macro just discards the tag. - -(defun backquote-process (s) - (cond - ((vectorp s) - (let ((n (backquote-process (append s ())))) - (if (= (car n) 0) - (cons 0 s) - (cons 1 (cond - ((eq (nth 1 n) 'list) - (cons 'vector (nthcdr 2 n))) - ((eq (nth 1 n) 'append) - (cons 'vconcat (nthcdr 2 n))) - (t - (list 'apply '(function vector) (cdr n)))))))) - ((atom s) - (cons 0 (if (or (null s) (eq s t) (not (symbolp s))) - s - (list 'quote s)))) - ((eq (car s) backquote-unquote-symbol) - (cons 1 (nth 1 s))) - ((eq (car s) backquote-splice-symbol) - (cons 2 (nth 1 s))) - ((eq (car s) backquote-backquote-symbol) - (backquote-process (cdr (backquote-process (nth 1 s))))) - (t - (let ((rest s) - item firstlist list lists expression) - ;; Scan this list-level, setting LISTS to a list of forms, - ;; each of which produces a list of elements - ;; that should go in this level. - ;; The order of LISTS is backwards. - ;; If there are non-splicing elements (constant or variable) - ;; at the beginning, put them in FIRSTLIST, - ;; as a list of tagged values (TAG . FORM). - ;; If there are any at the end, they go in LIST, likewise. - (while (consp rest) - ;; Turn . (, foo) into (,@ foo). - (if (eq (car rest) backquote-unquote-symbol) - (setq rest (list (list backquote-splice-symbol (nth 1 rest))))) - (setq item (backquote-process (car rest))) - (cond - ((= (car item) 2) - ;; Put the nonspliced items before the first spliced item - ;; into FIRSTLIST. - (if (null lists) - (setq firstlist list - list nil)) - ;; Otherwise, put any preceding nonspliced items into LISTS. - (if list - (setq lists (cons (backquote-listify list '(0 . nil)) lists))) - (setq lists (cons (cdr item) lists)) - (setq list nil)) - (t - (setq list (cons item list)))) - (setq rest (cdr rest))) - ;; Handle nonsplicing final elements, and the tail of the list - ;; (which remains in REST). - (if (or rest list) - (setq lists (cons (backquote-listify list (backquote-process rest)) - lists))) - ;; Turn LISTS into a form that produces the combined list. - (setq expression - (if (or (cdr lists) - (eq (car-safe (car lists)) backquote-splice-symbol)) - (cons 'append (nreverse lists)) - (car lists))) - ;; Tack on any initial elements. - (if firstlist - (setq expression (backquote-listify firstlist (cons 1 expression)))) - (if (eq (car-safe expression) 'quote) - (cons 0 (list 'quote s)) - (cons 1 expression)))))) - -;; backquote-listify takes (tag . structure) pairs from backquote-process -;; and decides between append, list, backquote-list*, and cons depending -;; on which tags are in the list. - -(defun backquote-listify (list old-tail) - (let ((heads nil) (tail (cdr old-tail)) (list-tail list) (item nil)) - (if (= (car old-tail) 0) - (setq tail (eval tail) - old-tail nil)) - (while (consp list-tail) - (setq item (car list-tail)) - (setq list-tail (cdr list-tail)) - (if (or heads old-tail (/= (car item) 0)) - (setq heads (cons (cdr item) heads)) - (setq tail (cons (eval (cdr item)) tail)))) - (cond - (tail - (if (null old-tail) - (setq tail (list 'quote tail))) - (if heads - (let ((use-list* (or (cdr heads) - (and (consp (car heads)) - (eq (car (car heads)) - backquote-splice-symbol))))) - (cons (if use-list* 'backquote-list* 'cons) - (append heads (list tail)))) - tail)) - (t (cons 'list heads))))) - -;; backquote.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el deleted file mode 100644 index ef2880c7d9b..00000000000 --- a/lisp/emacs-lisp/byte-opt.el +++ /dev/null @@ -1,1872 +0,0 @@ -;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler. - -;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc. - -;; Author: Jamie Zawinski <jwz@lucid.com> -;; Hallvard Furuseth <hbf@ulrik.uio.no> -;; Keywords: internal - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; This file has been censored by the Communications Decency Act. -;;; That law was passed under the guise of a ban on pornography, but -;;; it bans far more than that. This file did not contain pornography, -;;; but it was censored nonetheless. - -;;; For information on US government censorship of the Internet, and -;;; what you can do to bring back freedom of the press, see the web -;;; site http://www.vtw.org/ - -;; ======================================================================== -;; "No matter how hard you try, you can't make a racehorse out of a pig. -;; You can, however, make a faster pig." -;; -;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code -;; makes it be a VW Bug with fuel injection and a turbocharger... You're -;; still not going to make it go faster than 70 mph, but it might be easier -;; to get it there. -;; - -;; TO DO: -;; -;; (apply '(lambda (x &rest y) ...) 1 (foo)) -;; -;; maintain a list of functions known not to access any global variables -;; (actually, give them a 'dynamically-safe property) and then -;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==> -;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> ) -;; by recursing on this, we might be able to eliminate the entire let. -;; However certain variables should never have their bindings optimized -;; away, because they affect everything. -;; (put 'debug-on-error 'binding-is-magic t) -;; (put 'debug-on-abort 'binding-is-magic t) -;; (put 'debug-on-next-call 'binding-is-magic t) -;; (put 'mocklisp-arguments 'binding-is-magic t) -;; (put 'inhibit-quit 'binding-is-magic t) -;; (put 'quit-flag 'binding-is-magic t) -;; (put 't 'binding-is-magic t) -;; (put 'nil 'binding-is-magic t) -;; possibly also -;; (put 'gc-cons-threshold 'binding-is-magic t) -;; (put 'track-mouse 'binding-is-magic t) -;; others? -;; -;; Simple defsubsts often produce forms like -;; (let ((v1 (f1)) (v2 (f2)) ...) -;; (FN v1 v2 ...)) -;; It would be nice if we could optimize this to -;; (FN (f1) (f2) ...) -;; but we can't unless FN is dynamically-safe (it might be dynamically -;; referring to the bindings that the lambda arglist established.) -;; One of the uncountable lossages introduced by dynamic scope... -;; -;; Maybe there should be a control-structure that says "turn on -;; fast-and-loose type-assumptive optimizations here." Then when -;; we see a form like (car foo) we can from then on assume that -;; the variable foo is of type cons, and optimize based on that. -;; But, this won't win much because of (you guessed it) dynamic -;; scope. Anything down the stack could change the value. -;; (Another reason it doesn't work is that it is perfectly valid -;; to call car with a null argument.) A better approach might -;; be to allow type-specification of the form -;; (put 'foo 'arg-types '(float (list integer) dynamic)) -;; (put 'foo 'result-type 'bool) -;; It should be possible to have these types checked to a certain -;; degree. -;; -;; collapse common subexpressions -;; -;; It would be nice if redundant sequences could be factored out as well, -;; when they are known to have no side-effects: -;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2 -;; but beware of traps like -;; (cons (list x y) (list x y)) -;; -;; Tail-recursion elimination is not really possible in Emacs Lisp. -;; Tail-recursion elimination is almost always impossible when all variables -;; have dynamic scope, but given that the "return" byteop requires the -;; binding stack to be empty (rather than emptying it itself), there can be -;; no truly tail-recursive Emacs Lisp functions that take any arguments or -;; make any bindings. -;; -;; Here is an example of an Emacs Lisp function which could safely be -;; byte-compiled tail-recursively: -;; -;; (defun tail-map (fn list) -;; (cond (list -;; (funcall fn (car list)) -;; (tail-map fn (cdr list))))) -;; -;; However, if there was even a single let-binding around the COND, -;; it could not be byte-compiled, because there would be an "unbind" -;; byte-op between the final "call" and "return." Adding a -;; Bunbind_all byteop would fix this. -;; -;; (defun foo (x y z) ... (foo a b c)) -;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return) -;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return) -;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return) -;; -;; this also can be considered tail recursion: -;; -;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return) -;; could generalize this by doing the optimization -;; (goto X) ... X: (return) --> (return) -;; -;; But this doesn't solve all of the problems: although by doing tail- -;; recursion elimination in this way, the call-stack does not grow, the -;; binding-stack would grow with each recursive step, and would eventually -;; overflow. I don't believe there is any way around this without lexical -;; scope. -;; -;; Wouldn't it be nice if Emacs Lisp had lexical scope. -;; -;; Idea: the form (lexical-scope) in a file means that the file may be -;; compiled lexically. This proclamation is file-local. Then, within -;; that file, "let" would establish lexical bindings, and "let-dynamic" -;; would do things the old way. (Or we could use CL "declare" forms.) -;; We'd have to notice defvars and defconsts, since those variables should -;; always be dynamic, and attempting to do a lexical binding of them -;; should simply do a dynamic binding instead. -;; But! We need to know about variables that were not necessarily defvarred -;; in the file being compiled (doing a boundp check isn't good enough.) -;; Fdefvar() would have to be modified to add something to the plist. -;; -;; A major disadvantage of this scheme is that the interpreter and compiler -;; would have different semantics for files compiled with (dynamic-scope). -;; Since this would be a file-local optimization, there would be no way to -;; modify the interpreter to obey this (unless the loader was hacked -;; in some grody way, but that's a really bad idea.) - -;; Other things to consider: - -;;;;; Associative math should recognize subcalls to identical function: -;;;(disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) -;;;;; This should generate the same as (1+ x) and (1- x) - -;;;(disassemble (lambda (x) (cons (+ x 1) (- x 1)))) -;;;;; An awful lot of functions always return a non-nil value. If they're -;;;;; error free also they may act as true-constants. - -;;;(disassemble (lambda (x) (and (point) (foo)))) -;;;;; When -;;;;; - all but one arguments to a function are constant -;;;;; - the non-constant argument is an if-expression (cond-expression?) -;;;;; then the outer function can be distributed. If the guarding -;;;;; condition is side-effect-free [assignment-free] then the other -;;;;; arguments may be any expressions. Since, however, the code size -;;;;; can increase this way they should be "simple". Compare: - -;;;(disassemble (lambda (x) (eq (if (point) 'a 'b) 'c))) -;;;(disassemble (lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c)))) - -;;;;; (car (cons A B)) -> (progn B A) -;;;(disassemble (lambda (x) (car (cons (foo) 42)))) - -;;;;; (cdr (cons A B)) -> (progn A B) -;;;(disassemble (lambda (x) (cdr (cons 42 (foo))))) - -;;;;; (car (list A B ...)) -> (progn B ... A) -;;;(disassemble (lambda (x) (car (list (foo) 42 (bar))))) - -;;;;; (cdr (list A B ...)) -> (progn A (list B ...)) -;;;(disassemble (lambda (x) (cdr (list 42 (foo) (bar))))) - - -;;; Code: - -(defun byte-compile-log-lap-1 (format &rest args) - (if (aref byte-code-vector 0) - (error "The old version of the disassembler is loaded. Reload new-bytecomp as well.")) - (byte-compile-log-1 - (apply 'format format - (let (c a) - (mapcar '(lambda (arg) - (if (not (consp arg)) - (if (and (symbolp arg) - (string-match "^byte-" (symbol-name arg))) - (intern (substring (symbol-name arg) 5)) - arg) - (if (integerp (setq c (car arg))) - (error "non-symbolic byte-op %s" c)) - (if (eq c 'TAG) - (setq c arg) - (setq a (cond ((memq c byte-goto-ops) - (car (cdr (cdr arg)))) - ((memq c byte-constref-ops) - (car (cdr arg))) - (t (cdr arg)))) - (setq c (symbol-name c)) - (if (string-match "^byte-." c) - (setq c (intern (substring c 5))))) - (if (eq c 'constant) (setq c 'const)) - (if (and (eq (cdr arg) 0) - (not (memq c '(unbind call const)))) - c - (format "(%s %s)" c a)))) - args))))) - -(defmacro byte-compile-log-lap (format-string &rest args) - (list 'and - '(memq byte-optimize-log '(t byte)) - (cons 'byte-compile-log-lap-1 - (cons format-string args)))) - - -;;; byte-compile optimizers to support inlining - -(put 'inline 'byte-optimizer 'byte-optimize-inline-handler) - -(defun byte-optimize-inline-handler (form) - "byte-optimize-handler for the `inline' special-form." - (cons 'progn - (mapcar - '(lambda (sexp) - (let ((fn (car-safe sexp))) - (if (and (symbolp fn) - (or (cdr (assq fn byte-compile-function-environment)) - (and (fboundp fn) - (not (or (cdr (assq fn byte-compile-macro-environment)) - (and (consp (setq fn (symbol-function fn))) - (eq (car fn) 'macro)) - (subrp fn)))))) - (byte-compile-inline-expand sexp) - sexp))) - (cdr form)))) - - -;; Splice the given lap code into the current instruction stream. -;; If it has any labels in it, you're responsible for making sure there -;; are no collisions, and that byte-compile-tag-number is reasonable -;; after this is spliced in. The provided list is destroyed. -(defun byte-inline-lapcode (lap) - (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))) - - -(defun byte-compile-inline-expand (form) - (let* ((name (car form)) - (fn (or (cdr (assq name byte-compile-function-environment)) - (and (fboundp name) (symbol-function name))))) - (if (null fn) - (progn - (byte-compile-warn "attempt to inline %s before it was defined" name) - form) - ;; else - (if (and (consp fn) (eq (car fn) 'autoload)) - (load (nth 1 fn))) - (if (and (consp fn) (eq (car fn) 'autoload)) - (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name)) - (if (symbolp fn) - (byte-compile-inline-expand (cons fn (cdr form))) - (if (byte-code-function-p fn) - (progn - (fetch-bytecode fn) - (cons (list 'lambda (aref fn 0) - (list 'byte-code (aref fn 1) (aref fn 2) (aref fn 3))) - (cdr form))) - (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name)) - (cons fn (cdr form))))))) - -;;; ((lambda ...) ...) -;;; -(defun byte-compile-unfold-lambda (form &optional name) - (or name (setq name "anonymous lambda")) - (let ((lambda (car form)) - (values (cdr form))) - (if (byte-code-function-p lambda) - (setq lambda (list 'lambda (aref lambda 0) - (list 'byte-code (aref lambda 1) - (aref lambda 2) (aref lambda 3))))) - (let ((arglist (nth 1 lambda)) - (body (cdr (cdr lambda))) - optionalp restp - bindings) - (if (and (stringp (car body)) (cdr body)) - (setq body (cdr body))) - (if (and (consp (car body)) (eq 'interactive (car (car body)))) - (setq body (cdr body))) - (while arglist - (cond ((eq (car arglist) '&optional) - ;; ok, I'll let this slide because funcall_lambda() does... - ;; (if optionalp (error "multiple &optional keywords in %s" name)) - (if restp (error "&optional found after &rest in %s" name)) - (if (null (cdr arglist)) - (error "nothing after &optional in %s" name)) - (setq optionalp t)) - ((eq (car arglist) '&rest) - ;; ...but it is by no stretch of the imagination a reasonable - ;; thing that funcall_lambda() allows (&rest x y) and - ;; (&rest x &optional y) in arglists. - (if (null (cdr arglist)) - (error "nothing after &rest in %s" name)) - (if (cdr (cdr arglist)) - (error "multiple vars after &rest in %s" name)) - (setq restp t)) - (restp - (setq bindings (cons (list (car arglist) - (and values (cons 'list values))) - bindings) - values nil)) - ((and (not optionalp) (null values)) - (byte-compile-warn "attempt to open-code %s with too few arguments" name) - (setq arglist nil values 'too-few)) - (t - (setq bindings (cons (list (car arglist) (car values)) - bindings) - values (cdr values)))) - (setq arglist (cdr arglist))) - (if values - (progn - (or (eq values 'too-few) - (byte-compile-warn - "attempt to open-code %s with too many arguments" name)) - form) - (setq body (mapcar 'byte-optimize-form body)) - (let ((newform - (if bindings - (cons 'let (cons (nreverse bindings) body)) - (cons 'progn body)))) - (byte-compile-log " %s\t==>\t%s" form newform) - newform))))) - - -;;; implementing source-level optimizers - -(defun byte-optimize-form-code-walker (form for-effect) - ;; - ;; For normal function calls, We can just mapcar the optimizer the cdr. But - ;; we need to have special knowledge of the syntax of the special forms - ;; like let and defun (that's why they're special forms :-). (Actually, - ;; the important aspect is that they are subrs that don't evaluate all of - ;; their args.) - ;; - (let ((fn (car-safe form)) - tmp) - (cond ((not (consp form)) - (if (not (and for-effect - (or byte-compile-delete-errors - (not (symbolp form)) - (eq form t)))) - form)) - ((eq fn 'quote) - (if (cdr (cdr form)) - (byte-compile-warn "malformed quote form: %s" - (prin1-to-string form))) - ;; map (quote nil) to nil to simplify optimizer logic. - ;; map quoted constants to nil if for-effect (just because). - (and (nth 1 form) - (not for-effect) - form)) - ((or (byte-code-function-p fn) - (eq 'lambda (car-safe fn))) - (byte-compile-unfold-lambda form)) - ((memq fn '(let let*)) - ;; recursively enter the optimizer for the bindings and body - ;; of a let or let*. This for depth-firstness: forms that - ;; are more deeply nested are optimized first. - (cons fn - (cons - (mapcar '(lambda (binding) - (if (symbolp binding) - binding - (if (cdr (cdr binding)) - (byte-compile-warn "malformed let binding: %s" - (prin1-to-string binding))) - (list (car binding) - (byte-optimize-form (nth 1 binding) nil)))) - (nth 1 form)) - (byte-optimize-body (cdr (cdr form)) for-effect)))) - ((eq fn 'cond) - (cons fn - (mapcar '(lambda (clause) - (if (consp clause) - (cons - (byte-optimize-form (car clause) nil) - (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: %s" - (prin1-to-string clause)) - clause)) - (cdr form)))) - ((eq fn 'progn) - ;; as an extra added bonus, this simplifies (progn <x>) --> <x> - (if (cdr (cdr form)) - (progn - (setq tmp (byte-optimize-body (cdr form) for-effect)) - (if (cdr tmp) (cons 'progn tmp) (car tmp))) - (byte-optimize-form (nth 1 form) for-effect))) - ((eq fn 'prog1) - (if (cdr (cdr form)) - (cons 'prog1 - (cons (byte-optimize-form (nth 1 form) for-effect) - (byte-optimize-body (cdr (cdr form)) t))) - (byte-optimize-form (nth 1 form) for-effect))) - ((eq fn 'prog2) - (cons 'prog2 - (cons (byte-optimize-form (nth 1 form) t) - (cons (byte-optimize-form (nth 2 form) for-effect) - (byte-optimize-body (cdr (cdr (cdr form))) t))))) - - ((memq fn '(save-excursion save-restriction save-current-buffer)) - ;; those subrs which have an implicit progn; it's not quite good - ;; enough to treat these like normal function calls. - ;; This can turn (save-excursion ...) into (save-excursion) which - ;; will be optimized away in the lap-optimize pass. - (cons fn (byte-optimize-body (cdr form) for-effect))) - - ((eq fn 'with-output-to-temp-buffer) - ;; this is just like the above, except for the first argument. - (cons fn - (cons - (byte-optimize-form (nth 1 form) nil) - (byte-optimize-body (cdr (cdr form)) for-effect)))) - - ((eq fn 'if) - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (cons - (byte-optimize-form (nth 2 form) for-effect) - (byte-optimize-body (nthcdr 3 form) for-effect))))) - - ((memq fn '(and or)) ; remember, and/or are control structures. - ;; take forms off the back until we can't any more. - ;; In the future it could conceivably be a problem that the - ;; subexpressions of these forms are optimized in the reverse - ;; order, but it's ok for now. - (if for-effect - (let ((backwards (reverse (cdr form)))) - (while (and backwards - (null (setcar backwards - (byte-optimize-form (car backwards) - for-effect)))) - (setq backwards (cdr backwards))) - (if (and (cdr form) (null backwards)) - (byte-compile-log - " all subforms of %s called for effect; deleted" form)) - (and backwards - (cons fn (nreverse backwards)))) - (cons fn (mapcar 'byte-optimize-form (cdr form))))) - - ((eq fn 'interactive) - (byte-compile-warn "misplaced interactive spec: %s" - (prin1-to-string form)) - nil) - - ((memq fn '(defun defmacro function - condition-case save-window-excursion)) - ;; These forms are compiled as constants or by breaking out - ;; all the subexpressions and compiling them separately. - form) - - ((eq fn 'unwind-protect) - ;; the "protected" part of an unwind-protect is compiled (and thus - ;; optimized) as a top-level form, so don't do it here. But the - ;; non-protected part has the same for-effect status as the - ;; unwind-protect itself. (The protected part is always for effect, - ;; but that isn't handled properly yet.) - (cons fn - (cons (byte-optimize-form (nth 1 form) for-effect) - (cdr (cdr form))))) - - ((eq fn 'catch) - ;; the body of a catch is compiled (and thus optimized) as a - ;; top-level form, so don't do it here. The tag is never - ;; for-effect. The body should have the same for-effect status - ;; as the catch form itself, but that isn't handled properly yet. - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (cdr (cdr form))))) - - ;; If optimization is on, this is the only place that macros are - ;; expanded. If optimization is off, then macroexpansion happens - ;; in byte-compile-form. Otherwise, the macros are already expanded - ;; by the time that is reached. - ((not (eq form - (setq form (macroexpand form - byte-compile-macro-environment)))) - (byte-optimize-form form for-effect)) - - ((not (symbolp fn)) - (or (eq 'mocklisp (car-safe fn)) ; ha! - (byte-compile-warn "%s is a malformed function" - (prin1-to-string fn))) - form) - - ((and for-effect (setq tmp (get fn 'side-effect-free)) - (or byte-compile-delete-errors - (eq tmp 'error-free) - (progn - (byte-compile-warn "%s called for effect" - (prin1-to-string form)) - nil))) - (byte-compile-log " %s called for effect; deleted" fn) - ;; appending a nil here might not be necessary, but it can't hurt. - (byte-optimize-form - (cons 'progn (append (cdr form) '(nil))) t)) - - (t - ;; Otherwise, no args can be considered to be for-effect, - ;; even if the called function is for-effect, because we - ;; don't know anything about that function. - (cons fn (mapcar 'byte-optimize-form (cdr form))))))) - - -(defun byte-optimize-form (form &optional for-effect) - "The source-level pass of the optimizer." - ;; - ;; First, optimize all sub-forms of this one. - (setq form (byte-optimize-form-code-walker form for-effect)) - ;; - ;; after optimizing all subforms, optimize this form until it doesn't - ;; optimize any further. This means that some forms will be passed through - ;; the optimizer many times, but that's necessary to make the for-effect - ;; processing do as much as possible. - ;; - (let (opt new) - (if (and (consp form) - (symbolp (car form)) - (or (and for-effect - ;; we don't have any of these yet, but we might. - (setq opt (get (car form) 'byte-for-effect-optimizer))) - (setq opt (get (car form) 'byte-optimizer))) - (not (eq form (setq new (funcall opt form))))) - (progn -;; (if (equal form new) (error "bogus optimizer -- %s" opt)) - (byte-compile-log " %s\t==>\t%s" form new) - (setq new (byte-optimize-form new for-effect)) - new) - form))) - - -(defun byte-optimize-body (forms all-for-effect) - ;; optimize the cdr of a progn or implicit progn; all forms is a list of - ;; forms, all but the last of which are optimized with the assumption that - ;; they are being called for effect. the last is for-effect as well if - ;; all-for-effect is true. returns a new list of forms. - (let ((rest forms) - (result nil) - fe new) - (while rest - (setq fe (or all-for-effect (cdr rest))) - (setq new (and (car rest) (byte-optimize-form (car rest) fe))) - (if (or new (not fe)) - (setq result (cons new result))) - (setq rest (cdr rest))) - (nreverse result))) - - -;;; some source-level optimizers -;;; -;;; when writing optimizers, be VERY careful that the optimizer returns -;;; something not EQ to its argument if and ONLY if it has made a change. -;;; This implies that you cannot simply destructively modify the list; -;;; you must return something not EQ to it if you make an optimization. -;;; -;;; It is now safe to optimize code such that it introduces new bindings. - -;; I'd like this to be a defsubst, but let's not be self-referential... -(defmacro byte-compile-trueconstp (form) - ;; Returns non-nil if FORM is a non-nil constant. - (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) - ((not (symbolp (, form)))) - ((eq (, form) t))))) - -;; If the function is being called with constant numeric args, -;; evaluate as much as possible at compile-time. This optimizer -;; assumes that the function is associative, like + or *. -(defun byte-optimize-associative-math (form) - (let ((args nil) - (constants nil) - (rest (cdr form))) - (while rest - (if (numberp (car rest)) - (setq constants (cons (car rest) constants)) - (setq args (cons (car rest) args))) - (setq rest (cdr rest))) - (if (cdr constants) - (if args - (list (car form) - (apply (car form) constants) - (if (cdr args) - (cons (car form) (nreverse args)) - (car args))) - (apply (car form) constants)) - form))) - -;; If the function is being called with constant numeric args, -;; evaluate as much as possible at compile-time. This optimizer -;; assumes that the function satisfies -;; (op x1 x2 ... xn) == (op ...(op (op x1 x2) x3) ...xn) -;; like - and /. -(defun byte-optimize-nonassociative-math (form) - (if (or (not (numberp (car (cdr form)))) - (not (numberp (car (cdr (cdr form)))))) - form - (let ((constant (car (cdr form))) - (rest (cdr (cdr form)))) - (while (numberp (car rest)) - (setq constant (funcall (car form) constant (car rest)) - rest (cdr rest))) - (if rest - (cons (car form) (cons constant rest)) - constant)))) - -;;(defun byte-optimize-associative-two-args-math (form) -;; (setq form (byte-optimize-associative-math form)) -;; (if (consp form) -;; (byte-optimize-two-args-left form) -;; form)) - -;;(defun byte-optimize-nonassociative-two-args-math (form) -;; (setq form (byte-optimize-nonassociative-math form)) -;; (if (consp form) -;; (byte-optimize-two-args-right form) -;; form)) - -(defun byte-optimize-approx-equal (x y) - (< (* (abs (- x y)) 100) (abs (+ x y)))) - -;; Collect all the constants from FORM, after the STARTth arg, -;; and apply FUN to them to make one argument at the end. -;; For functions that can handle floats, that optimization -;; can be incorrect because reordering can cause an overflow -;; that would otherwise be avoided by encountering an arg that is a float. -;; We avoid this problem by (1) not moving float constants and -;; (2) not moving anything if it would cause an overflow. -(defun byte-optimize-delay-constants-math (form start fun) - ;; Merge all FORM's constants from number START, call FUN on them - ;; and put the result at the end. - (let ((rest (nthcdr (1- start) form)) - (orig form) - ;; t means we must check for overflow. - (overflow (memq fun '(+ *)))) - (while (cdr (setq rest (cdr rest))) - (if (integerp (car rest)) - (let (constants) - (setq form (copy-sequence form) - rest (nthcdr (1- start) form)) - (while (setq rest (cdr rest)) - (cond ((integerp (car rest)) - (setq constants (cons (car rest) constants)) - (setcar rest nil)))) - ;; If necessary, check now for overflow - ;; that might be caused by reordering. - (if (and overflow - ;; We have overflow if the result of doing the arithmetic - ;; on floats is not even close to the result - ;; of doing it on integers. - (not (byte-optimize-approx-equal - (apply fun (mapcar 'float constants)) - (float (apply fun constants))))) - (setq form orig) - (setq form (nconc (delq nil form) - (list (apply fun (nreverse constants))))))))) - form)) - -(defun byte-optimize-plus (form) - (setq form (byte-optimize-delay-constants-math form 1 '+)) - (if (memq 0 form) (setq form (delq 0 (copy-sequence form)))) - ;;(setq form (byte-optimize-associative-two-args-math form)) - (cond ((null (cdr form)) - (condition-case () - (eval form) - (error form))) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker). -;; ((null (cdr (cdr form))) (nth 1 form)) - (t form))) - -(defun byte-optimize-minus (form) - ;; Put constants at the end, except the last constant. - (setq form (byte-optimize-delay-constants-math form 2 '+)) - ;; Now only first and last element can be a number. - (let ((last (car (reverse (nthcdr 3 form))))) - (cond ((eq 0 last) - ;; (- x y ... 0) --> (- x y ...) - (setq form (copy-sequence form)) - (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form)))) - ;; If form is (- CONST foo... CONST), merge first and last. - ((and (numberp (nth 1 form)) - (numberp last)) - (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form)) - (delq last (copy-sequence (nthcdr 3 form)))))))) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker). -;;; (if (eq (nth 2 form) 0) -;;; (nth 1 form) ; (- x 0) --> x - (byte-optimize-predicate - (if (and (null (cdr (cdr (cdr form)))) - (eq (nth 1 form) 0)) ; (- 0 x) --> (- x) - (cons (car form) (cdr (cdr form))) - form)) -;;; ) - ) - -(defun byte-optimize-multiply (form) - (setq form (byte-optimize-delay-constants-math form 1 '*)) - ;; If there is a constant in FORM, it is now the last element. - (cond ((null (cdr form)) 1) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker or if it appears in other arithmetic). -;;; ((null (cdr (cdr form))) (nth 1 form)) - ((let ((last (car (reverse form)))) - (cond ((eq 0 last) (cons 'progn (cdr form))) - ((eq 1 last) (delq 1 (copy-sequence form))) - ((eq -1 last) (list '- (delq -1 (copy-sequence form)))) - ((and (eq 2 last) - (memq t (mapcar 'symbolp (cdr form)))) - (prog1 (setq form (delq 2 (copy-sequence form))) - (while (not (symbolp (car (setq form (cdr form)))))) - (setcar form (list '+ (car form) (car form))))) - (form)))))) - -(defsubst byte-compile-butlast (form) - (nreverse (cdr (reverse form)))) - -(defun byte-optimize-divide (form) - (setq form (byte-optimize-delay-constants-math form 2 '*)) - (let ((last (car (reverse (cdr (cdr form)))))) - (if (numberp last) - (cond ((= (length form) 3) - (if (and (numberp (nth 1 form)) - (not (zerop last)) - (condition-case nil - (/ (nth 1 form) last) - (error nil))) - (setq form (list 'progn (/ (nth 1 form) last))))) - ((= last 1) - (setq form (byte-compile-butlast form))) - ((numberp (nth 1 form)) - (setq form (cons (car form) - (cons (/ (nth 1 form) last) - (byte-compile-butlast (cdr (cdr form))))) - last nil)))) - (cond -;;; ((null (cdr (cdr form))) -;;; (nth 1 form)) - ((eq (nth 1 form) 0) - (append '(progn) (cdr (cdr form)) '(0))) - ((eq last -1) - (list '- (if (nthcdr 3 form) - (byte-compile-butlast form) - (nth 1 form)))) - (form)))) - -(defun byte-optimize-logmumble (form) - (setq form (byte-optimize-delay-constants-math form 1 (car form))) - (byte-optimize-predicate - (cond ((memq 0 form) - (setq form (if (eq (car form) 'logand) - (cons 'progn (cdr form)) - (delq 0 (copy-sequence form))))) - ((and (eq (car-safe form) 'logior) - (memq -1 form)) - (cons 'progn (cdr form))) - (form)))) - - -(defun byte-optimize-binary-predicate (form) - (if (byte-compile-constp (nth 1 form)) - (if (byte-compile-constp (nth 2 form)) - (condition-case () - (list 'quote (eval form)) - (error form)) - ;; This can enable some lapcode optimizations. - (list (car form) (nth 2 form) (nth 1 form))) - form)) - -(defun byte-optimize-predicate (form) - (let ((ok t) - (rest (cdr form))) - (while (and rest ok) - (setq ok (byte-compile-constp (car rest)) - rest (cdr rest))) - (if ok - (condition-case () - (list 'quote (eval form)) - (error form)) - form))) - -(defun byte-optimize-identity (form) - (if (and (cdr form) (null (cdr (cdr form)))) - (nth 1 form) - (byte-compile-warn "identity called with %d arg%s, but requires 1" - (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s")) - form)) - -(put 'identity 'byte-optimizer 'byte-optimize-identity) - -(put '+ 'byte-optimizer 'byte-optimize-plus) -(put '* 'byte-optimizer 'byte-optimize-multiply) -(put '- 'byte-optimizer 'byte-optimize-minus) -(put '/ 'byte-optimizer 'byte-optimize-divide) -(put 'max 'byte-optimizer 'byte-optimize-associative-math) -(put 'min 'byte-optimizer 'byte-optimize-associative-math) - -(put '= 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'eql 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'equal 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate) - -(put '< 'byte-optimizer 'byte-optimize-predicate) -(put '> 'byte-optimizer 'byte-optimize-predicate) -(put '<= 'byte-optimizer 'byte-optimize-predicate) -(put '>= 'byte-optimizer 'byte-optimize-predicate) -(put '1+ 'byte-optimizer 'byte-optimize-predicate) -(put '1- 'byte-optimizer 'byte-optimize-predicate) -(put 'not 'byte-optimizer 'byte-optimize-predicate) -(put 'null 'byte-optimizer 'byte-optimize-predicate) -(put 'memq 'byte-optimizer 'byte-optimize-predicate) -(put 'consp 'byte-optimizer 'byte-optimize-predicate) -(put 'listp 'byte-optimizer 'byte-optimize-predicate) -(put 'symbolp 'byte-optimizer 'byte-optimize-predicate) -(put 'stringp 'byte-optimizer 'byte-optimize-predicate) -(put 'string< 'byte-optimizer 'byte-optimize-predicate) -(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) - -(put 'logand 'byte-optimizer 'byte-optimize-logmumble) -(put 'logior 'byte-optimizer 'byte-optimize-logmumble) -(put 'logxor 'byte-optimizer 'byte-optimize-logmumble) -(put 'lognot 'byte-optimizer 'byte-optimize-predicate) - -(put 'car 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr 'byte-optimizer 'byte-optimize-predicate) -(put 'car-safe 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) - - -;; I'm not convinced that this is necessary. Doesn't the optimizer loop -;; take care of this? - Jamie -;; I think this may some times be necessary to reduce ie (quote 5) to 5, -;; so arithmetic optimizers recognize the numeric constant. - Hallvard -(put 'quote 'byte-optimizer 'byte-optimize-quote) -(defun byte-optimize-quote (form) - (if (or (consp (nth 1 form)) - (and (symbolp (nth 1 form)) - (not (memq (nth 1 form) '(nil t))))) - form - (nth 1 form))) - -(defun byte-optimize-zerop (form) - (cond ((numberp (nth 1 form)) - (eval form)) - (byte-compile-delete-errors - (list '= (nth 1 form) 0)) - (form))) - -(put 'zerop 'byte-optimizer 'byte-optimize-zerop) - -(defun byte-optimize-and (form) - ;; Simplify if less than 2 args. - ;; if there is a literal nil in the args to `and', throw it and following - ;; forms away, and surround the `and' with (progn ... nil). - (cond ((null (cdr form))) - ((memq nil form) - (list 'progn - (byte-optimize-and - (prog1 (setq form (copy-sequence form)) - (while (nth 1 form) - (setq form (cdr form))) - (setcdr form nil))) - nil)) - ((null (cdr (cdr form))) - (nth 1 form)) - ((byte-optimize-predicate form)))) - -(defun byte-optimize-or (form) - ;; Throw away nil's, and simplify if less than 2 args. - ;; If there is a literal non-nil constant in the args to `or', throw away all - ;; following forms. - (if (memq nil form) - (setq form (delq nil (copy-sequence form)))) - (let ((rest form)) - (while (cdr (setq rest (cdr rest))) - (if (byte-compile-trueconstp (car rest)) - (setq form (copy-sequence form) - rest (setcdr (memq (car rest) form) nil)))) - (if (cdr (cdr form)) - (byte-optimize-predicate form) - (nth 1 form)))) - -(defun byte-optimize-cond (form) - ;; if any clauses have a literal nil as their test, throw them away. - ;; if any clause has a literal non-nil constant as its test, throw - ;; away all following clauses. - (let (rest) - ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...) - (while (setq rest (assq nil (cdr form))) - (setq form (delq rest (copy-sequence form)))) - (if (memq nil (cdr form)) - (setq form (delq nil (copy-sequence form)))) - (setq rest form) - (while (setq rest (cdr rest)) - (cond ((byte-compile-trueconstp (car-safe (car rest))) - (cond ((eq rest (cdr form)) - (setq form - (if (cdr (car rest)) - (if (cdr (cdr (car rest))) - (cons 'progn (cdr (car rest))) - (nth 1 (car rest))) - (car (car rest))))) - ((cdr rest) - (setq form (copy-sequence form)) - (setcdr (memq (car rest) form) nil))) - (setq rest nil))))) - ;; - ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... )) - (if (eq 'cond (car-safe form)) - (let ((clauses (cdr form))) - (if (and (consp (car clauses)) - (null (cdr (car clauses)))) - (list 'or (car (car clauses)) - (byte-optimize-cond - (cons (car form) (cdr (cdr form))))) - form)) - form)) - -(defun byte-optimize-if (form) - ;; (if <true-constant> <then> <else...>) ==> <then> - ;; (if <false-constant> <then> <else...>) ==> (progn <else...>) - ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>)) - ;; (if <test> <then> nil) ==> (if <test> <then>) - (let ((clause (nth 1 form))) - (cond ((byte-compile-trueconstp clause) - (nth 2 form)) - ((null clause) - (if (nthcdr 4 form) - (cons 'progn (nthcdr 3 form)) - (nth 3 form))) - ((nth 2 form) - (if (equal '(nil) (nthcdr 3 form)) - (list 'if clause (nth 2 form)) - form)) - ((or (nth 3 form) (nthcdr 4 form)) - (list 'if - ;; Don't make a double negative; - ;; instead, take away the one that is there. - (if (and (consp clause) (memq (car clause) '(not null)) - (= (length clause) 2)) ; (not xxxx) or (not (xxxx)) - (nth 1 clause) - (list 'not clause)) - (if (nthcdr 4 form) - (cons 'progn (nthcdr 3 form)) - (nth 3 form)))) - (t - (list 'progn clause nil))))) - -(defun byte-optimize-while (form) - (if (nth 1 form) - form)) - -(put 'and 'byte-optimizer 'byte-optimize-and) -(put 'or 'byte-optimizer 'byte-optimize-or) -(put 'cond 'byte-optimizer 'byte-optimize-cond) -(put 'if 'byte-optimizer 'byte-optimize-if) -(put 'while 'byte-optimizer 'byte-optimize-while) - -;; byte-compile-negation-optimizer lives in bytecomp.el -(put '/= 'byte-optimizer 'byte-compile-negation-optimizer) -(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer) -(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer) - - -(defun byte-optimize-funcall (form) - ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...) - ;; (funcall 'foo ...) ==> (foo ...) - (let ((fn (nth 1 form))) - (if (memq (car-safe fn) '(quote function)) - (cons (nth 1 fn) (cdr (cdr form))) - form))) - -(defun byte-optimize-apply (form) - ;; If the last arg is a literal constant, turn this into a funcall. - ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...). - (let ((fn (nth 1 form)) - (last (nth (1- (length form)) form))) ; I think this really is fastest - (or (if (or (null last) - (eq (car-safe last) 'quote)) - (if (listp (nth 1 last)) - (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) - (nconc (list 'funcall fn) butlast - (mapcar '(lambda (x) (list 'quote x)) (nth 1 last)))) - (byte-compile-warn - "last arg to apply can't be a literal atom: %s" - (prin1-to-string last)) - nil)) - form))) - -(put 'funcall 'byte-optimizer 'byte-optimize-funcall) -(put 'apply 'byte-optimizer 'byte-optimize-apply) - - -(put 'let 'byte-optimizer 'byte-optimize-letX) -(put 'let* 'byte-optimizer 'byte-optimize-letX) -(defun byte-optimize-letX (form) - (cond ((null (nth 1 form)) - ;; No bindings - (cons 'progn (cdr (cdr form)))) - ((or (nth 2 form) (nthcdr 3 form)) - form) - ;; The body is nil - ((eq (car form) 'let) - (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form))) - '(nil))) - (t - (let ((binds (reverse (nth 1 form)))) - (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil))))) - - -(put 'nth 'byte-optimizer 'byte-optimize-nth) -(defun byte-optimize-nth (form) - (if (and (= (safe-length form) 3) (memq (nth 1 form) '(0 1))) - (list 'car (if (zerop (nth 1 form)) - (nth 2 form) - (list 'cdr (nth 2 form)))) - (byte-optimize-predicate form))) - -(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr) -(defun byte-optimize-nthcdr (form) - (if (and (= (safe-length form) 3) (not (memq (nth 1 form) '(0 1 2)))) - (byte-optimize-predicate form) - (let ((count (nth 1 form))) - (setq form (nth 2 form)) - (while (>= (setq count (1- count)) 0) - (setq form (list 'cdr form))) - form))) - -;;; enumerating those functions which need not be called if the returned -;;; value is not used. That is, something like -;;; (progn (list (something-with-side-effects) (yow)) -;;; (foo)) -;;; may safely be turned into -;;; (progn (progn (something-with-side-effects) (yow)) -;;; (foo)) -;;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo. - -;;; I wonder if I missed any :-\) -(let ((side-effect-free-fns - '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan - assoc assq - boundp buffer-file-name buffer-local-variables buffer-modified-p - buffer-substring - capitalize car-less-than-car car cdr ceiling concat coordinates-in-window-p - copy-marker cos count-lines - default-boundp default-value documentation downcase - elt exp expt fboundp featurep - 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 floor format - get get-buffer get-buffer-window getenv get-file-buffer - int-to-string - length log log10 logand logb logior lognot logxor lsh - marker-buffer max member memq min mod - next-window nth nthcdr number-to-string - parse-colon-path previous-window - radians-to-degrees rassq regexp-quote reverse round - sin sqrt string< string= string-equal string-lessp string-to-char - string-to-int string-to-number substring symbol-plist - tan upcase user-variable-p vconcat - window-buffer window-dedicated-p window-edges window-height - window-hscroll window-minibuffer-p window-width - zerop)) - (side-effect-and-error-free-fns - '(arrayp atom - bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp - car-safe case-table-p cdr-safe char-or-string-p commandp cons consp - current-buffer - dot dot-marker eobp eolp eq eql equal eventp floatp framep - get-largest-window get-lru-window - identity ignore integerp integer-or-marker-p interactive-p - invocation-directory invocation-name - keymapp list listp - make-marker mark mark-marker markerp memory-limit minibuffer-window - mouse-movement-p - natnump nlistp not null number-or-marker-p numberp - one-window-p overlayp - point point-marker point-min point-max processp - selected-window sequencep stringp subrp symbolp syntax-table-p - user-full-name user-login-name user-original-login-name - user-real-login-name user-real-uid user-uid - vector vectorp - window-configuration-p window-live-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))) - (while side-effect-and-error-free-fns - (put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free) - (setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns))) - nil) - - -(defun byte-compile-splice-in-already-compiled-code (form) - ;; form is (byte-code "..." [...] n) - (if (not (memq byte-optimize '(t lap))) - (byte-compile-normal-call form) - (byte-inline-lapcode - (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)) - (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form)) - byte-compile-maxdepth)) - (setq byte-compile-depth (1+ byte-compile-depth)))) - -(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code) - - -(defconst byte-constref-ops - '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) - -;;; This function extracts the bitfields from variable-length opcodes. -;;; Originally defined in disass.el (which no longer uses it.) - -(defun disassemble-offset () - "Don't call this!" - ;; fetch and return the offset for the current opcode. - ;; return NIL if this opcode has no offset - ;; OP, PTR and BYTES are used and set dynamically - (defvar op) - (defvar ptr) - (defvar bytes) - (cond ((< op byte-nth) - (let ((tem (logand op 7))) - (setq op (logand op 248)) - (cond ((eq tem 6) - (setq ptr (1+ ptr)) ;offset in next byte - (aref bytes ptr)) - ((eq tem 7) - (setq ptr (1+ ptr)) ;offset in next 2 bytes - (+ (aref bytes ptr) - (progn (setq ptr (1+ ptr)) - (lsh (aref bytes ptr) 8)))) - (t tem)))) ;offset was in opcode - ((>= op byte-constant) - (prog1 (- op byte-constant) ;offset in opcode - (setq op byte-constant))) - ((and (>= op byte-constant2) - (<= op byte-goto-if-not-nil-else-pop)) - (setq ptr (1+ ptr)) ;offset in next 2 bytes - (+ (aref bytes ptr) - (progn (setq ptr (1+ ptr)) - (lsh (aref bytes ptr) 8)))) - ((and (>= op byte-listN) - (<= op byte-insertN)) - (setq ptr (1+ ptr)) ;offset in next byte - (aref bytes ptr)))) - - -;;; This de-compiler is used for inline expansion of compiled functions, -;;; and by the disassembler. -;;; -;;; This list contains numbers, which are pc values, -;;; before each instruction. -(defun byte-decompile-bytecode (bytes constvec) - "Turns BYTECODE into lapcode, referring to CONSTVEC." - (let ((byte-compile-constants nil) - (byte-compile-variables nil) - (byte-compile-tag-number 0)) - (byte-decompile-bytecode-1 bytes constvec))) - -;; As byte-decompile-bytecode, but updates -;; byte-compile-{constants, variables, tag-number}. -;; If MAKE-SPLICEABLE is true, then `return' opcodes are replaced -;; with `goto's destined for the end of the code. -;; That is for use by the compiler. -;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler. -;; In that case, we put a pc value into the list -;; before each insn (or its label). -(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) - (let ((length (length bytes)) - (ptr 0) optr tag tags op offset - lap tmp - endtag - (retcount 0)) - (while (not (= ptr length)) - (or make-spliceable - (setq lap (cons ptr lap))) - (setq op (aref bytes ptr) - optr ptr - offset (disassemble-offset)) ; this does dynamic-scope magic - (setq op (aref byte-code-vector op)) - (cond ((memq op byte-goto-ops) - ;; it's a pc - (setq offset - (cdr (or (assq offset tags) - (car (setq tags - (cons (cons offset - (byte-compile-make-tag)) - tags))))))) - ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t) - ((memq op byte-constref-ops))) - (setq tmp (aref constvec offset) - offset (if (eq op 'byte-constant) - (byte-compile-get-constant tmp) - (or (assq tmp byte-compile-variables) - (car (setq byte-compile-variables - (cons (list tmp) - byte-compile-variables))))))) - ((and make-spliceable - (eq op 'byte-return)) - (if (= ptr (1- length)) - (setq op nil) - (setq offset (or endtag (setq endtag (byte-compile-make-tag))) - op 'byte-goto)))) - ;; lap = ( [ (pc . (op . arg)) ]* ) - (setq lap (cons (cons optr (cons op (or offset 0))) - lap)) - (setq ptr (1+ ptr))) - ;; take off the dummy nil op that we replaced a trailing "return" with. - (let ((rest lap)) - (while rest - (cond ((numberp (car rest))) - ((setq tmp (assq (car (car rest)) tags)) - ;; this addr is jumped to - (setcdr rest (cons (cons nil (cdr tmp)) - (cdr rest))) - (setq tags (delq tmp tags)) - (setq rest (cdr rest)))) - (setq rest (cdr rest)))) - (if tags (error "optimizer error: missed tags %s" tags)) - (if (null (car (cdr (car lap)))) - (setq lap (cdr lap))) - (if endtag - (setq lap (cons (cons nil endtag) lap))) - ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) - (mapcar (function (lambda (elt) - (if (numberp elt) - elt - (cdr elt)))) - (nreverse lap)))) - - -;;; peephole optimizer - -(defconst byte-tagref-ops (cons 'TAG byte-goto-ops)) - -(defconst byte-conditional-ops - '(byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - -(defconst byte-after-unbind-ops - '(byte-constant byte-dup - byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp - byte-eq byte-equal byte-not - byte-cons byte-list1 byte-list2 ; byte-list3 byte-list4 - byte-interactive-p) - ;; How about other side-effect-free-ops? Is it safe to move an - ;; error invocation (such as from nth) out of an unwind-protect? - "Byte-codes that can be moved past an unbind.") - -(defconst byte-compile-side-effect-and-error-free-ops - '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp - byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe - byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max - byte-point-min byte-following-char byte-preceding-char - byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp - byte-current-buffer byte-interactive-p)) - -(defconst byte-compile-side-effect-free-ops - (nconc - '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref - byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 - byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate - byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax - byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt - byte-member byte-assq byte-quo byte-rem) - byte-compile-side-effect-and-error-free-ops)) - -;;; This crock is because of the way DEFVAR_BOOL variables work. -;;; Consider the code -;;; -;;; (defun foo (flag) -;;; (let ((old-pop-ups pop-up-windows) -;;; (pop-up-windows flag)) -;;; (cond ((not (eq pop-up-windows old-pop-ups)) -;;; (setq old-pop-ups pop-up-windows) -;;; ...)))) -;;; -;;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is -;;; something else. But if we optimize -;;; -;;; varref flag -;;; varbind pop-up-windows -;;; varref pop-up-windows -;;; not -;;; to -;;; varref flag -;;; dup -;;; varbind pop-up-windows -;;; not -;;; -;;; we break the program, because it will appear that pop-up-windows and -;;; old-pop-ups are not EQ when really they are. So we have to know what -;;; the BOOL variables are, and not perform this optimization on them. -;;; -(defconst byte-boolean-vars - '(abbrev-all-caps abbrevs-changed byte-metering-on - cannot-suspend completion-auto-help completion-ignore-case - cursor-in-echo-area debug-on-next-call debug-on-quit - delete-exited-processes enable-recursive-minibuffers - highlight-nonselected-windows indent-tabs-mode inhibit-local-menu-bar-menus - insert-default-directory inverse-video load-force-doc-strings - load-in-progress menu-prompting minibuffer-auto-raise - mode-line-inverse-video multiple-frames no-redraw-on-reenter noninteractive - parse-sexp-ignore-comments pop-up-frames pop-up-windows - print-escape-newlines system-uses-terminfo truncate-partial-width-windows - visible-bell vms-stmlf-recfm words-include-escapes) - "DEFVAR_BOOL variables. Giving these any non-nil value sets them to t. -If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer -may generate incorrect code.") - -(defun byte-optimize-lapcode (lap &optional for-effect) - "Simple peephole optimizer. LAP is both modified and returned." - (let (lap0 off0 - lap1 off1 - lap2 off2 - (keep-going 'first-time) - (add-depth 0) - rest tmp tmp2 tmp3 - (side-effect-free (if byte-compile-delete-errors - byte-compile-side-effect-free-ops - byte-compile-side-effect-and-error-free-ops))) - (while keep-going - (or (eq keep-going 'first-time) - (byte-compile-log-lap " ---- next pass")) - (setq rest lap - keep-going nil) - (while rest - (setq lap0 (car rest) - lap1 (nth 1 rest) - lap2 (nth 2 rest)) - - ;; You may notice that sequences like "dup varset discard" are - ;; optimized but sequences like "dup varset TAG1: discard" are not. - ;; You may be tempted to change this; resist that temptation. - (cond ;; - ;; <side-effect-free> pop --> <deleted> - ;; ...including: - ;; const-X pop --> <deleted> - ;; varref-X pop --> <deleted> - ;; dup pop --> <deleted> - ;; - ((and (eq 'byte-discard (car lap1)) - (memq (car lap0) side-effect-free)) - (setq keep-going t) - (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) - (setq rest (cdr rest)) - (cond ((= tmp 1) - (byte-compile-log-lap - " %s discard\t-->\t<deleted>" lap0) - (setq lap (delq lap0 (delq lap1 lap)))) - ((= tmp 0) - (byte-compile-log-lap - " %s discard\t-->\t<deleted> discard" lap0) - (setq lap (delq lap0 lap))) - ((= tmp -1) - (byte-compile-log-lap - " %s discard\t-->\tdiscard discard" lap0) - (setcar lap0 'byte-discard) - (setcdr lap0 0)) - ((error "Optimizer error: too much on the stack")))) - ;; - ;; goto*-X X: --> X: - ;; - ((and (memq (car lap0) byte-goto-ops) - (eq (cdr lap0) lap1)) - (cond ((eq (car lap0) 'byte-goto) - (setq lap (delq lap0 lap)) - (setq tmp "<deleted>")) - ((memq (car lap0) byte-goto-always-pop-ops) - (setcar lap0 (setq tmp 'byte-discard)) - (setcdr lap0 0)) - ((error "Depth conflict at tag %d" (nth 2 lap0)))) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" - (nth 1 lap1) (nth 1 lap1) - tmp (nth 1 lap1))) - (setq keep-going t)) - ;; - ;; varset-X varref-X --> dup varset-X - ;; varbind-X varref-X --> dup varbind-X - ;; const/dup varset-X varref-X --> const/dup varset-X const/dup - ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup - ;; The latter two can enable other optimizations. - ;; - ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) - (not (eq (car lap0) 'byte-constant))) - nil - (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (memq (car (cdr lap0)) '(nil t))) - (cdr lap0) - (byte-compile-get-constant t))) - (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" - lap0 lap1 lap2 lap0 lap1 - (cons (car lap0) tmp)) - (setcar lap2 (car lap0)) - (setcdr lap2 tmp)) - (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) - (setcar lap2 (car lap1)) - (setcar lap1 'byte-dup) - (setcdr lap1 0) - ;; The stack depth gets locally increased, so we will - ;; increase maxdepth in case depth = maxdepth here. - ;; This can cause the third argument to byte-code to - ;; be larger than necessary. - (setq add-depth 1)))) - ;; - ;; dup varset-X discard --> varset-X - ;; dup varbind-X discard --> varbind-X - ;; (the varbind variant can emerge from other optimizations) - ;; - ((and (eq 'byte-dup (car lap0)) - (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) - (setq keep-going t - rest (cdr rest)) - (setq lap (delq lap0 (delq lap2 lap)))) - ;; - ;; not goto-X-if-nil --> goto-X-if-non-nil - ;; not goto-X-if-non-nil --> goto-X-if-nil - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (eq 'byte-not (car lap0)) - (or (eq 'byte-goto-if-nil (car lap1)) - (eq 'byte-goto-if-not-nil (car lap1)))) - (byte-compile-log-lap " not %s\t-->\t%s" - lap1 - (cons - (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil) - (cdr lap1))) - (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil)) - (setq lap (delq lap0 lap)) - (setq keep-going t)) - ;; - ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: - ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (or (eq 'byte-goto-if-nil (car lap0)) - (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX - (eq 'byte-goto (car lap1)) ; gotoY - (eq (cdr lap0) lap2)) ; TAG X - (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) - 'byte-goto-if-not-nil 'byte-goto-if-nil))) - (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" - lap0 lap1 lap2 - (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) - (setcar lap1 inverse) - (setq keep-going t))) - ;; - ;; const goto-if-* --> whatever - ;; - ((and (eq 'byte-constant (car lap0)) - (memq (car lap1) byte-conditional-ops)) - (cond ((if (or (eq (car lap1) 'byte-goto-if-nil) - (eq (car lap1) 'byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) - (byte-compile-log-lap " %s %s\t-->\t<deleted>" - lap0 lap1) - (setq rest (cdr rest) - lap (delq lap0 (delq lap1 lap)))) - (t - (if (memq (car lap1) byte-goto-always-pop-ops) - (progn - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 (cons 'byte-goto (cdr lap1))) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-goto (cdr lap1)))) - (setcar lap1 'byte-goto))) - (setq keep-going t)) - ;; - ;; varref-X varref-X --> varref-X dup - ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup - ;; We don't optimize the const-X variations on this here, - ;; because that would inhibit some goto optimizations; we - ;; optimize the const-X case after all other optimizations. - ;; - ((and (eq 'byte-varref (car lap0)) - (progn - (setq tmp (cdr rest)) - (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp))) - t) - (eq (cdr lap0) (cdr (car tmp))) - (eq 'byte-varref (car (car tmp)))) - (if (memq byte-optimize-log '(t byte)) - (let ((str "")) - (setq tmp2 (cdr rest)) - (while (not (eq tmp tmp2)) - (setq tmp2 (cdr tmp2) - str (concat str " dup"))) - (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" - lap0 str lap0 lap0 str))) - (setq keep-going t) - (setcar (car tmp) 'byte-dup) - (setcdr (car tmp) 0) - (setq rest tmp)) - ;; - ;; TAG1: TAG2: --> TAG1: <deleted> - ;; (and other references to TAG2 are replaced with TAG1) - ;; - ((and (eq (car lap0) 'TAG) - (eq (car lap1) 'TAG)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " adjacent tags %d and %d merged" - (nth 1 lap1) (nth 1 lap0))) - (setq tmp3 lap) - (while (setq tmp2 (rassq lap0 tmp3)) - (setcdr tmp2 lap1) - (setq tmp3 (cdr (memq tmp2 tmp3)))) - (setq lap (delq lap0 lap) - keep-going t)) - ;; - ;; unused-TAG: --> <deleted> - ;; - ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap))) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " unused tag %d removed" (nth 1 lap0))) - (setq lap (delq lap0 lap) - keep-going t)) - ;; - ;; goto ... --> goto <delete until TAG or end> - ;; return ... --> return <delete until TAG or end> - ;; - ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil)))) - (setq tmp rest) - (let ((i 0) - (opt-p (memq byte-optimize-log '(t lap))) - str deleted) - (while (and (setq tmp (cdr tmp)) - (not (eq 'TAG (car (car tmp))))) - (if opt-p (setq deleted (cons (car tmp) deleted) - str (concat str " %s") - i (1+ i)))) - (if opt-p - (let ((tagstr - (if (eq 'TAG (car (car tmp))) - (format "%d:" (car (cdr (car tmp)))) - (or (car tmp) "")))) - (if (< i 6) - (apply 'byte-compile-log-lap-1 - (concat " %s" str - " %s\t-->\t%s <deleted> %s") - lap0 - (nconc (nreverse deleted) - (list tagstr lap0 tagstr))) - (byte-compile-log-lap - " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" - lap0 i (if (= i 1) "" "s") - tagstr lap0 tagstr)))) - (rplacd rest tmp)) - (setq keep-going t)) - ;; - ;; <safe-op> unbind --> unbind <safe-op> - ;; (this may enable other optimizations.) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) byte-after-unbind-ops)) - (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) - (setcar rest lap1) - (setcar (cdr rest) lap0) - (setq keep-going t)) - ;; - ;; varbind-X unbind-N --> discard unbind-(N-1) - ;; save-excursion unbind-N --> unbind-(N-1) - ;; save-restriction unbind-N --> unbind-(N-1) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) '(byte-varbind byte-save-excursion - byte-save-restriction)) - (< 0 (cdr lap1))) - (if (zerop (setcdr lap1 (1- (cdr lap1)))) - (delq lap1 rest)) - (if (eq (car lap0) 'byte-varbind) - (setcar rest (cons 'byte-discard 0)) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s %s" - lap0 (cons (car lap1) (1+ (cdr lap1))) - (if (eq (car lap0) 'byte-varbind) - (car rest) - (car (cdr rest))) - (if (and (/= 0 (cdr lap1)) - (eq (car lap0) 'byte-varbind)) - (car (cdr rest)) - "")) - (setq keep-going t)) - ;; - ;; goto*-X ... X: goto-Y --> goto*-Y - ;; goto-X ... X: return --> return - ;; - ((and (memq (car lap0) byte-goto-ops) - (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) - '(byte-goto byte-return))) - (cond ((and (not (eq tmp lap0)) - (or (eq (car lap0) 'byte-goto) - (eq (car tmp) 'byte-goto))) - (byte-compile-log-lap " %s [%s]\t-->\t%s" - (car lap0) tmp tmp) - (if (eq (car tmp) 'byte-return) - (setcar lap0 'byte-return)) - (setcdr lap0 (cdr tmp)) - (setq keep-going t)))) - ;; - ;; goto-*-else-pop X ... X: goto-if-* --> whatever - ;; goto-*-else-pop X ... X: discard --> whatever - ;; - ((and (memq (car lap0) '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap0 (car tmp)))) - (setq tmp2 (car tmp)) - (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop - byte-goto-if-nil) - (byte-goto-if-not-nil-else-pop - byte-goto-if-not-nil)))) - (if (memq (car tmp2) tmp3) - (progn (setcar lap0 (car tmp2)) - (setcdr lap0 (cdr tmp2)) - (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" - (car lap0) tmp2 lap0)) - ;; Get rid of the -else-pop's and jump one step further. - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" - (car lap0) tmp2 (nth 1 tmp3)) - (setcar lap0 (nth 1 tmp3)) - (setcdr lap0 (nth 1 tmp))) - (setq keep-going t)) - ;; - ;; const goto-X ... X: goto-if-* --> whatever - ;; const goto-X ... X: discard --> whatever - ;; - ((and (eq (car lap0) 'byte-constant) - (eq (car lap1) 'byte-goto) - (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap1 (car tmp)))) - (setq tmp2 (car tmp)) - (cond ((memq (car tmp2) - (if (null (car (cdr lap0))) - '(byte-goto-if-nil byte-goto-if-nil-else-pop) - '(byte-goto-if-not-nil - byte-goto-if-not-nil-else-pop))) - (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" - lap0 tmp2 lap0 tmp2) - (setcar lap1 (car tmp2)) - (setcdr lap1 (cdr tmp2)) - ;; Let next step fix the (const,goto-if*) sequence. - (setq rest (cons nil rest))) - (t - ;; Jump one step further - (byte-compile-log-lap - " %s goto [%s]\t-->\t<deleted> goto <skip>" - lap0 tmp2) - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)))) - (setq keep-going t)) - ;; - ;; X: varref-Y ... varset-Y goto-X --> - ;; X: varref-Y Z: ... dup varset-Y goto-Z - ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) - ;; (This is so usual for while loops that it is worth handling). - ;; - ((and (eq (car lap1) 'byte-varset) - (eq (car lap2) 'byte-goto) - (not (memq (cdr lap2) rest)) ;Backwards jump - (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) - (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) - ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" - (nth 1 (cdr lap2)) (car tmp) - lap1 lap2 - (nth 1 (cdr lap2)) (car tmp) - (nth 1 newtag) 'byte-dup lap1 - (cons 'byte-goto newtag) - ) - (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) - (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) - (setq add-depth 1) - (setq keep-going t)) - ;; - ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: - ;; (This can pull the loop test to the end of the loop) - ;; - ((and (eq (car lap0) 'byte-goto) - (eq (car lap1) 'TAG) - (eq lap1 - (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) - (memq (car (car tmp)) - '(byte-goto byte-goto-if-nil byte-goto-if-not-nil - byte-goto-if-nil-else-pop))) -;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" -;; lap0 lap1 (cdr lap0) (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - "%s %s: ... %s: %s\t-->\t%s ... %s:" - lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) - (cons (cdr (assq (car (car tmp)) - '((byte-goto-if-nil . byte-goto-if-not-nil) - (byte-goto-if-not-nil . byte-goto-if-nil) - (byte-goto-if-nil-else-pop . - byte-goto-if-not-nil-else-pop) - (byte-goto-if-not-nil-else-pop . - byte-goto-if-nil-else-pop)))) - newtag) - - (nth 1 newtag) - ) - (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) - (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) - ;; We can handle this case but not the -if-not-nil case, - ;; because we won't know which non-nil constant to push. - (setcdr rest (cons (cons 'byte-constant - (byte-compile-get-constant nil)) - (cdr rest)))) - (setcar lap0 (nth 1 (memq (car (car tmp)) - '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil - byte-goto-if-nil - byte-goto-if-not-nil - byte-goto byte-goto)))) - ) - (setq keep-going t)) - ) - (setq rest (cdr rest))) - ) - ;; Cleanup stage: - ;; Rebuild byte-compile-constants / byte-compile-variables. - ;; Simple optimizations that would inhibit other optimizations if they - ;; were done in the optimizing loop, and optimizations which there is no - ;; need to do more than once. - (setq byte-compile-constants nil - byte-compile-variables nil) - (setq rest lap) - (while rest - (setq lap0 (car rest) - lap1 (nth 1 rest)) - (if (memq (car lap0) byte-constref-ops) - (if (eq (cdr lap0) 'byte-constant) - (or (memq (cdr lap0) byte-compile-variables) - (setq byte-compile-variables (cons (cdr lap0) - byte-compile-variables))) - (or (memq (cdr lap0) byte-compile-constants) - (setq byte-compile-constants (cons (cdr lap0) - byte-compile-constants))))) - (cond (;; - ;; const-C varset-X const-C --> const-C dup varset-X - ;; const-C varbind-X const-C --> const-C dup varbind-X - ;; - (and (eq (car lap0) 'byte-constant) - (eq (car (nth 2 rest)) 'byte-constant) - (eq (cdr lap0) (car (nth 2 rest))) - (memq (car lap1) '(byte-varbind byte-varset))) - (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s" - lap0 lap1 lap0 lap0 lap1) - (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1))) - (setcar (cdr rest) (cons 'byte-dup 0)) - (setq add-depth 1)) - ;; - ;; const-X [dup/const-X ...] --> const-X [dup ...] dup - ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup - ;; - ((memq (car lap0) '(byte-constant byte-varref)) - (setq tmp rest - tmp2 nil) - (while (progn - (while (eq 'byte-dup (car (car (setq tmp (cdr tmp)))))) - (and (eq (cdr lap0) (cdr (car tmp))) - (eq (car lap0) (car (car tmp))))) - (setcar tmp (cons 'byte-dup 0)) - (setq tmp2 t)) - (if tmp2 - (byte-compile-log-lap - " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0))) - ;; - ;; unbind-N unbind-M --> unbind-(N+M) - ;; - ((and (eq 'byte-unbind (car lap0)) - (eq 'byte-unbind (car lap1))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-unbind - (+ (cdr lap0) (cdr lap1)))) - (setq keep-going t) - (setq lap (delq lap0 lap)) - (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) - ) - (setq rest (cdr rest))) - (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) - lap) - -(provide 'byte-optimize) - - -;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when this file compiles -;; itself, compile some of its most used recursive functions (at load time). -;; -(eval-when-compile - (or (byte-code-function-p (symbol-function 'byte-optimize-form)) - (assq 'byte-code (symbol-function 'byte-optimize-form)) - (let ((byte-optimize nil) - (byte-compile-warnings nil)) - (mapcar '(lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) - '(byte-optimize-form - byte-optimize-body - byte-optimize-predicate - byte-optimize-binary-predicate - ;; Inserted some more than necessary, to speed it up. - byte-optimize-form-code-walker - byte-optimize-lapcode)))) - nil) - -;;; byte-opt.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el deleted file mode 100644 index 1ffd3cae2ca..00000000000 --- a/lisp/emacs-lisp/bytecomp.el +++ /dev/null @@ -1,3427 +0,0 @@ -;;; bytecomp.el --- compilation of Lisp code into byte code. - -;; Copyright (C) 1985, 1986, 1987, 1992, 1994 Free Software Foundation, Inc. - -;; Author: Jamie Zawinski <jwz@lucid.com> -;; Hallvard Furuseth <hbf@ulrik.uio.no> -;; Keywords: internal - -;; Subsequently modified by RMS. - -;;; This version incorporates changes up to version 2.10 of the -;;; Zawinski-Furuseth compiler. -(defconst byte-compile-version "$Revision: 2.24 $") - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The Emacs Lisp byte compiler. This crunches lisp source into a sort -;; of p-code which takes up less space and can be interpreted faster. -;; The user entry points are byte-compile-file and byte-recompile-directory. - -;;; Code: - -;; ======================================================================== -;; Entry points: -;; byte-recompile-directory, byte-compile-file, -;; batch-byte-compile, batch-byte-recompile-directory, -;; byte-compile, compile-defun, -;; display-call-tree -;; (byte-compile-buffer and byte-compile-and-load-file were turned off -;; because they are not terribly useful and get in the way of completion.) - -;; This version of the byte compiler has the following improvements: -;; + optimization of compiled code: -;; - removal of unreachable code; -;; - removal of calls to side-effectless functions whose return-value -;; is unused; -;; - compile-time evaluation of safe constant forms, such as (consp nil) -;; and (ash 1 6); -;; - open-coding of literal lambdas; -;; - peephole optimization of emitted code; -;; - trivial functions are left uncompiled for speed. -;; + support for inline functions; -;; + compile-time evaluation of arbitrary expressions; -;; + compile-time warning messages for: -;; - functions being redefined with incompatible arglists; -;; - functions being redefined as macros, or vice-versa; -;; - functions or macros defined multiple times in the same file; -;; - functions being called with the incorrect number of arguments; -;; - functions being called which are not defined globally, in the -;; file, or as autoloads; -;; - assignment and reference of undeclared free variables; -;; - various syntax errors; -;; + correct compilation of nested defuns, defmacros, defvars and defsubsts; -;; + correct compilation of top-level uses of macros; -;; + the ability to generate a histogram of functions called. - -;; User customization variables: -;; -;; byte-compile-verbose Whether to report the function currently being -;; compiled in the minibuffer; -;; byte-optimize Whether to do optimizations; this may be -;; t, nil, 'source, or 'byte; -;; byte-optimize-log Whether to report (in excruciating detail) -;; exactly which optimizations have been made. -;; This may be t, nil, 'source, or 'byte; -;; byte-compile-error-on-warn Whether to stop compilation when a warning is -;; produced; -;; byte-compile-delete-errors Whether the optimizer may delete calls or -;; variable references that are side-effect-free -;; except that they may return an error. -;; byte-compile-generate-call-tree Whether to generate a histogram of -;; function calls. This can be useful for -;; finding unused functions, as well as simple -;; performance metering. -;; byte-compile-warnings List of warnings to issue, or t. May contain -;; 'free-vars (references to variables not in the -;; current lexical scope) -;; 'unresolved (calls to unknown functions) -;; 'callargs (lambda calls with args that don't -;; match the lambda's definition) -;; 'redefine (function cell redefined from -;; a macro to a lambda or vice versa, -;; or redefined to take other args) -;; 'obsolete (obsolete variables and functions) -;; byte-compile-compatibility Whether the compiler should -;; generate .elc files which can be loaded into -;; generic emacs 18. -;; emacs-lisp-file-regexp Regexp for the extension of source-files; -;; see also the function byte-compile-dest-file. - -;; New Features: -;; -;; o The form `defsubst' is just like `defun', except that the function -;; generated will be open-coded in compiled code which uses it. This -;; means that no function call will be generated, it will simply be -;; spliced in. Lisp functions calls are very slow, so this can be a -;; big win. -;; -;; You can generally accomplish the same thing with `defmacro', but in -;; that case, the defined procedure can't be used as an argument to -;; mapcar, etc. -;; -;; o You can also open-code one particular call to a function without -;; open-coding all calls. Use the 'inline' form to do this, like so: -;; -;; (inline (foo 1 2 3)) ;; `foo' will be open-coded -;; or... -;; (inline ;; `foo' and `baz' will be -;; (foo 1 2 3 (bar 5)) ;; open-coded, but `bar' will not. -;; (baz 0)) -;; -;; o It is possible to open-code a function in the same file it is defined -;; in without having to load that file before compiling it. the -;; byte-compiler has been modified to remember function definitions in -;; the compilation environment in the same way that it remembers macro -;; definitions. -;; -;; o Forms like ((lambda ...) ...) are open-coded. -;; -;; o The form `eval-when-compile' is like progn, except that the body -;; is evaluated at compile-time. When it appears at top-level, this -;; is analogous to the Common Lisp idiom (eval-when (compile) ...). -;; When it does not appear at top-level, it is similar to the -;; Common Lisp #. reader macro (but not in interpreted code). -;; -;; o The form `eval-and-compile' is similar to eval-when-compile, but -;; the whole form is evalled both at compile-time and at run-time. -;; -;; o The command compile-defun is analogous to eval-defun. -;; -;; o If you run byte-compile-file on a filename which is visited in a -;; buffer, and that buffer is modified, you are asked whether you want -;; to save the buffer before compiling. -;; -;; o byte-compiled files now start with the string `;ELC'. -;; Some versions of `file' can be customized to recognize that. - -(require 'backquote) - -(or (fboundp 'defsubst) - ;; This really ought to be loaded already! - (load-library "byte-run")) - -;;; The feature of compiling in a specific target Emacs version -;;; has been turned off because compile time options are a bad idea. -(defmacro byte-compile-single-version () nil) -(defmacro byte-compile-version-cond (cond) cond) - -;;; The crud you see scattered through this file of the form -;;; (or (and (boundp 'epoch::version) epoch::version) -;;; (string-lessp emacs-version "19")) -;;; is because the Epoch folks couldn't be bothered to follow the -;;; normal emacs version numbering convention. - -;; (if (byte-compile-version-cond -;; (or (and (boundp 'epoch::version) epoch::version) -;; (string-lessp emacs-version "19"))) -;; (progn -;; ;; emacs-18 compatibility. -;; (defvar baud-rate (baud-rate)) ;Define baud-rate if it's undefined -;; -;; (if (byte-compile-single-version) -;; (defmacro byte-code-function-p (x) "Emacs 18 doesn't have these." nil) -;; (defun byte-code-function-p (x) "Emacs 18 doesn't have these." nil)) -;; -;; (or (and (fboundp 'member) -;; ;; avoid using someone else's possibly bogus definition of this. -;; (subrp (symbol-function 'member))) -;; (defun member (elt list) -;; "like memq, but uses equal instead of eq. In v19, this is a subr." -;; (while (and list (not (equal elt (car list)))) -;; (setq list (cdr list))) -;; list)))) - - -(defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms) - "\\.EL\\(;[0-9]+\\)?$" - "\\.el$") - "*Regexp which matches Emacs Lisp source files. -You may want to redefine `byte-compile-dest-file' if you change this.") - -;; This enables file name handlers such as jka-compr -;; to remove parts of the file name that should not be copied -;; through to the output file name. -(defun byte-compiler-base-file-name (filename) - (let ((handler (find-file-name-handler filename - 'byte-compiler-base-file-name))) - (if handler - (funcall handler 'byte-compiler-base-file-name filename) - filename))) - -(or (fboundp 'byte-compile-dest-file) - ;; The user may want to redefine this along with emacs-lisp-file-regexp, - ;; so only define it if it is undefined. - (defun byte-compile-dest-file (filename) - "Convert an Emacs Lisp source file name to a compiled file name." - (setq filename (byte-compiler-base-file-name filename)) - (setq filename (file-name-sans-versions filename)) - (cond ((eq system-type 'vax-vms) - (concat (substring filename 0 (string-match ";" filename)) "c")) - ((string-match emacs-lisp-file-regexp filename) - (concat (substring filename 0 (match-beginning 0)) ".elc")) - (t (concat filename ".elc"))))) - -;; This can be the 'byte-compile property of any symbol. -(autoload 'byte-compile-inline-expand "byte-opt") - -;; This is the entrypoint to the lapcode optimizer pass1. -(autoload 'byte-optimize-form "byte-opt") -;; This is the entrypoint to the lapcode optimizer pass2. -(autoload 'byte-optimize-lapcode "byte-opt") -(autoload 'byte-compile-unfold-lambda "byte-opt") - -;; This is the entry point to the decompiler, which is used by the -;; disassembler. The disassembler just requires 'byte-compile, but -;; that doesn't define this function, so this seems to be a reasonable -;; thing to do. -(autoload 'byte-decompile-bytecode "byte-opt") - -(defvar byte-compile-verbose - (and (not noninteractive) (> baud-rate search-slow-speed)) - "*Non-nil means print messages describing progress of byte-compiler.") - -(defvar byte-compile-compatibility nil - "*Non-nil means generate output that can run in Emacs 18.") - -;; (defvar byte-compile-generate-emacs19-bytecodes -;; (not (or (and (boundp 'epoch::version) epoch::version) -;; (string-lessp emacs-version "19"))) -;; "*If this is true, then the byte-compiler will generate bytecode which -;; makes use of byte-ops which are present only in Emacs 19. Code generated -;; this way can never be run in Emacs 18, and may even cause it to crash.") - -(defvar byte-optimize t - "*Enables optimization in the byte compiler. -nil means don't do any optimization. -t means do all optimizations. -`source' means do source-level optimizations only. -`byte' means do code-level optimizations only.") - -(defvar byte-compile-delete-errors t - "*If non-nil, the optimizer may delete forms that may signal an error. -This includes variable references and calls to functions such as `car'.") - -(defvar byte-compile-dynamic nil - "*If non-nil, compile function bodies so they load lazily. -They are hidden comments in the compiled file, and brought into core when the -function is called. - -To enable this option, make it a file-local variable -in the source file you want it to apply to. -For example, add -*-byte-compile-dynamic: t;-*- on the first line. - -When this option is true, if you load the compiled file and then move it, -the functions you loaded will not be able to run.") - -(defvar byte-compile-dynamic-docstrings t - "*If non-nil, compile doc strings for lazy access. -We bury the doc strings of functions and variables -inside comments in the file, and bring them into core only when they -are actually needed. - -When this option is true, if you load the compiled file and then move it, -you won't be able to find the documentation of anything in that file. - -To disable this option for a certain file, make it a file-local variable -in the source file. For example, add this to the first line: - -*-byte-compile-dynamic-docstrings:nil;-*- -You can also set the variable globally. - -This option is enabled by default because it reduces Emacs memory usage.") - -(defvar byte-optimize-log nil - "*If true, the byte-compiler will log its optimizations into *Compile-Log*. -If this is 'source, then only source-level optimizations will be logged. -If it is 'byte, then only byte-level optimizations will be logged.") - -(defvar byte-compile-error-on-warn nil - "*If true, the byte-compiler reports warnings with `error'.") - -(defconst byte-compile-warning-types - '(redefine callargs free-vars unresolved obsolete)) -(defvar byte-compile-warnings t - "*List of warnings that the byte-compiler should issue (t for all). -Elements of the list may be be: - - free-vars references to variables not in the current lexical scope. - unresolved calls to unknown functions. - callargs lambda calls with args that don't match the definition. - redefine function cell redefined from a macro to a lambda or vice - versa, or redefined to take a different number of arguments. - obsolete obsolete variables and functions. - -See also the macro `byte-compiler-options'.") - -(defvar byte-compile-generate-call-tree nil - "*Non-nil means collect call-graph information when compiling. -This records functions were called and from where. -If the value is t, compilation displays the call graph when it finishes. -If the value is neither t nor nil, compilation asks you whether to display -the graph. - -The call tree only lists functions called, not macros used. Those functions -which the byte-code interpreter knows about directly (eq, cons, etc.) are -not reported. - -The call tree also lists those functions which are not known to be called -\(that is, to which no calls have been compiled). Functions which can be -invoked interactively are excluded from this list.") - -(defconst byte-compile-call-tree nil "Alist of functions and their call tree. -Each element looks like - - \(FUNCTION CALLERS CALLS\) - -where CALLERS is a list of functions that call FUNCTION, and CALLS -is a list of functions for which calls were generated while compiling -FUNCTION.") - -(defvar byte-compile-call-tree-sort 'name - "*If non-nil, sort the call tree. -The values `name', `callers', `calls', `calls+callers' -specify different fields to sort on.") - -;; (defvar byte-compile-overwrite-file t -;; "If nil, old .elc files are deleted before the new is saved, and .elc -;; files will have the same modes as the corresponding .el file. Otherwise, -;; existing .elc files will simply be overwritten, and the existing modes -;; will not be changed. If this variable is nil, then an .elc file which -;; is a symbolic link will be turned into a normal file, instead of the file -;; which the link points to being overwritten.") - -(defvar byte-compile-constants nil - "list of all constants encountered during compilation of this form") -(defvar byte-compile-variables nil - "list of all variables encountered during compilation of this form") -(defvar byte-compile-bound-variables nil - "list of variables bound in the context of the current form; this list -lives partly on the stack.") -(defvar byte-compile-free-references) -(defvar byte-compile-free-assignments) - -(defvar byte-compiler-error-flag) - -(defconst byte-compile-initial-macro-environment - '( -;; (byte-compiler-options . (lambda (&rest forms) -;; (apply 'byte-compiler-options-handler forms))) - (eval-when-compile . (lambda (&rest body) - (list 'quote (eval (byte-compile-top-level - (cons 'progn body)))))) - (eval-and-compile . (lambda (&rest body) - (eval (cons 'progn body)) - (cons 'progn 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.") - -(defvar byte-compile-macro-environment byte-compile-initial-macro-environment - "Alist of macros defined in the file being compiled. -Each element looks like (MACRONAME . DEFINITION). It is -\(MACRONAME . nil) when a macro is redefined as a function.") - -(defvar byte-compile-function-environment nil - "Alist of functions defined in the file being compiled. -This is so we can inline them when necessary. -Each element looks like (FUNCTIONNAME . DEFINITION). It is -\(FUNCTIONNAME . nil) when a function is redefined as a macro.") - -(defvar byte-compile-unresolved-functions nil - "Alist of undefined functions to which calls have been compiled (used for -warnings when the function is later defined with incorrect args).") - -(defvar byte-compile-tag-number 0) -(defvar byte-compile-output nil - "Alist describing contents to put in byte code string. -Each element is (INDEX . VALUE)") -(defvar byte-compile-depth 0 "Current depth of execution stack.") -(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") - - -;;; The byte codes; this information is duplicated in bytecomp.c - -(defconst byte-code-vector nil - "An array containing byte-code names indexed by byte-code values.") - -(defconst byte-stack+-info nil - "An array with the stack adjustment for each byte-code.") - -(defmacro byte-defop (opcode stack-adjust opname &optional docstring) - ;; This is a speed-hack for building the byte-code-vector at compile-time. - ;; We fill in the vector at macroexpand-time, and then after the last call - ;; to byte-defop, we write the vector out as a constant instead of writing - ;; out a bunch of calls to aset. - ;; Actually, we don't fill in the vector itself, because that could make - ;; it problematic to compile big changes to this compiler; we store the - ;; values on its plist, and remove them later in -extrude. - (let ((v1 (or (get 'byte-code-vector 'tmp-compile-time-value) - (put 'byte-code-vector 'tmp-compile-time-value - (make-vector 256 nil)))) - (v2 (or (get 'byte-stack+-info 'tmp-compile-time-value) - (put 'byte-stack+-info 'tmp-compile-time-value - (make-vector 256 nil))))) - (aset v1 opcode opname) - (aset v2 opcode stack-adjust)) - (if docstring - (list 'defconst opname opcode (concat "Byte code opcode " docstring ".")) - (list 'defconst opname opcode))) - -(defmacro byte-extrude-byte-code-vectors () - (prog1 (list 'setq 'byte-code-vector - (get 'byte-code-vector 'tmp-compile-time-value) - 'byte-stack+-info - (get 'byte-stack+-info 'tmp-compile-time-value)) - ;; emacs-18 has no REMPROP. - (put 'byte-code-vector 'tmp-compile-time-value nil) - (put 'byte-stack+-info 'tmp-compile-time-value nil))) - - -;; unused: 0-7 - -;; These opcodes are special in that they pack their argument into the -;; opcode word. -;; -(byte-defop 8 1 byte-varref "for variable reference") -(byte-defop 16 -1 byte-varset "for setting a variable") -(byte-defop 24 -1 byte-varbind "for binding a variable") -(byte-defop 32 0 byte-call "for calling a function") -(byte-defop 40 0 byte-unbind "for unbinding special bindings") -;; codes 8-47 are consumed by the preceding opcodes - -;; unused: 48-55 - -(byte-defop 56 -1 byte-nth) -(byte-defop 57 0 byte-symbolp) -(byte-defop 58 0 byte-consp) -(byte-defop 59 0 byte-stringp) -(byte-defop 60 0 byte-listp) -(byte-defop 61 -1 byte-eq) -(byte-defop 62 -1 byte-memq) -(byte-defop 63 0 byte-not) -(byte-defop 64 0 byte-car) -(byte-defop 65 0 byte-cdr) -(byte-defop 66 -1 byte-cons) -(byte-defop 67 0 byte-list1) -(byte-defop 68 -1 byte-list2) -(byte-defop 69 -2 byte-list3) -(byte-defop 70 -3 byte-list4) -(byte-defop 71 0 byte-length) -(byte-defop 72 -1 byte-aref) -(byte-defop 73 -2 byte-aset) -(byte-defop 74 0 byte-symbol-value) -(byte-defop 75 0 byte-symbol-function) ; this was commented out -(byte-defop 76 -1 byte-set) -(byte-defop 77 -1 byte-fset) ; this was commented out -(byte-defop 78 -1 byte-get) -(byte-defop 79 -2 byte-substring) -(byte-defop 80 -1 byte-concat2) -(byte-defop 81 -2 byte-concat3) -(byte-defop 82 -3 byte-concat4) -(byte-defop 83 0 byte-sub1) -(byte-defop 84 0 byte-add1) -(byte-defop 85 -1 byte-eqlsign) -(byte-defop 86 -1 byte-gtr) -(byte-defop 87 -1 byte-lss) -(byte-defop 88 -1 byte-leq) -(byte-defop 89 -1 byte-geq) -(byte-defop 90 -1 byte-diff) -(byte-defop 91 0 byte-negate) -(byte-defop 92 -1 byte-plus) -(byte-defop 93 -1 byte-max) -(byte-defop 94 -1 byte-min) -(byte-defop 95 -1 byte-mult) ; v19 only -(byte-defop 96 1 byte-point) -(byte-defop 97 0 byte-save-current-buffer - "To make a binding to record the current buffer") -(byte-defop 98 0 byte-goto-char) -(byte-defop 99 0 byte-insert) -(byte-defop 100 1 byte-point-max) -(byte-defop 101 1 byte-point-min) -(byte-defop 102 0 byte-char-after) -(byte-defop 103 1 byte-following-char) -(byte-defop 104 1 byte-preceding-char) -(byte-defop 105 1 byte-current-column) -(byte-defop 106 0 byte-indent-to) -(byte-defop 107 0 byte-scan-buffer-OBSOLETE) ; no longer generated as of v18 -(byte-defop 108 1 byte-eolp) -(byte-defop 109 1 byte-eobp) -(byte-defop 110 1 byte-bolp) -(byte-defop 111 1 byte-bobp) -(byte-defop 112 1 byte-current-buffer) -(byte-defop 113 0 byte-set-buffer) -(byte-defop 114 1 byte-read-char-OBSOLETE) -(byte-defop 115 0 byte-set-mark-OBSOLETE) -(byte-defop 116 1 byte-interactive-p) - -;; These ops are new to v19 -(byte-defop 117 0 byte-forward-char) -(byte-defop 118 0 byte-forward-word) -(byte-defop 119 -1 byte-skip-chars-forward) -(byte-defop 120 -1 byte-skip-chars-backward) -(byte-defop 121 0 byte-forward-line) -(byte-defop 122 0 byte-char-syntax) -(byte-defop 123 -1 byte-buffer-substring) -(byte-defop 124 -1 byte-delete-region) -(byte-defop 125 -1 byte-narrow-to-region) -(byte-defop 126 1 byte-widen) -(byte-defop 127 0 byte-end-of-line) - -;; unused: 128 - -;; These store their argument in the next two bytes -(byte-defop 129 1 byte-constant2 - "for reference to a constant with vector index >= byte-constant-limit") -(byte-defop 130 0 byte-goto "for unconditional jump") -(byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil") -(byte-defop 132 -1 byte-goto-if-not-nil "to pop value and jump if it's not nil") -(byte-defop 133 -1 byte-goto-if-nil-else-pop - "to examine top-of-stack, jump and don't pop it if it's nil, -otherwise pop it") -(byte-defop 134 -1 byte-goto-if-not-nil-else-pop - "to examine top-of-stack, jump and don't pop it if it's non nil, -otherwise pop it") - -(byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'") -(byte-defop 136 -1 byte-discard "to discard one value from stack") -(byte-defop 137 1 byte-dup "to duplicate the top of the stack") - -(byte-defop 138 0 byte-save-excursion - "to make a binding to record the buffer, point and mark") -(byte-defop 139 0 byte-save-window-excursion - "to make a binding to record entire window configuration") -(byte-defop 140 0 byte-save-restriction - "to make a binding to record the current buffer clipping restrictions") -(byte-defop 141 -1 byte-catch - "for catch. Takes, on stack, the tag and an expression for the body") -(byte-defop 142 -1 byte-unwind-protect - "for unwind-protect. Takes, on stack, an expression for the unwind-action") - -;; For condition-case. Takes, on stack, the variable to bind, -;; an expression for the body, and a list of clauses. -(byte-defop 143 -2 byte-condition-case) - -;; For entry to with-output-to-temp-buffer. -;; Takes, on stack, the buffer name. -;; Binds standard-output and does some other things. -;; Returns with temp buffer on the stack in place of buffer name. -(byte-defop 144 0 byte-temp-output-buffer-setup) - -;; For exit from with-output-to-temp-buffer. -;; Expects the temp buffer on the stack underneath value to return. -;; Pops them both, then pushes the value back on. -;; Unbinds standard-output and makes the temp buffer visible. -(byte-defop 145 -1 byte-temp-output-buffer-show) - -;; these ops are new to v19 - -;; To unbind back to the beginning of this frame. -;; Not used yet, but will be needed for tail-recursion elimination. -(byte-defop 146 0 byte-unbind-all) - -;; these ops are new to v19 -(byte-defop 147 -2 byte-set-marker) -(byte-defop 148 0 byte-match-beginning) -(byte-defop 149 0 byte-match-end) -(byte-defop 150 0 byte-upcase) -(byte-defop 151 0 byte-downcase) -(byte-defop 152 -1 byte-string=) -(byte-defop 153 -1 byte-string<) -(byte-defop 154 -1 byte-equal) -(byte-defop 155 -1 byte-nthcdr) -(byte-defop 156 -1 byte-elt) -(byte-defop 157 -1 byte-member) -(byte-defop 158 -1 byte-assq) -(byte-defop 159 0 byte-nreverse) -(byte-defop 160 -1 byte-setcar) -(byte-defop 161 -1 byte-setcdr) -(byte-defop 162 0 byte-car-safe) -(byte-defop 163 0 byte-cdr-safe) -(byte-defop 164 -1 byte-nconc) -(byte-defop 165 -1 byte-quo) -(byte-defop 166 -1 byte-rem) -(byte-defop 167 0 byte-numberp) -(byte-defop 168 0 byte-integerp) - -;; unused: 169-174 -(byte-defop 175 nil byte-listN) -(byte-defop 176 nil byte-concatN) -(byte-defop 177 nil byte-insertN) - -;; unused: 178-191 - -(byte-defop 192 1 byte-constant "for reference to a constant") -;; codes 193-255 are consumed by byte-constant. -(defconst byte-constant-limit 64 - "Exclusive maximum index usable in the `byte-constant' opcode.") - -(defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil - byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop) - "List of byte-codes whose offset is a pc.") - -(defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil)) - -(byte-extrude-byte-code-vectors) - -;;; lapcode generator -;;; -;;; the byte-compiler now does source -> lapcode -> bytecode instead of -;;; source -> bytecode, because it's a lot easier to make optimizations -;;; on lapcode than on bytecode. -;;; -;;; Elements of the lapcode list are of the form (<instruction> . <parameter>) -;;; where instruction is a symbol naming a byte-code instruction, -;;; and parameter is an argument to that instruction, if any. -;;; -;;; The instruction can be the pseudo-op TAG, which means that this position -;;; in the instruction stream is a target of a goto. (car PARAMETER) will be -;;; the PC for this location, and the whole instruction "(TAG pc)" will be the -;;; parameter for some goto op. -;;; -;;; If the operation is varbind, varref, varset or push-constant, then the -;;; parameter is (variable/constant . index_in_constant_vector). -;;; -;;; First, the source code is macroexpanded and optimized in various ways. -;;; Then the resultant code is compiled into lapcode. Another set of -;;; optimizations are then run over the lapcode. Then the variables and -;;; constants referenced by the lapcode are collected and placed in the -;;; constants-vector. (This happens now so that variables referenced by dead -;;; code don't consume space.) And finally, the lapcode is transformed into -;;; compacted byte-code. -;;; -;;; A distinction is made between variables and constants because the variable- -;;; referencing instructions are more sensitive to the variables being near the -;;; front of the constants-vector than the constant-referencing instructions. -;;; Also, this lets us notice references to free variables. - -(defun byte-compile-lapcode (lap) - "Turns lapcode into bytecode. The lapcode is destroyed." - ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. - (let ((pc 0) ; Program counter - op off ; Operation & offset - (bytes '()) ; Put the output bytes here - (patchlist nil) ; List of tags and goto's to patch - rest rel tmp) - (while lap - (setq op (car (car lap)) - off (cdr (car lap))) - (cond ((not (symbolp op)) - (error "Non-symbolic opcode `%s'" op)) - ((eq op 'TAG) - (setcar off pc) - (setq patchlist (cons off patchlist))) - ((memq op byte-goto-ops) - (setq pc (+ pc 3)) - (setq bytes (cons (cons pc (cdr off)) - (cons nil - (cons (symbol-value op) bytes)))) - (setq patchlist (cons bytes patchlist))) - (t - (setq bytes - (cond ((cond ((consp off) - ;; Variable or constant reference - (setq off (cdr off)) - (eq op 'byte-constant))) - (cond ((< off byte-constant-limit) - (setq pc (1+ pc)) - (cons (+ byte-constant off) bytes)) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons byte-constant2 bytes)))))) - ((<= byte-listN (symbol-value op)) - (setq pc (+ 2 pc)) - (cons off (cons (symbol-value op) bytes))) - ((< off 6) - (setq pc (1+ pc)) - (cons (+ (symbol-value op) off) bytes)) - ((< off 256) - (setq pc (+ 2 pc)) - (cons off (cons (+ (symbol-value op) 6) bytes))) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons (+ (symbol-value op) 7) - bytes)))))))) - (setq lap (cdr lap))) - ;;(if (not (= pc (length bytes))) - ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) - ;; Patch PC into jumps - (let (bytes) - (while patchlist - (setq bytes (car patchlist)) - (cond ((atom (car bytes))) ; Tag - (t ; Absolute jump - (setq pc (car (cdr (car bytes)))) ; Pick PC from tag - (setcar (cdr bytes) (logand pc 255)) - (setcar bytes (lsh pc -8)))) - (setq patchlist (cdr patchlist)))) - (concat (nreverse bytes)))) - - -;;; byte compiler messages - -(defvar byte-compile-current-form nil) -(defvar byte-compile-current-file nil) -(defvar byte-compile-dest-file nil) - -(defmacro byte-compile-log (format-string &rest args) - (list 'and - 'byte-optimize - '(memq byte-optimize-log '(t source)) - (list 'let '((print-escape-newlines t) - (print-level 4) - (print-length 4)) - (list 'byte-compile-log-1 - (cons 'format - (cons format-string - (mapcar - '(lambda (x) - (if (symbolp x) (list 'prin1-to-string x) x)) - args))))))) - -(defconst byte-compile-last-warned-form nil) - -;; Log a message STRING in *Compile-Log*. -;; Also log the current function and file if not already done. -(defun byte-compile-log-1 (string &optional fill) - (cond (noninteractive - (if (or byte-compile-current-file - (and byte-compile-last-warned-form - (not (eq byte-compile-current-form - byte-compile-last-warned-form)))) - (message "While compiling %s%s:" - (or byte-compile-current-form "toplevel forms") - (if byte-compile-current-file - (if (stringp byte-compile-current-file) - (concat " in file " byte-compile-current-file) - (concat " in buffer " - (buffer-name byte-compile-current-file))) - ""))) - (message " %s" string)) - (t - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) - (goto-char (point-max)) - (cond ((or byte-compile-current-file - (and byte-compile-last-warned-form - (not (eq byte-compile-current-form - byte-compile-last-warned-form)))) - (if byte-compile-current-file - (insert "\n\^L\n" (current-time-string) "\n")) - (insert "While compiling " - (if byte-compile-current-form - (format "%s" byte-compile-current-form) - "toplevel forms")) - (if byte-compile-current-file - (if (stringp byte-compile-current-file) - (insert " in file " byte-compile-current-file) - (insert " in buffer " - (buffer-name byte-compile-current-file)))) - (insert ":\n"))) - (insert " " string "\n") - (if (and fill (not (string-match "\n" string))) - (let ((fill-prefix " ") - (fill-column 78)) - (fill-paragraph nil))) - ))) - (setq byte-compile-current-file nil - byte-compile-last-warned-form byte-compile-current-form)) - -;; Log the start of a file in *Compile-Log*, and mark it as done. -;; But do nothing in batch mode. -(defun byte-compile-log-file () - (and byte-compile-current-file (not noninteractive) - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) - (goto-char (point-max)) - (insert "\n\^L\nCompiling " - (if (stringp byte-compile-current-file) - (concat "file " byte-compile-current-file) - (concat "buffer " (buffer-name byte-compile-current-file))) - " at " (current-time-string) "\n") - (setq byte-compile-current-file nil)))) - -(defun byte-compile-warn (format &rest args) - (setq format (apply 'format format args)) - (if byte-compile-error-on-warn - (error "%s" format) ; byte-compile-file catches and logs it - (byte-compile-log-1 (concat "** " format) t) -;;; It is useless to flash warnings too fast to be read. -;;; Besides, they will all be shown at the end. -;;; (or noninteractive ; already written on stdout. -;;; (message "Warning: %s" format)) - )) - -;;; This function should be used to report errors that have halted -;;; compilation of the current file. -(defun byte-compile-report-error (error-info) - (setq byte-compiler-error-flag t) - (byte-compile-log-1 - (concat "!! " - (format (if (cdr error-info) "%s (%s)" "%s") - (get (car error-info) 'error-message) - (prin1-to-string (cdr error-info)))))) - -;;; Used by make-obsolete. -(defun byte-compile-obsolete (form) - (let ((new (get (car form) 'byte-obsolete-info))) - (if (memq 'obsolete byte-compile-warnings) - (byte-compile-warn "%s is an obsolete function; %s" (car form) - (if (stringp (car new)) - (car new) - (format "use %s instead." (car new))))) - (funcall (or (cdr new) 'byte-compile-normal-call) form))) - -;; Compiler options - -;; (defvar byte-compiler-valid-options -;; '((optimize byte-optimize (t nil source byte) val) -;; (file-format byte-compile-compatibility (emacs18 emacs19) -;; (eq val 'emacs18)) -;; ;; (new-bytecodes byte-compile-generate-emacs19-bytecodes (t nil) val) -;; (delete-errors byte-compile-delete-errors (t nil) val) -;; (verbose byte-compile-verbose (t nil) val) -;; (warnings byte-compile-warnings ((callargs redefine free-vars unresolved)) -;; val))) - -;; Inhibit v18/v19 selectors if the version is hardcoded. -;; #### This should print a warning if the user tries to change something -;; than can't be changed because the running compiler doesn't support it. -;; (cond -;; ((byte-compile-single-version) -;; (setcar (cdr (cdr (assq 'new-bytecodes byte-compiler-valid-options))) -;; (list (byte-compile-version-cond -;; byte-compile-generate-emacs19-bytecodes))) -;; (setcar (cdr (cdr (assq 'file-format byte-compiler-valid-options))) -;; (if (byte-compile-version-cond byte-compile-compatibility) -;; '(emacs18) '(emacs19))))) - -;; (defun byte-compiler-options-handler (&rest args) -;; (let (key val desc choices) -;; (while args -;; (if (or (atom (car args)) (nthcdr 2 (car args)) (null (cdr (car args)))) -;; (error "Malformed byte-compiler option `%s'" (car args))) -;; (setq key (car (car args)) -;; val (car (cdr (car args))) -;; desc (assq key byte-compiler-valid-options)) -;; (or desc -;; (error "Unknown byte-compiler option `%s'" key)) -;; (setq choices (nth 2 desc)) -;; (if (consp (car choices)) -;; (let (this -;; (handler 'cons) -;; (ret (and (memq (car val) '(+ -)) -;; (copy-sequence (if (eq t (symbol-value (nth 1 desc))) -;; choices -;; (symbol-value (nth 1 desc))))))) -;; (setq choices (car choices)) -;; (while val -;; (setq this (car val)) -;; (cond ((memq this choices) -;; (setq ret (funcall handler this ret))) -;; ((eq this '+) (setq handler 'cons)) -;; ((eq this '-) (setq handler 'delq)) -;; ((error "`%s' only accepts %s" key choices))) -;; (setq val (cdr val))) -;; (set (nth 1 desc) ret)) -;; (or (memq val choices) -;; (error "`%s' must be one of `%s'" key choices)) -;; (set (nth 1 desc) (eval (nth 3 desc)))) -;; (setq args (cdr args))) -;; nil)) - -;;; sanity-checking arglists - -(defun byte-compile-fdefinition (name macro-p) - (let* ((list (if macro-p - byte-compile-macro-environment - byte-compile-function-environment)) - (env (cdr (assq name list)))) - (or env - (let ((fn name)) - (while (and (symbolp fn) - (fboundp fn) - (or (symbolp (symbol-function fn)) - (consp (symbol-function fn)) - (and (not macro-p) - (byte-code-function-p (symbol-function fn))))) - (setq fn (symbol-function fn))) - (if (and (not macro-p) (byte-code-function-p fn)) - fn - (and (consp fn) - (if (eq 'macro (car fn)) - (cdr fn) - (if macro-p - nil - (if (eq 'autoload (car fn)) - nil - fn))))))))) - -(defun byte-compile-arglist-signature (arglist) - (let ((args 0) - opts - restp) - (while arglist - (cond ((eq (car arglist) '&optional) - (or opts (setq opts 0))) - ((eq (car arglist) '&rest) - (if (cdr arglist) - (setq restp t - arglist nil))) - (t - (if opts - (setq opts (1+ opts)) - (setq args (1+ args))))) - (setq arglist (cdr arglist))) - (cons args (if restp nil (if opts (+ args opts) args))))) - - -(defun byte-compile-arglist-signatures-congruent-p (old new) - (not (or - (> (car new) (car old)) ; requires more args now - (and (null (cdr old)) ; took rest-args, doesn't any more - (cdr new)) - (and (cdr new) (cdr old) ; can't take as many args now - (< (cdr new) (cdr old))) - ))) - -(defun byte-compile-arglist-signature-string (signature) - (cond ((null (cdr signature)) - (format "%d+" (car signature))) - ((= (car signature) (cdr signature)) - (format "%d" (car signature))) - (t (format "%d-%d" (car signature) (cdr signature))))) - - -;; Warn if the form is calling a function with the wrong number of arguments. -(defun byte-compile-callargs-warn (form) - (let* ((def (or (byte-compile-fdefinition (car form) nil) - (byte-compile-fdefinition (car form) t))) - (sig (and def (byte-compile-arglist-signature - (if (eq 'lambda (car-safe def)) - (nth 1 def) - (if (byte-code-function-p def) - (aref def 0) - '(&rest def)))))) - (ncall (length (cdr form)))) - (if sig - (if (or (< ncall (car sig)) - (and (cdr sig) (> ncall (cdr sig)))) - (byte-compile-warn - "%s called with %d argument%s, but %s %s" - (car form) ncall - (if (= 1 ncall) "" "s") - (if (< ncall (car sig)) - "requires" - "accepts only") - (byte-compile-arglist-signature-string sig))) - (or (fboundp (car form)) ; might be a subr or autoload. - (eq (car form) byte-compile-current-form) ; ## this doesn't work with recursion. - ;; It's a currently-undefined function. Remember number of args in call. - (let ((cons (assq (car form) byte-compile-unresolved-functions)) - (n (length (cdr form)))) - (if cons - (or (memq n (cdr cons)) - (setcdr cons (cons n (cdr cons)))) - (setq byte-compile-unresolved-functions - (cons (list (car form) n) - byte-compile-unresolved-functions)))))))) - -;; Warn if the function or macro is being redefined with a different -;; number of arguments. -(defun byte-compile-arglist-warn (form macrop) - (let ((old (byte-compile-fdefinition (nth 1 form) macrop))) - (if old - (let ((sig1 (byte-compile-arglist-signature - (if (eq 'lambda (car-safe old)) - (nth 1 old) - (if (byte-code-function-p old) - (aref old 0) - '(&rest def))))) - (sig2 (byte-compile-arglist-signature (nth 2 form)))) - (or (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-warn "%s %s used to take %s %s, now takes %s" - (if (eq (car form) 'defun) "function" "macro") - (nth 1 form) - (byte-compile-arglist-signature-string sig1) - (if (equal sig1 '(1 . 1)) "argument" "arguments") - (byte-compile-arglist-signature-string sig2)))) - ;; This is the first definition. See if previous calls are compatible. - (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions)) - nums sig min max) - (if calls - (progn - (setq sig (byte-compile-arglist-signature (nth 2 form)) - nums (sort (copy-sequence (cdr calls)) (function <)) - min (car nums) - max (car (nreverse nums))) - (if (or (< min (car sig)) - (and (cdr sig) (> max (cdr sig)))) - (byte-compile-warn - "%s being defined to take %s%s, but was previously called with %s" - (nth 1 form) - (byte-compile-arglist-signature-string sig) - (if (equal sig '(1 . 1)) " arg" " args") - (byte-compile-arglist-signature-string (cons min max)))) - - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))) - ))) - -;; If we have compiled any calls to functions which are not known to be -;; defined, issue a warning enumerating them. -;; `unresolved' in the list `byte-compile-warnings' disables this. -(defun byte-compile-warn-about-unresolved-functions () - (if (memq 'unresolved byte-compile-warnings) - (let ((byte-compile-current-form "the end of the data")) - (if (cdr byte-compile-unresolved-functions) - (let* ((str "The following functions are not known to be defined: ") - (L (length str)) - (rest (reverse byte-compile-unresolved-functions)) - s) - (while rest - (setq s (symbol-name (car (car rest))) - L (+ L (length s) 2) - rest (cdr rest)) - (if (< L (1- fill-column)) - (setq str (concat str " " s (and rest ","))) - (setq str (concat str "\n " s (and rest ",")) - L (+ (length s) 4)))) - (byte-compile-warn "%s" str)) - (if byte-compile-unresolved-functions - (byte-compile-warn "the function %s is not known to be defined." - (car (car byte-compile-unresolved-functions))))))) - nil) - - -(defmacro byte-compile-constp (form) - ;; Returns non-nil if FORM is a constant. - (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) - ((not (symbolp (, form)))) - ((memq (, form) '(nil t)))))) - -(defmacro byte-compile-close-variables (&rest body) - (cons 'let - (cons '(;; - ;; Close over these variables to encapsulate the - ;; compilation state - ;; - (byte-compile-macro-environment - ;; Copy it because the compiler may patch into the - ;; macroenvironment. - (copy-alist byte-compile-initial-macro-environment)) - (byte-compile-function-environment nil) - (byte-compile-bound-variables nil) - (byte-compile-free-references nil) - (byte-compile-free-assignments nil) - ;; - ;; Close over these variables so that `byte-compiler-options' - ;; can change them on a per-file basis. - ;; - (byte-compile-verbose byte-compile-verbose) - (byte-optimize byte-optimize) - (byte-compile-compatibility byte-compile-compatibility) - (byte-compile-dynamic byte-compile-dynamic) - (byte-compile-dynamic-docstrings - byte-compile-dynamic-docstrings) -;; (byte-compile-generate-emacs19-bytecodes -;; byte-compile-generate-emacs19-bytecodes) - (byte-compile-warnings (if (eq byte-compile-warnings t) - byte-compile-warning-types - byte-compile-warnings)) - ) - body))) - -(defvar byte-compile-warnings-point-max nil) -(defmacro displaying-byte-compile-warnings (&rest body) - (list 'let - '((byte-compile-warnings-point-max byte-compile-warnings-point-max)) - ;; Log the file name. - '(byte-compile-log-file) - ;; Record how much is logged now. - ;; We will display the log buffer if anything more is logged - ;; before the end of BODY. - '(or byte-compile-warnings-point-max - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) - (setq byte-compile-warnings-point-max (point-max)))) - (list 'unwind-protect - (list 'condition-case 'error-info - (cons 'progn body) - '(error - (byte-compile-report-error error-info))) - '(save-excursion - ;; If there were compilation warnings, display them. - (set-buffer "*Compile-Log*") - (if (= byte-compile-warnings-point-max (point-max)) - nil - (select-window - (prog1 (selected-window) - (select-window (display-buffer (current-buffer))) - (goto-char byte-compile-warnings-point-max) - (recenter 1)))))))) - - -;;;###autoload -(defun byte-force-recompile (directory) - "Recompile every `.el' file in DIRECTORY that already has a `.elc' file. -Files in subdirectories of DIRECTORY are processed also." - (interactive "DByte force recompile (directory): ") - (byte-recompile-directory directory nil t)) - -;;;###autoload -(defun byte-recompile-directory (directory &optional arg force) - "Recompile every `.el' file in DIRECTORY that needs recompilation. -This is if a `.elc' file exists but is older than the `.el' file. -Files in subdirectories of DIRECTORY are processed also. - -If the `.elc' file does not exist, normally the `.el' file is *not* compiled. -But a prefix argument (optional second arg) means ask user, -for each such `.el' file, whether to compile it. Prefix argument 0 means -don't ask and compile the file anyway. - -A nonzero prefix argument also means ask about each subdirectory. - -If the third argument FORCE is non-nil, -recompile every `.el' file that already has a `.elc' file." - (interactive "DByte recompile directory: \nP") - (if arg - (setq arg (prefix-numeric-value arg))) - (if noninteractive - nil - (save-some-buffers) - (force-mode-line-update)) - (let ((directories (list (expand-file-name directory))) - (file-count 0) - (dir-count 0) - last-dir) - (displaying-byte-compile-warnings - (while directories - (setq directory (car directories)) - (or noninteractive (message "Checking %s..." directory)) - (let ((files (directory-files directory)) - source dest) - (while files - (setq source (expand-file-name (car files) directory)) - (if (and (not (member (car files) '("." ".." "RCS" "CVS"))) - (file-directory-p source) - (not (file-symlink-p source))) - ;; This file is a subdirectory. Handle them differently. - (if (or (null arg) - (eq 0 arg) - (y-or-n-p (concat "Check " source "? "))) - (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) - (not (auto-save-file-name-p source)) - (setq dest (byte-compile-dest-file source)) - (if (file-exists-p dest) - ;; File was already compiled. - (or force (file-newer-than-file-p source dest)) - ;; No compiled file exists yet. - (and arg - (or (eq 0 arg) - (y-or-n-p (concat "Compile " source "? ")))))) - (progn (if (and noninteractive (not byte-compile-verbose)) - (message "Compiling %s..." source)) - (byte-compile-file source) - (or noninteractive - (message "Checking %s..." directory)) - (setq file-count (1+ file-count)) - (if (not (eq last-dir directory)) - (setq last-dir directory - dir-count (1+ dir-count))) - ))) - (setq files (cdr files)))) - (setq directories (cdr directories)))) - (message "Done (Total of %d file%s compiled%s)" - file-count (if (= file-count 1) "" "s") - (if (> dir-count 1) (format " in %d directories" dir-count) "")))) - -;;;###autoload -(defun byte-compile-file (filename &optional load) - "Compile a file of Lisp code named FILENAME into a file of byte code. -The output file's name is made by appending `c' to the end of FILENAME. -With prefix arg (noninteractively: 2nd arg), load the file after compiling." -;; (interactive "fByte compile file: \nP") - (interactive - (let ((file buffer-file-name) - (file-name nil) - (file-dir nil)) - (and file - (eq (cdr (assq 'major-mode (buffer-local-variables))) - 'emacs-lisp-mode) - (setq file-name (file-name-nondirectory file) - file-dir (file-name-directory file))) - (list (read-file-name (if current-prefix-arg - "Byte compile and load file: " - "Byte compile file: ") - file-dir file-name nil) - current-prefix-arg))) - ;; Expand now so we get the current buffer's defaults - (setq filename (expand-file-name filename)) - - ;; If we're compiling a file that's in a buffer and is modified, offer - ;; to save it first. - (or noninteractive - (let ((b (get-file-buffer (expand-file-name filename)))) - (if (and b (buffer-modified-p b) - (y-or-n-p (format "save buffer %s first? " (buffer-name b)))) - (save-excursion (set-buffer b) (save-buffer))))) - - (if byte-compile-verbose - (message "Compiling %s..." filename)) - (let ((byte-compile-current-file filename) - target-file input-buffer output-buffer - byte-compile-dest-file) - (setq target-file (byte-compile-dest-file filename)) - (setq byte-compile-dest-file target-file) - (save-excursion - (setq input-buffer (get-buffer-create " *Compiler Input*")) - (set-buffer input-buffer) - (erase-buffer) - (insert-file-contents filename) - ;; Run hooks including the uncompression hook. - ;; If they change the file name, then change it for the output also. - (let ((buffer-file-name filename) - (default-major-mode 'emacs-lisp-mode) - (enable-local-eval nil)) - (normal-mode) - (setq filename buffer-file-name)) - ;; Set the default directory, in case an eval-when-compile uses it. - (setq default-directory (file-name-directory filename))) - (setq byte-compiler-error-flag nil) - ;; It is important that input-buffer not be current at this call, - ;; so that the value of point set in input-buffer - ;; within byte-compile-from-buffer lingers in that buffer. - (setq output-buffer (byte-compile-from-buffer input-buffer filename)) - (if byte-compiler-error-flag - nil - (if byte-compile-verbose - (message "Compiling %s...done" filename)) - (kill-buffer input-buffer) - (save-excursion - (set-buffer output-buffer) - (goto-char (point-max)) - (insert "\n") ; aaah, unix. - (let ((vms-stmlf-recfm t)) - (if (file-writable-p target-file) - (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki - (if (or (eq system-type 'ms-dos) (eq system-type 'windows-nt)) - (setq buffer-file-type t)) - (write-region 1 (point-max) target-file)) - ;; This is just to give a better error message than - ;; write-region - (signal 'file-error - (list "Opening output file" - (if (file-exists-p target-file) - "cannot overwrite file" - "directory not writable or nonexistent") - target-file)))) - (kill-buffer (current-buffer))) - (if (and byte-compile-generate-call-tree - (or (eq t byte-compile-generate-call-tree) - (y-or-n-p (format "Report call tree for %s? " filename)))) - (save-excursion - (display-call-tree filename))) - (if load - (load target-file)) - t))) - -;;(defun byte-compile-and-load-file (&optional filename) -;; "Compile a file of Lisp code named FILENAME into a file of byte code, -;;and then load it. The output file's name is made by appending \"c\" to -;;the end of FILENAME." -;; (interactive) -;; (if filename ; I don't get it, (interactive-p) doesn't always work -;; (byte-compile-file filename t) -;; (let ((current-prefix-arg '(4))) -;; (call-interactively 'byte-compile-file)))) - -;;(defun byte-compile-buffer (&optional buffer) -;; "Byte-compile and evaluate contents of BUFFER (default: the current buffer)." -;; (interactive "bByte compile buffer: ") -;; (setq buffer (if buffer (get-buffer buffer) (current-buffer))) -;; (message "Compiling %s..." (buffer-name buffer)) -;; (let* ((filename (or (buffer-file-name buffer) -;; (concat "#<buffer " (buffer-name buffer) ">"))) -;; (byte-compile-current-file buffer)) -;; (byte-compile-from-buffer buffer nil)) -;; (message "Compiling %s...done" (buffer-name buffer)) -;; t) - -;;; compiling a single function -;;;###autoload -(defun compile-defun (&optional arg) - "Compile and evaluate the current top-level form. -Print the result in the minibuffer. -With argument, insert value in current buffer after the form." - (interactive "P") - (save-excursion - (end-of-defun) - (beginning-of-defun) - (let* ((byte-compile-current-file nil) - (byte-compile-last-warned-form 'nothing) - (value (eval (displaying-byte-compile-warnings - (byte-compile-sexp (read (current-buffer))))))) - (cond (arg - (message "Compiling from buffer... done.") - (prin1 value (current-buffer)) - (insert "\n")) - ((message "%s" (prin1-to-string value))))))) - - -(defun byte-compile-from-buffer (inbuffer &optional filename) - ;; Filename is used for the loading-into-Emacs-18 error message. - (let (outbuffer - ;; Prevent truncation of flonums and lists as we read and print them - (float-output-format nil) - (case-fold-search nil) - (print-length nil) - (print-level nil) - ;; Simulate entry to byte-compile-top-level - (byte-compile-constants nil) - (byte-compile-variables nil) - (byte-compile-tag-number 0) - (byte-compile-depth 0) - (byte-compile-maxdepth 0) - (byte-compile-output nil) - ;; #### This is bound in b-c-close-variables. - ;; (byte-compile-warnings (if (eq byte-compile-warnings t) - ;; byte-compile-warning-types - ;; byte-compile-warnings)) - ) - (byte-compile-close-variables - (save-excursion - (setq outbuffer - (set-buffer (get-buffer-create " *Compiler Output*"))) - (erase-buffer) - ;; (emacs-lisp-mode) - (setq case-fold-search nil) - (and filename (byte-compile-insert-header filename inbuffer outbuffer)) - - ;; This is a kludge. Some operating systems (OS/2, DOS) need to - ;; write files containing binary information specially. - ;; Under most circumstances, such files will be in binary - ;; overwrite mode, so those OS's use that flag to guess how - ;; they should write their data. Advise them that .elc files - ;; need to be written carefully. - (setq overwrite-mode 'overwrite-mode-binary)) - (displaying-byte-compile-warnings - (save-excursion - (set-buffer inbuffer) - (goto-char 1) - - ;; Compile the forms from the input buffer. - (while (progn - (while (progn (skip-chars-forward " \t\n\^l") - (looking-at ";")) - (forward-line 1)) - (not (eobp))) - (byte-compile-file-form (read inbuffer))) - - ;; Compile pending forms at end of file. - (byte-compile-flush-pending) - (byte-compile-warn-about-unresolved-functions) - ;; Should we always do this? When calling multiple files, it - ;; would be useful to delay this warning until all have - ;; been compiled. - (setq byte-compile-unresolved-functions nil)))) - outbuffer)) - -(defun byte-compile-insert-header (filename inbuffer outbuffer) - (set-buffer inbuffer) - (let ((dynamic-docstrings byte-compile-dynamic-docstrings) - (dynamic byte-compile-dynamic)) - (set-buffer outbuffer) - (goto-char 1) - ;; - ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After that is - ;; the file-format version number (18 or 19) as a byte, followed by some - ;; nulls. The primary motivation for doing this is to get some binary - ;; characters up in the first line of the file so that `diff' will simply - ;; say "Binary files differ" instead of actually doing a diff of two .elc - ;; files. An extra benefit is that you can add this to /etc/magic: - ;; - ;; 0 string ;ELC GNU Emacs Lisp compiled file, - ;; >4 byte x version %d - ;; - (insert - ";ELC" - (if (byte-compile-version-cond byte-compile-compatibility) 18 19) - "\000\000\000\n" - ) - (insert ";;; 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") - (insert ";;; in Emacs version " emacs-version "\n") - (insert ";;; with bytecomp version " - (progn (string-match "[0-9.]+" byte-compile-version) - (match-string 0 byte-compile-version)) - "\n;;; " - (cond - ((eq byte-optimize 'source) "with source-level optimization only") - ((eq byte-optimize 'byte) "with byte-level optimization only") - (byte-optimize "with all optimizations") - (t "without optimization")) - (if (byte-compile-version-cond byte-compile-compatibility) - "; compiled with Emacs 18 compatibility.\n" - ".\n")) - (if dynamic - (insert ";;; Function definitions are lazy-loaded.\n")) - (if (not (byte-compile-version-cond byte-compile-compatibility)) - (insert ";;; This file uses opcodes which do not exist in Emacs 18.\n" - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "\n(if (and (boundp 'emacs-version)\n" - ;; If there is a name at the end of emacs-version, - ;; don't try to check the version number. - "\t (< (aref emacs-version (1- (length emacs-version))) ?A)\n" - "\t (or (and (boundp 'epoch::version) epoch::version)\n" - (if dynamic-docstrings - "\t (string-lessp emacs-version \"19.29\")))\n" - "\t (string-lessp emacs-version \"19\")))\n") - " (error \"`" - ;; prin1-to-string is used to quote backslashes. - (substring (prin1-to-string (file-name-nondirectory filename)) - 1 -1) - (if dynamic-docstrings - "' was compiled for Emacs 19.29 or later\"))\n\n" - "' was compiled for Emacs 19\"))\n\n")) - (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n" - "\n") - ))) - - -(defun byte-compile-output-file-form (form) - ;; writes the given form to the output buffer, being careful of docstrings - ;; in defun, defmacro, defvar, defconst and autoload because make-docfile is - ;; so amazingly stupid. - ;; defalias calls are output directly by byte-compile-file-form-defmumble; - ;; it does not pay to first build the defalias in defmumble and then parse - ;; it here. - (if (and (memq (car-safe form) '(defun defmacro defvar defconst autoload)) - (stringp (nth 3 form))) - (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil - (eq (car form) 'autoload)) - (let ((print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-quoted t) - (print-gensym t)) - (princ "\n" outbuffer) - (prin1 form outbuffer) - nil))) - -(defun byte-compile-output-docform (preface name info form specindex quoted) - "Print a form with a doc string. INFO is (prefix doc-index postfix). -If PREFACE and NAME are non-nil, print them too, -before INFO and the FORM but after the doc string itself. -If SPECINDEX is non-nil, it is the index in FORM -of the function bytecode string. In that case, -we output that argument and the following argument (the constants vector) -together, for lazy loading. -QUOTED says that we have to put a quote before the -list that represents a doc string reference. -`autoload' needs that." - ;; We need to examine byte-compile-dynamic-docstrings - ;; in the input buffer (now current), not in the output buffer. - (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) - (set-buffer - (prog1 (current-buffer) - (set-buffer outbuffer) - (let (position) - - ;; Insert the doc string, and make it a comment with #@LENGTH. - (and (>= (nth 1 info) 0) - dynamic-docstrings - (not byte-compile-compatibility) - (progn - ;; Make the doc string start at beginning of line - ;; for make-docfile's sake. - (insert "\n") - (setq position - (byte-compile-output-as-comment - (nth (nth 1 info) form) nil)) - ;; If the doc string starts with * (a user variable), - ;; negate POSITION. - (if (and (stringp (nth (nth 1 info) form)) - (> (length (nth (nth 1 info) form)) 0) - (eq (aref (nth (nth 1 info) form) 0) ?*)) - (setq position (- position))))) - - (if preface - (progn - (insert preface) - (prin1 name outbuffer))) - (insert (car info)) - (let ((print-escape-newlines t) - (print-quoted t) - (print-gensym t) - (index 0)) - (prin1 (car form) outbuffer) - (while (setq form (cdr form)) - (setq index (1+ index)) - (insert " ") - (cond ((and (numberp specindex) (= index specindex)) - (let ((position - (byte-compile-output-as-comment - (cons (car form) (nth 1 form)) - t))) - (princ (format "(#$ . %d) nil" position) outbuffer) - (setq form (cdr form)) - (setq index (1+ index)))) - ((= index (nth 1 info)) - (if position - (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") - position) - outbuffer) - (let ((print-escape-newlines nil)) - (goto-char (prog1 (1+ (point)) - (prin1 (car form) outbuffer))) - (insert "\\\n") - (goto-char (point-max))))) - (t - (prin1 (car form) outbuffer))))) - (insert (nth 2 info)))))) - nil) - -(defun byte-compile-keep-pending (form &optional handler) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form t))) - (if handler - (let ((for-effect t)) - ;; To avoid consing up monstrously large forms at load time, we split - ;; the output regularly. - (and (memq (car-safe form) '(fset defalias)) - (nthcdr 300 byte-compile-output) - (byte-compile-flush-pending)) - (funcall handler form) - (if for-effect - (byte-compile-discard))) - (byte-compile-form form t)) - nil) - -(defun byte-compile-flush-pending () - (if byte-compile-output - (let ((form (byte-compile-out-toplevel t 'file))) - (cond ((eq (car-safe form) 'progn) - (mapcar 'byte-compile-output-file-form (cdr form))) - (form - (byte-compile-output-file-form form))) - (setq byte-compile-constants nil - byte-compile-variables nil - byte-compile-depth 0 - byte-compile-maxdepth 0 - byte-compile-output nil)))) - -(defun byte-compile-file-form (form) - (let ((byte-compile-current-form nil) ; close over this for warnings. - handler) - (cond - ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) - (setq handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall handler form)) - (byte-compile-flush-pending) - (byte-compile-output-file-form form)))) - ((eq form (setq form (macroexpand form byte-compile-macro-environment))) - (byte-compile-keep-pending form)) - (t - (byte-compile-file-form form))))) - -;; Functions and variables with doc strings must be output separately, -;; so make-docfile can recognise them. Most other things can be output -;; as byte-code. - -(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) -(defun byte-compile-file-form-defsubst (form) - (cond ((assq (nth 1 form) byte-compile-unresolved-functions) - (setq byte-compile-current-form (nth 1 form)) - (byte-compile-warn "defsubst %s was used before it was defined" - (nth 1 form)))) - (byte-compile-file-form - (macroexpand form byte-compile-macro-environment)) - ;; Return nil so the form is not output twice. - nil) - -(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) -(defun byte-compile-file-form-autoload (form) - (and (let ((form form)) - (while (if (setq form (cdr form)) (byte-compile-constp (car form)))) - (null form)) ;Constants only - (eval (nth 5 form)) ;Macro - (eval form)) ;Define the autoload. - (if (stringp (nth 3 form)) - form - ;; No doc string, so we can compile this as a normal form. - (byte-compile-keep-pending form 'byte-compile-normal-call))) - -(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) - (if (null (nth 3 form)) - ;; Since there is no doc string, we can compile this as a normal form, - ;; and not do a file-boundary. - (byte-compile-keep-pending form) - (if (memq 'free-vars byte-compile-warnings) - (setq byte-compile-bound-variables - (cons (nth 1 form) byte-compile-bound-variables))) - (cond ((consp (nth 2 form)) - (setq form (copy-sequence form)) - (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file)))) - form)) - -(put 'require 'byte-hunk-handler 'byte-compile-file-form-eval-boundary) -(defun byte-compile-file-form-eval-boundary (form) - (eval form) - (byte-compile-keep-pending form 'byte-compile-normal-call)) - -(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) -(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn) -(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn) -(defun byte-compile-file-form-progn (form) - (mapcar 'byte-compile-file-form (cdr form)) - ;; Return nil so the forms are not output twice. - nil) - -;; This handler is not necessary, but it makes the output from dont-compile -;; and similar macros cleaner. -(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval) -(defun byte-compile-file-form-eval (form) - (if (eq (car-safe (nth 1 form)) 'quote) - (nth 1 (nth 1 form)) - (byte-compile-keep-pending form))) - -(put 'defun 'byte-hunk-handler 'byte-compile-file-form-defun) -(defun byte-compile-file-form-defun (form) - (byte-compile-file-form-defmumble form nil)) - -(put 'defmacro 'byte-hunk-handler 'byte-compile-file-form-defmacro) -(defun byte-compile-file-form-defmacro (form) - (byte-compile-file-form-defmumble form t)) - -(defun byte-compile-file-form-defmumble (form macrop) - (let* ((name (car (cdr form))) - (this-kind (if macrop 'byte-compile-macro-environment - 'byte-compile-function-environment)) - (that-kind (if macrop 'byte-compile-function-environment - 'byte-compile-macro-environment)) - (this-one (assq name (symbol-value this-kind))) - (that-one (assq name (symbol-value that-kind))) - (byte-compile-free-references nil) - (byte-compile-free-assignments nil)) - - ;; When a function or macro is defined, add it to the call tree so that - ;; we can tell when functions are not used. - (if byte-compile-generate-call-tree - (or (assq name byte-compile-call-tree) - (setq byte-compile-call-tree - (cons (list name nil nil) byte-compile-call-tree)))) - - (setq byte-compile-current-form name) ; for warnings - (if (memq 'redefine byte-compile-warnings) - (byte-compile-arglist-warn form macrop)) - (if byte-compile-verbose - (message "Compiling %s... (%s)" (or filename "") (nth 1 form))) - (cond (that-one - (if (and (memq 'redefine byte-compile-warnings) - ;; don't warn when compiling the stubs in byte-run... - (not (assq (nth 1 form) - byte-compile-initial-macro-environment))) - (byte-compile-warn - "%s defined multiple times, as both function and macro" - (nth 1 form))) - (setcdr that-one nil)) - (this-one - (if (and (memq 'redefine byte-compile-warnings) - ;; hack: don't warn when compiling the magic internal - ;; byte-compiler macros in byte-run.el... - (not (assq (nth 1 form) - byte-compile-initial-macro-environment))) - (byte-compile-warn "%s %s defined multiple times in this file" - (if macrop "macro" "function") - (nth 1 form)))) - ((and (fboundp name) - (eq (car-safe (symbol-function name)) - (if macrop 'lambda 'macro))) - (if (memq 'redefine byte-compile-warnings) - (byte-compile-warn "%s %s being redefined as a %s" - (if macrop "function" "macro") - (nth 1 form) - (if macrop "macro" "function"))) - ;; shadow existing definition - (set this-kind - (cons (cons name nil) (symbol-value this-kind)))) - ) - (let ((body (nthcdr 3 form))) - (if (and (stringp (car body)) - (symbolp (car-safe (cdr-safe body))) - (car-safe (cdr-safe body)) - (stringp (car-safe (cdr-safe (cdr-safe body))))) - (byte-compile-warn "Probable `\"' without `\\' in doc string of %s" - (nth 1 form)))) - (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form)))) - (code (byte-compile-byte-code-maker new-one))) - (if this-one - (setcdr this-one new-one) - (set this-kind - (cons (cons name new-one) (symbol-value this-kind)))) - (if (and (stringp (nth 3 form)) - (eq 'quote (car-safe code)) - (eq 'lambda (car-safe (nth 1 code)))) - (cons (car form) - (cons name (cdr (nth 1 code)))) - (byte-compile-flush-pending) - (if (not (stringp (nth 3 form))) - ;; No doc string. Provide -1 as the "doc string index" - ;; so that no element will be treated as a doc string. - (byte-compile-output-docform - (if (byte-compile-version-cond byte-compile-compatibility) - "\n(fset '" "\n(defalias '") - name - (cond ((atom code) - (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))) - ((eq (car code) 'quote) - (setq code new-one) - (if macrop '(" '(macro " -1 ")") '(" '(" -1 ")"))) - ((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")")))) - (append code nil) - (and (atom code) byte-compile-dynamic - 1) - nil) - ;; Output the form by hand, that's much simpler than having - ;; b-c-output-file-form analyze the defalias. - (byte-compile-output-docform - (if (byte-compile-version-cond byte-compile-compatibility) - "\n(fset '" "\n(defalias '") - name - (cond ((atom code) - (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) - ((eq (car code) 'quote) - (setq code new-one) - (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) - ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))) - (append code nil) - (and (atom code) byte-compile-dynamic - 1) - nil)) - (princ ")" outbuffer) - nil)))) - -;; Print Lisp object EXP in the output file, inside a comment, -;; and return the file position it will have. -;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. -(defun byte-compile-output-as-comment (exp quoted) - (let ((position (point))) - (set-buffer - (prog1 (current-buffer) - (set-buffer outbuffer) - - ;; Insert EXP, and make it a comment with #@LENGTH. - (insert " ") - (if quoted - (prin1 exp outbuffer) - (princ exp outbuffer)) - (goto-char position) - ;; Quote certain special characters as needed. - ;; get_doc_string in doc.c does the unquoting. - (while (search-forward "\^A" nil t) - (replace-match "\^A\^A" t t)) - (goto-char position) - (while (search-forward "\000" nil t) - (replace-match "\^A0" t t)) - (goto-char position) - (while (search-forward "\037" nil t) - (replace-match "\^A_" t t)) - (goto-char (point-max)) - (insert "\037") - (goto-char position) - (insert "#@" (format "%d" (- (point-max) position))) - - ;; Save the file position of the object. - ;; Note we should add 1 to skip the space - ;; that we inserted before the actual doc string, - ;; and subtract 1 to convert from an 1-origin Emacs position - ;; to a file position; they cancel. - (setq position (point)) - (goto-char (point-max)))) - position)) - - - -;;;###autoload -(defun byte-compile (form) - "If FORM is a symbol, byte-compile its function definition. -If FORM is a lambda or a macro, byte-compile it as a function." - (displaying-byte-compile-warnings - (byte-compile-close-variables - (let* ((fun (if (symbolp form) - (and (fboundp form) (symbol-function form)) - form)) - (macro (eq (car-safe fun) 'macro))) - (if macro - (setq fun (cdr fun))) - (cond ((eq (car-safe fun) 'lambda) - (setq fun (if macro - (cons 'macro (byte-compile-lambda fun)) - (byte-compile-lambda fun))) - (if (symbolp form) - (defalias form fun) - fun))))))) - -(defun byte-compile-sexp (sexp) - "Compile and return SEXP." - (displaying-byte-compile-warnings - (byte-compile-close-variables - (byte-compile-top-level sexp)))) - -;; Given a function made by byte-compile-lambda, make a form which produces it. -(defun byte-compile-byte-code-maker (fun) - (cond - ((byte-compile-version-cond byte-compile-compatibility) - ;; Return (quote (lambda ...)). - (list 'quote (byte-compile-byte-code-unmake fun))) - ;; ## atom is faster than compiled-func-p. - ((atom fun) ; compiled function. - ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda - ;; would have produced a lambda. - fun) - ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial - ;; function, or this is Emacs 18, or generate-emacs19-bytecodes is off. - ((let (tmp) - (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun)))) - (null (cdr (memq tmp fun)))) - ;; Generate a make-byte-code call. - (let* ((interactive (assq 'interactive (cdr (cdr fun))))) - (nconc (list 'make-byte-code - (list 'quote (nth 1 fun)) ;arglist - (nth 1 tmp) ;bytes - (nth 2 tmp) ;consts - (nth 3 tmp)) ;depth - (cond ((stringp (nth 2 fun)) - (list (nth 2 fun))) ;doc - (interactive - (list nil))) - (cond (interactive - (list (if (or (null (nth 1 interactive)) - (stringp (nth 1 interactive))) - (nth 1 interactive) - ;; Interactive spec is a list or a variable - ;; (if it is correct). - (list 'quote (nth 1 interactive)))))))) - ;; a non-compiled function (probably trivial) - (list 'quote fun)))))) - -;; Turn a function into an ordinary lambda. Needed for v18 files. -(defun byte-compile-byte-code-unmake (function) - (if (consp function) - function;;It already is a lambda. - (setq function (append function nil)) ; turn it into a list - (nconc (list 'lambda (nth 0 function)) - (and (nth 4 function) (list (nth 4 function))) - (if (nthcdr 5 function) - (list (cons 'interactive (if (nth 5 function) - (nthcdr 5 function))))) - (list (list 'byte-code - (nth 1 function) (nth 2 function) - (nth 3 function)))))) - - -;; Byte-compile a lambda-expression and return a valid function. -;; The value is usually a compiled function but may be the original -;; lambda-expression. -(defun byte-compile-lambda (fun) - (let* ((arglist (nth 1 fun)) - (byte-compile-bound-variables - (nconc (and (memq 'free-vars byte-compile-warnings) - (delq '&rest (delq '&optional (copy-sequence arglist)))) - byte-compile-bound-variables)) - (body (cdr (cdr fun))) - (doc (if (stringp (car body)) - (prog1 (car body) - ;; Discard the doc string - ;; unless it is the last element of the body. - (if (nthcdr 2 body) - (setq body (cdr body)))))) - (int (assq 'interactive body))) - (cond (int - ;; Skip (interactive) if it is in front (the most usual location). - (if (eq int (car body)) - (setq body (cdr body))) - (cond ((consp (cdr int)) - (if (cdr (cdr int)) - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))) - ;; If the interactive spec is a call to `list', - ;; don't compile it, because `call-interactively' - ;; looks at the args of `list'. - (let ((form (nth 1 int))) - (while (or (eq (car-safe form) 'let) - (eq (car-safe form) 'let*) - (eq (car-safe form) 'save-excursion)) - (while (consp (cdr form)) - (setq form (cdr form))) - (setq form (car form))) - (or (eq (car-safe form) 'list) - (setq int (list 'interactive - (byte-compile-top-level (nth 1 int))))))) - ((cdr int) - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int)))))) - (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda))) - (if (and (eq 'byte-code (car-safe compiled)) - (not (byte-compile-version-cond - byte-compile-compatibility))) - (apply 'make-byte-code - (append (list arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or doc int) - (list doc)) - ;; optionally, the interactive spec. - (if int - (list (nth 1 int))))) - (setq compiled - (nconc (if int (list int)) - (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) - (compiled (list compiled))))) - (nconc (list 'lambda arglist) - (if (or doc (stringp (car compiled))) - (cons doc (cond (compiled) - (body (list nil)))) - compiled)))))) - -(defun byte-compile-constants-vector () - ;; Builds the constants-vector from the current variables and constants. - ;; This modifies the constants from (const . nil) to (const . offset). - ;; To keep the byte-codes to look up the vector as short as possible: - ;; First 6 elements are vars, as there are one-byte varref codes for those. - ;; Next up to byte-constant-limit are constants, still with one-byte codes. - ;; Next variables again, to get 2-byte codes for variable lookup. - ;; The rest of the constants and variables need 3-byte byte-codes. - (let* ((i -1) - (rest (nreverse byte-compile-variables)) ; nreverse because the first - (other (nreverse byte-compile-constants)) ; vars often are used most. - ret tmp - (limits '(5 ; Use the 1-byte varref codes, - 63 ; 1-constlim ; 1-byte byte-constant codes, - 255 ; 2-byte varref codes, - 65535)) ; 3-byte codes for the rest. - limit) - (while (or rest other) - (setq limit (car limits)) - (while (and rest (not (eq i limit))) - (if (setq tmp (assq (car (car rest)) ret)) - (setcdr (car rest) (cdr tmp)) - (setcdr (car rest) (setq i (1+ i))) - (setq ret (cons (car rest) ret))) - (setq rest (cdr rest))) - (setq limits (cdr limits) - rest (prog1 other - (setq other rest)))) - (apply 'vector (nreverse (mapcar 'car ret))))) - -;; Given an expression FORM, compile it and return an equivalent byte-code -;; expression (a call to the function byte-code). -(defun byte-compile-top-level (form &optional for-effect output-type) - ;; OUTPUT-TYPE advises about how form is expected to be used: - ;; 'eval or nil -> a single form, - ;; 'progn or t -> a list of forms, - ;; 'lambda -> body of a lambda, - ;; 'file -> used at file-level. - (let ((byte-compile-constants nil) - (byte-compile-variables nil) - (byte-compile-tag-number 0) - (byte-compile-depth 0) - (byte-compile-maxdepth 0) - (byte-compile-output nil)) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form for-effect))) - (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) - (setq form (nth 1 form))) - (if (and (eq 'byte-code (car-safe form)) - (not (memq byte-optimize '(t byte))) - (stringp (nth 1 form)) (vectorp (nth 2 form)) - (natnump (nth 3 form))) - form - (byte-compile-form form for-effect) - (byte-compile-out-toplevel for-effect output-type)))) - -(defun byte-compile-out-toplevel (&optional for-effect output-type) - (if for-effect - ;; The stack is empty. Push a value to be returned from (byte-code ..). - (if (eq (car (car byte-compile-output)) 'byte-discard) - (setq byte-compile-output (cdr byte-compile-output)) - (byte-compile-push-constant - ;; Push any constant - preferably one which already is used, and - ;; a number or symbol - ie not some big sequence. The return value - ;; isn't returned, but it would be a shame if some textually large - ;; constant was not optimized away because we chose to return it. - (and (not (assq nil byte-compile-constants)) ; Nil is often there. - (let ((tmp (reverse byte-compile-constants))) - (while (and tmp (not (or (symbolp (car (car tmp))) - (numberp (car (car tmp)))))) - (setq tmp (cdr tmp))) - (car (car tmp))))))) - (byte-compile-out 'byte-return 0) - (setq byte-compile-output (nreverse byte-compile-output)) - (if (memq byte-optimize '(t byte)) - (setq byte-compile-output - (byte-optimize-lapcode byte-compile-output for-effect))) - - ;; Decompile trivial functions: - ;; only constants and variables, or a single funcall except in lambdas. - ;; Except for Lisp_Compiled objects, forms like (foo "hi") - ;; are still quicker than (byte-code "..." [foo "hi"] 2). - ;; Note that even (quote foo) must be parsed just as any subr by the - ;; interpreter, so quote should be compiled into byte-code in some contexts. - ;; What to leave uncompiled: - ;; lambda -> never. we used to leave it uncompiled if the body was - ;; a single atom, but that causes confusion if the docstring - ;; uses the (file . pos) syntax. Besides, now that we have - ;; the Lisp_Compiled type, the compiled form is faster. - ;; eval -> atom, quote or (function atom atom atom) - ;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom) - ;; file -> as progn, but takes both quotes and atoms, and longer forms. - (let (rest - (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall. - tmp body) - (cond - ;; #### This should be split out into byte-compile-nontrivial-function-p. - ((or (eq output-type 'lambda) - (nthcdr (if (eq output-type 'file) 50 8) byte-compile-output) - (assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit. - (not (setq tmp (assq 'byte-return byte-compile-output))) - (progn - (setq rest (nreverse - (cdr (memq tmp (reverse byte-compile-output))))) - (while (cond - ((memq (car (car rest)) '(byte-varref byte-constant)) - (setq tmp (car (cdr (car rest)))) - (if (if (eq (car (car rest)) 'byte-constant) - (or (consp tmp) - (and (symbolp tmp) - (not (memq tmp '(nil t)))))) - (if maycall - (setq body (cons (list 'quote tmp) body))) - (setq body (cons tmp body)))) - ((and maycall - ;; Allow a funcall if at most one atom follows it. - (null (nthcdr 3 rest)) - (setq tmp (get (car (car rest)) 'byte-opcode-invert)) - (or (null (cdr rest)) - (and (memq output-type '(file progn t)) - (cdr (cdr rest)) - (eq (car (nth 1 rest)) 'byte-discard) - (progn (setq rest (cdr rest)) t)))) - (setq maycall nil) ; Only allow one real function call. - (setq body (nreverse body)) - (setq body (list - (if (and (eq tmp 'funcall) - (eq (car-safe (car body)) 'quote)) - (cons (nth 1 (car body)) (cdr body)) - (cons tmp body)))) - (or (eq output-type 'file) - (not (delq nil (mapcar 'consp (cdr (car body)))))))) - (setq rest (cdr rest))) - rest)) - (let ((byte-compile-vector (byte-compile-constants-vector))) - (list 'byte-code (byte-compile-lapcode byte-compile-output) - byte-compile-vector byte-compile-maxdepth))) - ;; it's a trivial function - ((cdr body) (cons 'progn (nreverse body))) - ((car body))))) - -;; Given BODY, compile it and return a new body. -(defun byte-compile-top-level-body (body &optional for-effect) - (setq body (byte-compile-top-level (cons 'progn body) for-effect t)) - (cond ((eq (car-safe body) 'progn) - (cdr body)) - (body - (list body)))) - -;; This is the recursive entry point for compiling each subform of an -;; expression. -;; If for-effect is non-nil, byte-compile-form will output a byte-discard -;; before terminating (ie no value will be left on the stack). -;; A byte-compile handler may, when for-effect is non-nil, choose output code -;; which does not leave a value on the stack, and then set for-effect to nil -;; (to prevent byte-compile-form from outputting the byte-discard). -;; If a handler wants to call another handler, it should do so via -;; byte-compile-form, or take extreme care to handle for-effect correctly. -;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) -;; -(defun byte-compile-form (form &optional for-effect) - (setq form (macroexpand form byte-compile-macro-environment)) - (cond ((not (consp form)) - (cond ((or (not (symbolp form)) (memq form '(nil t))) - (byte-compile-constant form)) - ((and for-effect byte-compile-delete-errors) - (setq for-effect nil)) - (t (byte-compile-variable-ref 'byte-varref form)))) - ((symbolp (car form)) - (let* ((fn (car form)) - (handler (get fn 'byte-compile))) - (if (memq fn '(t nil)) - (byte-compile-warn "%s called as a function" fn)) - (if (and handler - (or (not (byte-compile-version-cond - byte-compile-compatibility)) - (not (get (get fn 'byte-opcode) 'emacs19-opcode)))) - (funcall handler form) - (if (memq 'callargs byte-compile-warnings) - (byte-compile-callargs-warn form)) - (byte-compile-normal-call form)))) - ((and (or (byte-code-function-p (car form)) - (eq (car-safe (car form)) 'lambda)) - ;; if the form comes out the same way it went in, that's - ;; because it was malformed, and we couldn't unfold it. - (not (eq form (setq form (byte-compile-unfold-lambda form))))) - (byte-compile-form form for-effect) - (setq for-effect nil)) - ((byte-compile-normal-call form))) - (if for-effect - (byte-compile-discard))) - -(defun byte-compile-normal-call (form) - (if byte-compile-generate-call-tree - (byte-compile-annotate-call-tree form)) - (byte-compile-push-constant (car form)) - (mapcar 'byte-compile-form (cdr form)) ; wasteful, but faster. - (byte-compile-out 'byte-call (length (cdr form)))) - -(defun byte-compile-variable-ref (base-op var) - (if (or (not (symbolp var)) (memq var '(nil t))) - (byte-compile-warn (if (eq base-op 'byte-varbind) - "Attempt to let-bind %s %s" - "Variable reference to %s %s") - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var)) - (if (and (get var 'byte-obsolete-variable) - (memq 'obsolete byte-compile-warnings)) - (let ((ob (get var 'byte-obsolete-variable))) - (byte-compile-warn "%s is an obsolete variable; %s" var - (if (stringp ob) - ob - (format "use %s instead." ob))))) - (if (memq 'free-vars byte-compile-warnings) - (if (eq base-op 'byte-varbind) - (setq byte-compile-bound-variables - (cons var byte-compile-bound-variables)) - (or (boundp var) - (memq var byte-compile-bound-variables) - (if (eq base-op 'byte-varset) - (or (memq var byte-compile-free-assignments) - (progn - (byte-compile-warn "assignment to free variable %s" var) - (setq byte-compile-free-assignments - (cons var byte-compile-free-assignments)))) - (or (memq var byte-compile-free-references) - (progn - (byte-compile-warn "reference to free variable %s" var) - (setq byte-compile-free-references - (cons var byte-compile-free-references))))))))) - (let ((tmp (assq var byte-compile-variables))) - (or tmp - (setq tmp (list var) - byte-compile-variables (cons tmp byte-compile-variables))) - (byte-compile-out base-op tmp))) - -(defmacro byte-compile-get-constant (const) - (` (or (if (stringp (, const)) - (assoc (, const) byte-compile-constants) - (assq (, const) byte-compile-constants)) - (car (setq byte-compile-constants - (cons (list (, const)) byte-compile-constants)))))) - -;; Use this when the value of a form is a constant. This obeys for-effect. -(defun byte-compile-constant (const) - (if for-effect - (setq for-effect nil) - (byte-compile-out 'byte-constant (byte-compile-get-constant const)))) - -;; Use this for a constant that is not the value of its containing form. -;; This ignores for-effect. -(defun byte-compile-push-constant (const) - (let ((for-effect nil)) - (inline (byte-compile-constant const)))) - - -;; Compile those primitive ordinary functions -;; which have special byte codes just for speed. - -(defmacro byte-defop-compiler (function &optional compile-handler) - ;; add a compiler-form for FUNCTION. - ;; If function is a symbol, then the variable "byte-SYMBOL" must name - ;; the opcode to be used. If function is a list, the first element - ;; is the function and the second element is the bytecode-symbol. - ;; COMPILE-HANDLER is the function to use to compile this byte-op, or - ;; may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2. - ;; If it is nil, then the handler is "byte-compile-SYMBOL." - (let (opcode) - (if (symbolp function) - (setq opcode (intern (concat "byte-" (symbol-name function)))) - (setq opcode (car (cdr function)) - function (car function))) - (let ((fnform - (list 'put (list 'quote function) ''byte-compile - (list 'quote - (or (cdr (assq compile-handler - '((0 . byte-compile-no-args) - (1 . byte-compile-one-arg) - (2 . byte-compile-two-args) - (3 . byte-compile-three-args) - (0-1 . byte-compile-zero-or-one-arg) - (1-2 . byte-compile-one-or-two-args) - (2-3 . byte-compile-two-or-three-args) - ))) - compile-handler - (intern (concat "byte-compile-" - (symbol-name function)))))))) - (if opcode - (list 'progn fnform - (list 'put (list 'quote function) - ''byte-opcode (list 'quote opcode)) - (list 'put (list 'quote opcode) - ''byte-opcode-invert (list 'quote function))) - fnform)))) - -(defmacro byte-defop-compiler19 (function &optional compile-handler) - ;; Just like byte-defop-compiler, but defines an opcode that will only - ;; be used when byte-compile-compatibility is false. - (if (and (byte-compile-single-version) - byte-compile-compatibility) - ;; #### instead of doing nothing, this should do some remprops, - ;; #### to protect against the case where a single-version compiler - ;; #### is loaded into a world that has contained a multi-version one. - nil - (list 'progn - (list 'put - (list 'quote - (or (car (cdr-safe function)) - (intern (concat "byte-" - (symbol-name (or (car-safe function) function)))))) - ''emacs19-opcode t) - (list 'byte-defop-compiler function compile-handler)))) - -(defmacro byte-defop-compiler-1 (function &optional compile-handler) - (list 'byte-defop-compiler (list function nil) compile-handler)) - - -(put 'byte-call 'byte-opcode-invert 'funcall) -(put 'byte-list1 'byte-opcode-invert 'list) -(put 'byte-list2 'byte-opcode-invert 'list) -(put 'byte-list3 'byte-opcode-invert 'list) -(put 'byte-list4 'byte-opcode-invert 'list) -(put 'byte-listN 'byte-opcode-invert 'list) -(put 'byte-concat2 'byte-opcode-invert 'concat) -(put 'byte-concat3 'byte-opcode-invert 'concat) -(put 'byte-concat4 'byte-opcode-invert 'concat) -(put 'byte-concatN 'byte-opcode-invert 'concat) -(put 'byte-insertN 'byte-opcode-invert 'insert) - -(byte-defop-compiler (dot byte-point) 0) -(byte-defop-compiler (dot-max byte-point-max) 0) -(byte-defop-compiler (dot-min byte-point-min) 0) -(byte-defop-compiler point 0) -;;(byte-defop-compiler mark 0) ;; obsolete -(byte-defop-compiler point-max 0) -(byte-defop-compiler point-min 0) -(byte-defop-compiler following-char 0) -(byte-defop-compiler preceding-char 0) -(byte-defop-compiler current-column 0) -(byte-defop-compiler eolp 0) -(byte-defop-compiler eobp 0) -(byte-defop-compiler bolp 0) -(byte-defop-compiler bobp 0) -(byte-defop-compiler current-buffer 0) -;;(byte-defop-compiler read-char 0) ;; obsolete -(byte-defop-compiler interactive-p 0) -(byte-defop-compiler19 widen 0) -(byte-defop-compiler19 end-of-line 0-1) -(byte-defop-compiler19 forward-char 0-1) -(byte-defop-compiler19 forward-line 0-1) -(byte-defop-compiler symbolp 1) -(byte-defop-compiler consp 1) -(byte-defop-compiler stringp 1) -(byte-defop-compiler listp 1) -(byte-defop-compiler not 1) -(byte-defop-compiler (null byte-not) 1) -(byte-defop-compiler car 1) -(byte-defop-compiler cdr 1) -(byte-defop-compiler length 1) -(byte-defop-compiler symbol-value 1) -(byte-defop-compiler symbol-function 1) -(byte-defop-compiler (1+ byte-add1) 1) -(byte-defop-compiler (1- byte-sub1) 1) -(byte-defop-compiler goto-char 1) -(byte-defop-compiler char-after 1) -(byte-defop-compiler set-buffer 1) -;;(byte-defop-compiler set-mark 1) ;; obsolete -(byte-defop-compiler19 forward-word 1) -(byte-defop-compiler19 char-syntax 1) -(byte-defop-compiler19 nreverse 1) -(byte-defop-compiler19 car-safe 1) -(byte-defop-compiler19 cdr-safe 1) -(byte-defop-compiler19 numberp 1) -(byte-defop-compiler19 integerp 1) -(byte-defop-compiler19 skip-chars-forward 1-2) -(byte-defop-compiler19 skip-chars-backward 1-2) -(byte-defop-compiler (eql byte-eq) 2) -(byte-defop-compiler eq 2) -(byte-defop-compiler memq 2) -(byte-defop-compiler cons 2) -(byte-defop-compiler aref 2) -(byte-defop-compiler set 2) -(byte-defop-compiler (= byte-eqlsign) 2) -(byte-defop-compiler (< byte-lss) 2) -(byte-defop-compiler (> byte-gtr) 2) -(byte-defop-compiler (<= byte-leq) 2) -(byte-defop-compiler (>= byte-geq) 2) -(byte-defop-compiler get 2) -(byte-defop-compiler nth 2) -(byte-defop-compiler substring 2-3) -(byte-defop-compiler19 (move-marker byte-set-marker) 2-3) -(byte-defop-compiler19 set-marker 2-3) -(byte-defop-compiler19 match-beginning 1) -(byte-defop-compiler19 match-end 1) -(byte-defop-compiler19 upcase 1) -(byte-defop-compiler19 downcase 1) -(byte-defop-compiler19 string= 2) -(byte-defop-compiler19 string< 2) -(byte-defop-compiler19 (string-equal byte-string=) 2) -(byte-defop-compiler19 (string-lessp byte-string<) 2) -(byte-defop-compiler19 equal 2) -(byte-defop-compiler19 nthcdr 2) -(byte-defop-compiler19 elt 2) -(byte-defop-compiler19 member 2) -(byte-defop-compiler19 assq 2) -(byte-defop-compiler19 (rplaca byte-setcar) 2) -(byte-defop-compiler19 (rplacd byte-setcdr) 2) -(byte-defop-compiler19 setcar 2) -(byte-defop-compiler19 setcdr 2) -(byte-defop-compiler19 buffer-substring 2) -(byte-defop-compiler19 delete-region 2) -(byte-defop-compiler19 narrow-to-region 2) -(byte-defop-compiler19 (% byte-rem) 2) -(byte-defop-compiler aset 3) - -(byte-defop-compiler max byte-compile-associative) -(byte-defop-compiler min byte-compile-associative) -(byte-defop-compiler (+ byte-plus) byte-compile-associative) -(byte-defop-compiler19 (* byte-mult) byte-compile-associative) - -;;####(byte-defop-compiler19 move-to-column 1) -(byte-defop-compiler-1 interactive byte-compile-noop) - - -(defun byte-compile-subr-wrong-args (form n) - (byte-compile-warn "%s called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) - ;; get run-time wrong-number-of-args error. - (byte-compile-normal-call form)) - -(defun byte-compile-no-args (form) - (if (not (= (length form) 1)) - (byte-compile-subr-wrong-args form "none") - (byte-compile-out (get (car form) 'byte-opcode) 0))) - -(defun byte-compile-one-arg (form) - (if (not (= (length form) 2)) - (byte-compile-subr-wrong-args form 1) - (byte-compile-form (car (cdr form))) ;; Push the argument - (byte-compile-out (get (car form) 'byte-opcode) 0))) - -(defun byte-compile-two-args (form) - (if (not (= (length form) 3)) - (byte-compile-subr-wrong-args form 2) - (byte-compile-form (car (cdr form))) ;; Push the arguments - (byte-compile-form (nth 2 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0))) - -(defun byte-compile-three-args (form) - (if (not (= (length form) 4)) - (byte-compile-subr-wrong-args form 3) - (byte-compile-form (car (cdr form))) ;; Push the arguments - (byte-compile-form (nth 2 form)) - (byte-compile-form (nth 3 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0))) - -(defun byte-compile-zero-or-one-arg (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) - ((= len 2) (byte-compile-one-arg form)) - (t (byte-compile-subr-wrong-args form "0-1"))))) - -(defun byte-compile-one-or-two-args (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) - ((= len 3) (byte-compile-two-args form)) - (t (byte-compile-subr-wrong-args form "1-2"))))) - -(defun byte-compile-two-or-three-args (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) - ((= len 4) (byte-compile-three-args form)) - (t (byte-compile-subr-wrong-args form "2-3"))))) - -(defun byte-compile-noop (form) - (byte-compile-constant nil)) - -(defun byte-compile-discard () - (byte-compile-out 'byte-discard 0)) - - -;; Compile a function that accepts one or more args and is right-associative. -;; We do it by left-associativity so that the operations -;; are done in the same order as in interpreted code. -;; We treat the one-arg case, as in (+ x), like (+ x 0). -;; in order to convert markers to numbers, and trigger expected errors. -(defun byte-compile-associative (form) - (if (cdr form) - (let ((opcode (get (car form) 'byte-opcode)) - (args (copy-sequence (cdr form)))) - (byte-compile-form (car args)) - (setq args (cdr args)) - (or args (setq args '(0) - opcode (get '+ 'byte-opcode))) - (while args - (byte-compile-form (car args)) - (byte-compile-out opcode 0) - (setq args (cdr args)))) - (byte-compile-constant (eval form)))) - - -;; more complicated compiler macros - -(byte-defop-compiler list) -(byte-defop-compiler concat) -(byte-defop-compiler fset) -(byte-defop-compiler (indent-to-column byte-indent-to) byte-compile-indent-to) -(byte-defop-compiler indent-to) -(byte-defop-compiler insert) -(byte-defop-compiler-1 function byte-compile-function-form) -(byte-defop-compiler-1 - byte-compile-minus) -(byte-defop-compiler19 (/ byte-quo) byte-compile-quo) -(byte-defop-compiler19 nconc) -(byte-defop-compiler-1 beginning-of-line) - -(defun byte-compile-list (form) - (let ((count (length (cdr form)))) - (cond ((= count 0) - (byte-compile-constant nil)) - ((< count 5) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out - (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0)) - ((and (< count 256) (not (byte-compile-version-cond - byte-compile-compatibility))) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-listN count)) - (t (byte-compile-normal-call form))))) - -(defun byte-compile-concat (form) - (let ((count (length (cdr form)))) - (cond ((and (< 1 count) (< count 5)) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out - (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2)) - 0)) - ;; Concat of one arg is not a no-op if arg is not a string. - ((= count 0) - (byte-compile-form "")) - ((and (< count 256) (not (byte-compile-version-cond - byte-compile-compatibility))) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-concatN count)) - ((byte-compile-normal-call form))))) - -(defun byte-compile-minus (form) - (if (null (setq form (cdr form))) - (byte-compile-constant 0) - (byte-compile-form (car form)) - (if (cdr form) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-diff 0)) - (byte-compile-out 'byte-negate 0)))) - -(defun byte-compile-quo (form) - (let ((len (length form))) - (cond ((<= len 2) - (byte-compile-subr-wrong-args form "2 or more")) - (t - (byte-compile-form (car (setq form (cdr form)))) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-quo 0)))))) - -(defun byte-compile-nconc (form) - (let ((len (length form))) - (cond ((= len 1) - (byte-compile-constant nil)) - ((= len 2) - ;; nconc of one arg is a noop, even if that arg isn't a list. - (byte-compile-form (nth 1 form))) - (t - (byte-compile-form (car (setq form (cdr form)))) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-nconc 0)))))) - -(defun byte-compile-fset (form) - ;; warn about forms like (fset 'foo '(lambda () ...)) - ;; (where the lambda expression is non-trivial...) - (let ((fn (nth 2 form)) - body) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (setq fn (nth 1 fn))) 'lambda)) - (progn - (setq body (cdr (cdr fn))) - (if (stringp (car body)) (setq body (cdr body))) - (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) - (if (and (consp (car body)) - (not (eq 'byte-code (car (car body))))) - (byte-compile-warn - "A quoted lambda form is the second argument of fset. This is probably - not what you want, as that lambda cannot be compiled. Consider using - the syntax (function (lambda (...) ...)) instead."))))) - (byte-compile-two-args form)) - -(defun byte-compile-funarg (form) - ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) - ;; for cases where it's guaranteed that first arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 1 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (cons 'function (cdr fn)) - (cdr (cdr form)))) - form)))) - -(defun byte-compile-funarg-2 (form) - ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..))) - ;; for cases where it's guaranteed that second arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 2 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (nth 1 form) - (cons (cons 'function (cdr fn)) - (cdr (cdr (cdr form)))))) - form)))) - -;; (function foo) must compile like 'foo, not like (symbol-function 'foo). -;; Otherwise it will be incompatible with the interpreter, -;; and (funcall (function foo)) will lose with autoloads. - -(defun byte-compile-function-form (form) - (byte-compile-constant - (cond ((symbolp (nth 1 form)) - (nth 1 form)) - ;; If we're not allowed to use #[] syntax, then output a form like - ;; '(lambda (..) (byte-code ..)) instead of a call to make-byte-code. - ;; In this situation, calling make-byte-code at run-time will usually - ;; be less efficient than processing a call to byte-code. - ((byte-compile-version-cond byte-compile-compatibility) - (byte-compile-byte-code-unmake (byte-compile-lambda (nth 1 form)))) - ((byte-compile-lambda (nth 1 form)))))) - -(defun byte-compile-indent-to (form) - (let ((len (length form))) - (cond ((= len 2) - (byte-compile-form (car (cdr form))) - (byte-compile-out 'byte-indent-to 0)) - ((= len 3) - ;; no opcode for 2-arg case. - (byte-compile-normal-call form)) - (t - (byte-compile-subr-wrong-args form "1-2"))))) - -(defun byte-compile-insert (form) - (cond ((null (cdr form)) - (byte-compile-constant nil)) - ((and (not (byte-compile-version-cond - byte-compile-compatibility)) - (<= (length form) 256)) - (mapcar 'byte-compile-form (cdr form)) - (if (cdr (cdr form)) - (byte-compile-out 'byte-insertN (length (cdr form))) - (byte-compile-out 'byte-insert 0))) - ((memq t (mapcar 'consp (cdr (cdr form)))) - (byte-compile-normal-call form)) - ;; We can split it; there is no function call after inserting 1st arg. - (t - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-insert 0) - (if (cdr form) - (byte-compile-discard)))))) - -(defun byte-compile-beginning-of-line (form) - (if (not (byte-compile-constp (nth 1 form))) - (byte-compile-normal-call form) - (byte-compile-form - (list 'forward-line - (if (integerp (setq form (or (eval (nth 1 form)) 1))) - (1- form) - (byte-compile-warn "Non-numeric arg to beginning-of-line: %s" - form) - (list '1- (list 'quote form)))) - t) - (byte-compile-constant nil))) - - -(byte-defop-compiler-1 setq) -(byte-defop-compiler-1 setq-default) -(byte-defop-compiler-1 quote) -(byte-defop-compiler-1 quote-form) - -(defun byte-compile-setq (form) - (let ((args (cdr form))) - (if args - (while args - (byte-compile-form (car (cdr args))) - (or for-effect (cdr (cdr args)) - (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car args)) - (setq args (cdr (cdr args)))) - ;; (setq), with no arguments. - (byte-compile-form nil for-effect)) - (setq for-effect nil))) - -(defun byte-compile-setq-default (form) - (let ((args (cdr form)) - setters) - (while args - (setq setters - (cons (list 'set-default (list 'quote (car args)) (car (cdr args))) - setters)) - (setq args (cdr (cdr args)))) - (byte-compile-form (cons 'progn (nreverse setters))))) - -(defun byte-compile-quote (form) - (byte-compile-constant (car (cdr form)))) - -(defun byte-compile-quote-form (form) - (byte-compile-constant (byte-compile-top-level (nth 1 form)))) - - -;;; control structures - -(defun byte-compile-body (body &optional for-effect) - (while (cdr body) - (byte-compile-form (car body) t) - (setq body (cdr body))) - (byte-compile-form (car body) for-effect)) - -(defsubst byte-compile-body-do-effect (body) - (byte-compile-body body for-effect) - (setq for-effect nil)) - -(defsubst byte-compile-form-do-effect (form) - (byte-compile-form form for-effect) - (setq for-effect nil)) - -(byte-defop-compiler-1 inline byte-compile-progn) -(byte-defop-compiler-1 progn) -(byte-defop-compiler-1 prog1) -(byte-defop-compiler-1 prog2) -(byte-defop-compiler-1 if) -(byte-defop-compiler-1 cond) -(byte-defop-compiler-1 and) -(byte-defop-compiler-1 or) -(byte-defop-compiler-1 while) -(byte-defop-compiler-1 funcall) -(byte-defop-compiler-1 apply byte-compile-funarg) -(byte-defop-compiler-1 mapcar byte-compile-funarg) -(byte-defop-compiler-1 mapatoms byte-compile-funarg) -(byte-defop-compiler-1 mapconcat byte-compile-funarg) -(byte-defop-compiler-1 sort byte-compile-funarg-2) -(byte-defop-compiler-1 let) -(byte-defop-compiler-1 let*) - -(defun byte-compile-progn (form) - (byte-compile-body-do-effect (cdr form))) - -(defun byte-compile-prog1 (form) - (byte-compile-form-do-effect (car (cdr form))) - (byte-compile-body (cdr (cdr form)) t)) - -(defun byte-compile-prog2 (form) - (byte-compile-form (nth 1 form) t) - (byte-compile-form-do-effect (nth 2 form)) - (byte-compile-body (cdr (cdr (cdr form))) t)) - -(defmacro byte-compile-goto-if (cond discard tag) - (` (byte-compile-goto - (if (, cond) - (if (, discard) 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop) - (if (, discard) 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) - (, tag)))) - -(defun byte-compile-if (form) - (byte-compile-form (car (cdr form))) - (if (null (nthcdr 3 form)) - ;; No else-forms - (let ((donetag (byte-compile-make-tag))) - (byte-compile-goto-if nil for-effect donetag) - (byte-compile-form (nth 2 form) for-effect) - (byte-compile-out-tag donetag)) - (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag))) - (byte-compile-goto 'byte-goto-if-nil elsetag) - (byte-compile-form (nth 2 form) for-effect) - (byte-compile-goto 'byte-goto donetag) - (byte-compile-out-tag elsetag) - (byte-compile-body (cdr (cdr (cdr form))) for-effect) - (byte-compile-out-tag donetag))) - (setq for-effect nil)) - -(defun byte-compile-cond (clauses) - (let ((donetag (byte-compile-make-tag)) - nexttag clause) - (while (setq clauses (cdr clauses)) - (setq clause (car clauses)) - (cond ((or (eq (car clause) t) - (and (eq (car-safe (car clause)) 'quote) - (car-safe (cdr-safe (car clause))))) - ;; Unconditional clause - (setq clause (cons t clause) - clauses nil)) - ((cdr clauses) - (byte-compile-form (car clause)) - (if (null (cdr clause)) - ;; First clause is a singleton. - (byte-compile-goto-if t for-effect donetag) - (setq nexttag (byte-compile-make-tag)) - (byte-compile-goto 'byte-goto-if-nil nexttag) - (byte-compile-body (cdr clause) for-effect) - (byte-compile-goto 'byte-goto donetag) - (byte-compile-out-tag nexttag))))) - ;; Last clause - (and (cdr clause) (not (eq (car clause) t)) - (progn (byte-compile-form (car clause)) - (byte-compile-goto-if nil for-effect donetag) - (setq clause (cdr clause)))) - (byte-compile-body-do-effect clause) - (byte-compile-out-tag donetag))) - -(defun byte-compile-and (form) - (let ((failtag (byte-compile-make-tag)) - (args (cdr form))) - (if (null args) - (byte-compile-form-do-effect t) - (while (cdr args) - (byte-compile-form (car args)) - (byte-compile-goto-if nil for-effect failtag) - (setq args (cdr args))) - (byte-compile-form-do-effect (car args)) - (byte-compile-out-tag failtag)))) - -(defun byte-compile-or (form) - (let ((wintag (byte-compile-make-tag)) - (args (cdr form))) - (if (null args) - (byte-compile-form-do-effect nil) - (while (cdr args) - (byte-compile-form (car args)) - (byte-compile-goto-if t for-effect wintag) - (setq args (cdr args))) - (byte-compile-form-do-effect (car args)) - (byte-compile-out-tag wintag)))) - -(defun byte-compile-while (form) - (let ((endtag (byte-compile-make-tag)) - (looptag (byte-compile-make-tag))) - (byte-compile-out-tag looptag) - (byte-compile-form (car (cdr form))) - (byte-compile-goto-if nil for-effect endtag) - (byte-compile-body (cdr (cdr form)) t) - (byte-compile-goto 'byte-goto looptag) - (byte-compile-out-tag endtag) - (setq for-effect nil))) - -(defun byte-compile-funcall (form) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-call (length (cdr (cdr form))))) - - -(defun byte-compile-let (form) - ;; First compute the binding values in the old scope. - (let ((varlist (car (cdr form)))) - (while varlist - (if (consp (car varlist)) - (byte-compile-form (car (cdr (car varlist)))) - (byte-compile-push-constant nil)) - (setq varlist (cdr varlist)))) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (reverse (car (cdr form))))) - (while varlist - (byte-compile-variable-ref 'byte-varbind (if (consp (car varlist)) - (car (car varlist)) - (car varlist))) - (setq varlist (cdr varlist))) - (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) - -(defun byte-compile-let* (form) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (copy-sequence (car (cdr form))))) - (while varlist - (if (atom (car varlist)) - (byte-compile-push-constant nil) - (byte-compile-form (car (cdr (car varlist)))) - (setcar varlist (car (car varlist)))) - (byte-compile-variable-ref 'byte-varbind (car varlist)) - (setq varlist (cdr varlist))) - (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) - - -(byte-defop-compiler-1 /= byte-compile-negated) -(byte-defop-compiler-1 atom byte-compile-negated) -(byte-defop-compiler-1 nlistp byte-compile-negated) - -(put '/= 'byte-compile-negated-op '=) -(put 'atom 'byte-compile-negated-op 'consp) -(put 'nlistp 'byte-compile-negated-op 'listp) - -(defun byte-compile-negated (form) - (byte-compile-form-do-effect (byte-compile-negation-optimizer form))) - -;; Even when optimization is off, /= is optimized to (not (= ...)). -(defun byte-compile-negation-optimizer (form) - ;; an optimizer for forms where <form1> is less efficient than (not <form2>) - (list 'not - (cons (or (get (car form) 'byte-compile-negated-op) - (error - "Compiler error: `%s' has no `byte-compile-negated-op' property" - (car form))) - (cdr form)))) - -;;; other tricky macro-like special-forms - -(byte-defop-compiler-1 catch) -(byte-defop-compiler-1 unwind-protect) -(byte-defop-compiler-1 condition-case) -(byte-defop-compiler-1 save-excursion) -(byte-defop-compiler-1 save-current-buffer) -(byte-defop-compiler-1 save-restriction) -(byte-defop-compiler-1 save-window-excursion) -(byte-defop-compiler-1 with-output-to-temp-buffer) -(byte-defop-compiler-1 track-mouse) - -(defun byte-compile-catch (form) - (byte-compile-form (car (cdr form))) - (byte-compile-push-constant - (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) - (byte-compile-out 'byte-catch 0)) - -(defun byte-compile-unwind-protect (form) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr (cdr form)) t)) - (byte-compile-out 'byte-unwind-protect 0) - (byte-compile-form-do-effect (car (cdr form))) - (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-track-mouse (form) - (byte-compile-form - (list - 'funcall - (list 'quote - (list 'lambda nil - (cons 'track-mouse - (byte-compile-top-level-body (cdr form)))))))) - -(defun byte-compile-condition-case (form) - (let* ((var (nth 1 form)) - (byte-compile-bound-variables - (if var (cons var byte-compile-bound-variables) - byte-compile-bound-variables))) - (or (symbolp var) - (byte-compile-warn - "%s is not a variable-name or nil (in condition-case)" var)) - (byte-compile-push-constant var) - (byte-compile-push-constant (byte-compile-top-level - (nth 2 form) for-effect)) - (let ((clauses (cdr (cdr (cdr form)))) - compiled-clauses) - (while clauses - (let* ((clause (car clauses)) - (condition (car clause))) - (cond ((not (or (symbolp condition) - (and (listp condition) - (let ((syms condition) (ok t)) - (while syms - (if (not (symbolp (car syms))) - (setq ok nil)) - (setq syms (cdr syms))) - ok)))) - (byte-compile-warn - "%s is not a condition name or list of such (in condition-case)" - (prin1-to-string condition))) -;; ((not (or (eq condition 't) -;; (and (stringp (get condition 'error-message)) -;; (consp (get condition 'error-conditions))))) -;; (byte-compile-warn -;; "%s is not a known condition name (in condition-case)" -;; condition)) - ) - (setq compiled-clauses - (cons (cons condition - (byte-compile-top-level-body - (cdr clause) for-effect)) - compiled-clauses))) - (setq clauses (cdr clauses))) - (byte-compile-push-constant (nreverse compiled-clauses))) - (byte-compile-out 'byte-condition-case 0))) - - -(defun byte-compile-save-excursion (form) - (byte-compile-out 'byte-save-excursion 0) - (byte-compile-body-do-effect (cdr form)) - (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-save-restriction (form) - (byte-compile-out 'byte-save-restriction 0) - (byte-compile-body-do-effect (cdr form)) - (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-save-current-buffer (form) - (byte-compile-out 'byte-save-current-buffer 0) - (byte-compile-body-do-effect (cdr form)) - (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-save-window-excursion (form) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr form) for-effect)) - (byte-compile-out 'byte-save-window-excursion 0)) - -(defun byte-compile-with-output-to-temp-buffer (form) - (byte-compile-form (car (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-setup 0) - (byte-compile-body (cdr (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-show 0)) - - -;;; top-level forms elsewhere - -(byte-defop-compiler-1 defun) -(byte-defop-compiler-1 defmacro) -(byte-defop-compiler-1 defvar) -(byte-defop-compiler-1 defconst byte-compile-defvar) -(byte-defop-compiler-1 autoload) -(byte-defop-compiler-1 lambda byte-compile-lambda-form) -(byte-defop-compiler-1 defalias) - -(defun byte-compile-defun (form) - ;; This is not used for file-level defuns with doc strings. - (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning. - (list 'fset (list 'quote (nth 1 form)) - (byte-compile-byte-code-maker - (byte-compile-lambda (cons 'lambda (cdr (cdr form))))))) - (byte-compile-discard) - (byte-compile-constant (nth 1 form))) - -(defun byte-compile-defmacro (form) - ;; This is not used for file-level defmacros with doc strings. - (byte-compile-body-do-effect - (list (list 'fset (list 'quote (nth 1 form)) - (let ((code (byte-compile-byte-code-maker - (byte-compile-lambda - (cons 'lambda (cdr (cdr form))))))) - (if (eq (car-safe code) 'make-byte-code) - (list 'cons ''macro code) - (list 'quote (cons 'macro (eval code)))))) - (list 'quote (nth 1 form))))) - -(defun byte-compile-defvar (form) - ;; This is not used for file-level defvar/consts with doc strings. - (let ((var (nth 1 form)) - (value (nth 2 form)) - (string (nth 3 form))) - (if (memq 'free-vars byte-compile-warnings) - (setq byte-compile-bound-variables - (cons var byte-compile-bound-variables))) - (byte-compile-body-do-effect - (list (if (cdr (cdr form)) - (if (eq (car form) 'defconst) - (list 'setq var value) - (list 'or (list 'boundp (list 'quote var)) - (list 'setq var value)))) - ;; Put the defined variable in this library's load-history entry - ;; just as a real defvar would. - (list 'setq 'current-load-list - (list 'cons (list 'quote var) - 'current-load-list)) - (if string - (list 'put (list 'quote var) ''variable-documentation string)) - (list 'quote var))))) - -(defun byte-compile-autoload (form) - (and (byte-compile-constp (nth 1 form)) - (byte-compile-constp (nth 5 form)) - (eval (nth 5 form)) ; macro-p - (not (fboundp (eval (nth 1 form)))) - (byte-compile-warn - "The compiler ignores `autoload' except at top level. You should - probably put the autoload of the macro `%s' at top-level." - (eval (nth 1 form)))) - (byte-compile-normal-call form)) - -;; Lambda's in valid places are handled as special cases by various code. -;; The ones that remain are errors. -(defun byte-compile-lambda-form (form) - (error "`lambda' used as function name is invalid")) - -;; Compile normally, but deal with warnings for the function being defined. -(defun byte-compile-defalias (form) - (if (and (consp (cdr form)) (consp (nth 1 form)) - (eq (car (nth 1 form)) 'quote) - (consp (cdr (nth 1 form))) - (symbolp (nth 1 (nth 1 form))) - (consp (nthcdr 2 form)) - (consp (nth 2 form)) - (eq (car (nth 2 form)) 'quote) - (consp (cdr (nth 2 form))) - (symbolp (nth 1 (nth 2 form)))) - (progn - (byte-compile-defalias-warn (nth 1 (nth 1 form)) - (nth 1 (nth 2 form))) - (setq byte-compile-function-environment - (cons (cons (nth 1 (nth 1 form)) - (nth 1 (nth 2 form))) - byte-compile-function-environment)))) - (byte-compile-normal-call form)) - -;; Turn off warnings about prior calls to the function being defalias'd. -;; This could be smarter and compare those calls with -;; the function it is being aliased to. -(defun byte-compile-defalias-warn (new alias) - (let ((calls (assq new byte-compile-unresolved-functions))) - (if calls - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))) - -;;; tags - -;; Note: Most operations will strip off the 'TAG, but it speeds up -;; optimization to have the 'TAG as a part of the tag. -;; Tags will be (TAG . (tag-number . stack-depth)). -(defun byte-compile-make-tag () - (list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number)))) - - -(defun byte-compile-out-tag (tag) - (setq byte-compile-output (cons tag byte-compile-output)) - (if (cdr (cdr tag)) - (progn - ;; ## remove this someday - (and byte-compile-depth - (not (= (cdr (cdr tag)) byte-compile-depth)) - (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) - (setq byte-compile-depth (cdr (cdr tag)))) - (setcdr (cdr tag) byte-compile-depth))) - -(defun byte-compile-goto (opcode tag) - (setq byte-compile-output (cons (cons opcode tag) byte-compile-output)) - (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops) - (1- byte-compile-depth) - byte-compile-depth)) - (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) - (1- byte-compile-depth)))) - -(defun byte-compile-out (opcode offset) - (setq byte-compile-output (cons (cons opcode offset) byte-compile-output)) - (cond ((eq opcode 'byte-call) - (setq byte-compile-depth (- byte-compile-depth offset))) - ((eq opcode 'byte-return) - ;; This is actually an unnecessary case, because there should be - ;; no more opcodes behind byte-return. - (setq byte-compile-depth nil)) - (t - (setq byte-compile-depth (+ byte-compile-depth - (or (aref byte-stack+-info - (symbol-value opcode)) - (- (1- offset)))) - byte-compile-maxdepth (max byte-compile-depth - byte-compile-maxdepth)))) - ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) - ) - - -;;; call tree stuff - -(defun byte-compile-annotate-call-tree (form) - (let (entry) - ;; annotate the current call - (if (setq entry (assq (car form) byte-compile-call-tree)) - (or (memq byte-compile-current-form (nth 1 entry)) ;callers - (setcar (cdr entry) - (cons byte-compile-current-form (nth 1 entry)))) - (setq byte-compile-call-tree - (cons (list (car form) (list byte-compile-current-form) nil) - byte-compile-call-tree))) - ;; annotate the current function - (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) - (or (memq (car form) (nth 2 entry)) ;called - (setcar (cdr (cdr entry)) - (cons (car form) (nth 2 entry)))) - (setq byte-compile-call-tree - (cons (list byte-compile-current-form nil (list (car form))) - byte-compile-call-tree))) - )) - -;; Renamed from byte-compile-report-call-tree -;; to avoid interfering with completion of byte-compile-file. -;;;###autoload -(defun display-call-tree (&optional filename) - "Display a call graph of a specified file. -This lists which functions have been called, what functions called -them, and what functions they call. The list includes all functions -whose definitions have been compiled in this Emacs session, as well as -all functions called by those functions. - -The call graph does not include macros, inline functions, or -primitives that the byte-code interpreter knows about directly \(eq, -cons, etc.\). - -The call tree also lists those functions which are not known to be called -\(that is, to which no calls have been compiled\), and which cannot be -invoked interactively." - (interactive) - (message "Generating call tree...") - (with-output-to-temp-buffer "*Call-Tree*" - (set-buffer "*Call-Tree*") - (erase-buffer) - (message "Generating call tree... (sorting on %s)" - byte-compile-call-tree-sort) - (insert "Call tree for " - (cond ((null byte-compile-current-file) (or filename "???")) - ((stringp byte-compile-current-file) - byte-compile-current-file) - (t (buffer-name byte-compile-current-file))) - " sorted on " - (prin1-to-string byte-compile-call-tree-sort) - ":\n\n") - (if byte-compile-call-tree-sort - (setq byte-compile-call-tree - (sort byte-compile-call-tree - (cond ((eq byte-compile-call-tree-sort 'callers) - (function (lambda (x y) (< (length (nth 1 x)) - (length (nth 1 y)))))) - ((eq byte-compile-call-tree-sort 'calls) - (function (lambda (x y) (< (length (nth 2 x)) - (length (nth 2 y)))))) - ((eq byte-compile-call-tree-sort 'calls+callers) - (function (lambda (x y) (< (+ (length (nth 1 x)) - (length (nth 2 x))) - (+ (length (nth 1 y)) - (length (nth 2 y))))))) - ((eq byte-compile-call-tree-sort 'name) - (function (lambda (x y) (string< (car x) - (car y))))) - (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" - byte-compile-call-tree-sort)))))) - (message "Generating call tree...") - (let ((rest byte-compile-call-tree) - (b (current-buffer)) - f p - callers calls) - (while rest - (prin1 (car (car rest)) b) - (setq callers (nth 1 (car rest)) - calls (nth 2 (car rest))) - (insert "\t" - (cond ((not (fboundp (setq f (car (car rest))))) - (if (null f) - " <top level>";; shouldn't insert nil then, actually -sk - " <not defined>")) - ((subrp (setq f (symbol-function f))) - " <subr>") - ((symbolp f) - (format " ==> %s" f)) - ((byte-code-function-p f) - "<compiled function>") - ((not (consp f)) - "<malformed function>") - ((eq 'macro (car f)) - (if (or (byte-code-function-p (cdr f)) - (assq 'byte-code (cdr (cdr (cdr f))))) - " <compiled macro>" - " <macro>")) - ((assq 'byte-code (cdr (cdr f))) - "<compiled lambda>") - ((eq 'lambda (car f)) - "<function>") - (t "???")) - (format " (%d callers + %d calls = %d)" - ;; Does the optimizer eliminate common subexpressions?-sk - (length callers) - (length calls) - (+ (length callers) (length calls))) - "\n") - (if callers - (progn - (insert " called by:\n") - (setq p (point)) - (insert " " (if (car callers) - (mapconcat 'symbol-name callers ", ") - "<top level>")) - (let ((fill-prefix " ")) - (fill-region-as-paragraph p (point))))) - (if calls - (progn - (insert " calls:\n") - (setq p (point)) - (insert " " (mapconcat 'symbol-name calls ", ")) - (let ((fill-prefix " ")) - (fill-region-as-paragraph p (point))))) - (insert "\n") - (setq rest (cdr rest))) - - (message "Generating call tree...(finding uncalled functions...)") - (setq rest byte-compile-call-tree) - (let ((uncalled nil)) - (while rest - (or (nth 1 (car rest)) - (null (setq f (car (car rest)))) - (byte-compile-fdefinition f t) - (commandp (byte-compile-fdefinition f nil)) - (setq uncalled (cons f uncalled))) - (setq rest (cdr rest))) - (if uncalled - (let ((fill-prefix " ")) - (insert "Noninteractive functions not known to be called:\n ") - (setq p (point)) - (insert (mapconcat 'symbol-name (nreverse uncalled) ", ")) - (fill-region-as-paragraph p (point))))) - ) - (message "Generating call tree...done.") - )) - - -;;; by crl@newton.purdue.edu -;;; Only works noninteractively. -;;;###autoload -(defun batch-byte-compile () - "Run `byte-compile-file' on the files remaining on the command line. -Use this from the command line, with `-batch'; -it won't work in an interactive Emacs. -Each file is processed even if an error occurred previously. -For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\"" - ;; command-line-args-left is what is left of the command line (from startup.el) - (defvar command-line-args-left) ;Avoid 'free variable' warning - (if (not noninteractive) - (error "`batch-byte-compile' is to be used only with -batch")) - (let ((error nil)) - (while command-line-args-left - (if (file-directory-p (expand-file-name (car command-line-args-left))) - (let ((files (directory-files (car command-line-args-left))) - source dest) - (while files - (if (and (string-match emacs-lisp-file-regexp (car files)) - (not (auto-save-file-name-p (car files))) - (setq source (expand-file-name (car files) - (car command-line-args-left))) - (setq dest (byte-compile-dest-file source)) - (file-exists-p dest) - (file-newer-than-file-p source dest)) - (if (null (batch-byte-compile-file source)) - (setq error t))) - (setq files (cdr files)))) - (if (null (batch-byte-compile-file (car command-line-args-left))) - (setq error t))) - (setq command-line-args-left (cdr command-line-args-left))) - (message "Done") - (kill-emacs (if error 1 0)))) - -(defun batch-byte-compile-file (file) - (condition-case err - (progn (byte-compile-file file) t) - (error - (message (if (cdr err) - ">>Error occurred processing %s: %s (%s)" - ">>Error occurred processing %s: %s") - file - (get (car err) 'error-message) - (prin1-to-string (cdr err))) - nil))) - -;;;###autoload -(defun batch-byte-recompile-directory () - "Runs `byte-recompile-directory' on the dirs remaining on the command line. -Must be used only with `-batch', and kills Emacs on completion. -For example, invoke `emacs -batch -f batch-byte-recompile-directory .'." - ;; command-line-args-left is what is left of the command line (startup.el) - (defvar command-line-args-left) ;Avoid 'free variable' warning - (if (not noninteractive) - (error "batch-byte-recompile-directory is to be used only with -batch")) - (or command-line-args-left - (setq command-line-args-left '("."))) - (while command-line-args-left - (byte-recompile-directory (car command-line-args-left)) - (setq command-line-args-left (cdr command-line-args-left))) - (kill-emacs 0)) - - -(make-obsolete 'dot 'point) -(make-obsolete 'dot-max 'point-max) -(make-obsolete 'dot-min 'point-min) -(make-obsolete 'dot-marker 'point-marker) - -(make-obsolete 'buffer-flush-undo 'buffer-disable-undo) -(make-obsolete 'baud-rate "use the baud-rate variable instead") -(make-obsolete 'compiled-function-p 'byte-code-function-p) -(make-obsolete 'define-function 'defalias) -(make-obsolete-variable 'auto-fill-hook 'auto-fill-function) -(make-obsolete-variable 'blink-paren-hook 'blink-paren-function) -(make-obsolete-variable 'lisp-indent-hook 'lisp-indent-function) -(make-obsolete-variable 'temp-buffer-show-hook - 'temp-buffer-show-function) -(make-obsolete-variable 'inhibit-local-variables - "use enable-local-variables (with the reversed sense).") -(make-obsolete-variable 'unread-command-char - "use unread-command-events instead. That variable is a list of events to reread, so it now uses nil to mean `no event', instead of -1.") -(make-obsolete-variable 'unread-command-event - "use unread-command-events; which is a list of events rather than a single event.") -(make-obsolete-variable 'suspend-hooks 'suspend-hook) -(make-obsolete-variable 'comment-indent-hook 'comment-indent-function) -(make-obsolete-variable 'meta-flag "Use the set-input-mode function instead.") -(make-obsolete-variable 'executing-macro 'executing-kbd-macro) -(make-obsolete-variable 'before-change-function - "use before-change-functions; which is a list of functions rather than a single function.") -(make-obsolete-variable 'after-change-function - "use after-change-functions; which is a list of functions rather than a single function.") -(make-obsolete-variable 'font-lock-doc-string-face 'font-lock-string-face) -(make-obsolete-variable 'post-command-idle-hook - "use timers instead, with `run-with-idle-timer'.") -(make-obsolete-variable 'post-command-idle-delay - "use timers instead, with `run-with-idle-timer'.") - -(provide 'byte-compile) -(provide 'bytecomp) - - -;;; report metering (see the hacks in bytecode.c) - -(defun byte-compile-report-ops () - (defvar byte-code-meter) - (with-output-to-temp-buffer "*Meter*" - (set-buffer "*Meter*") - (let ((i 0) n op off) - (while (< i 256) - (setq n (aref (aref byte-code-meter 0) i) - off nil) - (if t ;(not (zerop n)) - (progn - (setq op i) - (setq off nil) - (cond ((< op byte-nth) - (setq off (logand op 7)) - (setq op (logand op 248))) - ((>= op byte-constant) - (setq off (- op byte-constant) - op byte-constant))) - (setq op (aref byte-code-vector op)) - (insert (format "%-4d" i)) - (insert (symbol-name op)) - (if off (insert " [" (int-to-string off) "]")) - (indent-to 40) - (insert (int-to-string n) "\n"))) - (setq i (1+ i)))))) - -;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compiles -;; itself, compile some of its most used recursive functions (at load time). -;; -(eval-when-compile - (or (byte-code-function-p (symbol-function 'byte-compile-form)) - (assq 'byte-code (symbol-function 'byte-compile-form)) - (let ((byte-optimize nil) ; do it fast - (byte-compile-warnings nil)) - (mapcar '(lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) - '(byte-compile-normal-call - byte-compile-form - byte-compile-body - ;; Inserted some more than necessary, to speed it up. - byte-compile-top-level - byte-compile-out-toplevel - byte-compile-constant - byte-compile-variable-ref)))) - nil) - -;;; bytecomp.el ends here diff --git a/lisp/emacs-lisp/cl-compat.el b/lisp/emacs-lisp/cl-compat.el deleted file mode 100644 index 7d5b6492edf..00000000000 --- a/lisp/emacs-lisp/cl-compat.el +++ /dev/null @@ -1,192 +0,0 @@ -;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility) - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains emulations of internal routines of the older -;; CL package which users may have called directly from their code. -;; Use (require 'cl-compat) to get these routines. - -;; See cl.el for Change Log. - - -;;; Code: - -;; Require at load-time, but not when compiling cl-compat. -(or (featurep 'cl) (require 'cl)) - - -;;; Keyword routines not supported by new package. - -(defmacro defkeyword (x &optional doc) - (list* 'defconst x (list 'quote x) (and doc (list doc)))) - -(defun keywordp (sym) - (and (symbolp sym) (eq (aref (symbol-name sym) 0) ?\:) (set sym sym))) - -(defun keyword-of (sym) - (or (keywordp sym) (keywordp (intern (format ":%s" sym))))) - - -;;; Multiple values. Note that the new package uses a different -;;; convention for multiple values. The following definitions -;;; emulate the old convention; all function names have been changed -;;; by capitalizing the first letter: Values, Multiple-value-*, -;;; to avoid conflict with the new-style definitions in cl-macs. - -(put 'Multiple-value-bind 'lisp-indent-function 2) -(put 'Multiple-value-setq 'lisp-indent-function 2) -(put 'Multiple-value-call 'lisp-indent-function 1) -(put 'Multiple-value-prog1 'lisp-indent-function 1) - -(defvar *mvalues-values* nil) - -(defun Values (&rest val-forms) - (setq *mvalues-values* val-forms) - (car val-forms)) - -(defun Values-list (val-forms) - (apply 'values val-forms)) - -(defmacro Multiple-value-list (form) - (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form)) - '(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*) - (list *mvalues-temp*)))) - -(defmacro Multiple-value-call (function &rest args) - (list 'apply function - (cons 'append - (mapcar (function (lambda (x) (list 'Multiple-value-list x))) - args)))) - -(defmacro Multiple-value-bind (vars form &rest body) - (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body)) - -(defmacro Multiple-value-setq (vars form) - (list 'multiple-value-setq vars (list 'Multiple-value-list form))) - -(defmacro Multiple-value-prog1 (form &rest body) - (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body))) - - -;;; Routines for parsing keyword arguments. - -(defun build-klist (arglist keys &optional allow-others) - (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist)))) - (or allow-others - (let ((bad (set-difference (mapcar 'car res) keys))) - (if bad (error "Bad keywords: %s not in %s" bad keys)))) - res)) - -(defun extract-from-klist (klist key &optional def) - (let ((res (assq key klist))) (if res (cdr res) def))) - -(defun keyword-argument-supplied-p (klist key) - (assq key klist)) - -(defun elt-satisfies-test-p (item elt klist) - (let ((test-not (cdr (assq ':test-not klist))) - (test (cdr (assq ':test klist))) - (key (cdr (assq ':key klist)))) - (if key (setq elt (funcall key elt))) - (if test-not (not (funcall test-not item elt)) - (funcall (or test 'eql) item elt)))) - - -;;; Rounding functions with old-style multiple value returns. - -(defun cl-floor (a &optional b) (Values-list (floor* a b))) -(defun cl-ceiling (a &optional b) (Values-list (ceiling* a b))) -(defun cl-round (a &optional b) (Values-list (round* a b))) -(defun cl-truncate (a &optional b) (Values-list (truncate* a b))) - -(defun safe-idiv (a b) - (let* ((q (/ (abs a) (abs b))) - (s (* (signum a) (signum b)))) - (Values q (- a (* s q b)) s))) - - -;; Internal routines. - -(defun pair-with-newsyms (oldforms) - (let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms))) - (Values (mapcar* 'list newsyms oldforms) newsyms))) - -(defun zip-lists (evens odds) - (mapcan 'list evens odds)) - -(defun unzip-lists (list) - (let ((e nil) (o nil)) - (while list - (setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list))) - (Values (nreverse e) (nreverse o)))) - -(defun reassemble-argslists (list) - (let ((n (apply 'min (mapcar 'length list))) (res nil)) - (while (>= (setq n (1- n)) 0) - (setq res (cons (mapcar (function (lambda (x) (elt x n))) list) res))) - res)) - -(defun duplicate-symbols-p (list) - (let ((res nil)) - (while list - (if (memq (car list) (cdr list)) (setq res (cons (car list) res))) - (setq list (cdr list))) - res)) - - -;;; Setf internals. - -(defun setnth (n list x) - (setcar (nthcdr n list) x)) - -(defun setnthcdr (n list x) - (setcdr (nthcdr (1- n) list) x)) - -(defun setelt (seq n x) - (if (consp seq) (setcar (nthcdr n seq) x) (aset seq n x))) - - -;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms, -;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms, -;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify, -;;; all names with embedded `$'. - - -(provide 'cl-compat) - -;;; cl-compat.el ends here - diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el deleted file mode 100644 index 2402d799108..00000000000 --- a/lisp/emacs-lisp/cl-extra.el +++ /dev/null @@ -1,924 +0,0 @@ -;;; cl-extra.el --- Common Lisp features, part 2 -*-byte-compile-dynamic: t;-*- - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains portions of the Common Lisp extensions -;; package which are autoloaded since they are relatively obscure. - -;; See cl.el for Change Log. - - -;;; Code: - -(or (memq 'cl-19 features) - (error "Tried to load `cl-extra' before `cl'!")) - - -;;; We define these here so that this file can compile without having -;;; loaded the cl.el file already. - -(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) -(defmacro cl-pop (place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) - -(defvar cl-emacs-type) - - -;;; Type coercion. - -(defun coerce (x type) - "Coerce OBJECT to type TYPE. -TYPE is a Common Lisp type specifier." - (cond ((eq type 'list) (if (listp x) x (append x nil))) - ((eq type 'vector) (if (vectorp x) x (vconcat x))) - ((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)) (coerce (symbol-name x) type)) - ((eq type 'float) (float x)) - ((typep x type) x) - (t (error "Can't coerce %s to type %s" x type)))) - - -;;; Predicates. - -(defun equalp (x y) - "T if two Lisp objects have similar structures and contents. -This is like `equal', except that it accepts numerically equal -numbers of different types (float vs. integer), and also compares -strings case-insensitively." - (cond ((eq x y) t) - ((stringp x) - (and (stringp y) (= (length x) (length y)) - (or (string-equal x y) - (string-equal (downcase x) (downcase y))))) ; lazy but simple! - ((numberp x) - (and (numberp y) (= x y))) - ((consp x) - (while (and (consp x) (consp y) (equalp (car x) (car y))) - (setq x (cdr x) y (cdr y))) - (and (not (consp x)) (equalp x y))) - ((vectorp x) - (and (vectorp y) (= (length x) (length y)) - (let ((i (length x))) - (while (and (>= (setq i (1- i)) 0) - (equalp (aref x i) (aref y i)))) - (< i 0)))) - (t (equal x y)))) - - -;;; Control structures. - -(defun cl-mapcar-many (cl-func cl-seqs) - (if (cdr (cdr cl-seqs)) - (let* ((cl-res nil) - (cl-n (apply 'min (mapcar 'length cl-seqs))) - (cl-i 0) - (cl-args (copy-sequence cl-seqs)) - cl-p1 cl-p2) - (setq cl-seqs (copy-sequence cl-seqs)) - (while (< cl-i cl-n) - (setq cl-p1 cl-seqs cl-p2 cl-args) - (while cl-p1 - (setcar cl-p2 - (if (consp (car cl-p1)) - (prog1 (car (car cl-p1)) - (setcar cl-p1 (cdr (car cl-p1)))) - (aref (car cl-p1) cl-i))) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) - (cl-push (apply cl-func cl-args) cl-res) - (setq cl-i (1+ cl-i))) - (nreverse cl-res)) - (let ((cl-res nil) - (cl-x (car cl-seqs)) - (cl-y (nth 1 cl-seqs))) - (let ((cl-n (min (length cl-x) (length cl-y))) - (cl-i -1)) - (while (< (setq cl-i (1+ cl-i)) cl-n) - (cl-push (funcall cl-func - (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i)) - (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i))) - cl-res))) - (nreverse cl-res)))) - -(defun map (cl-type cl-func cl-seq &rest cl-rest) - "Map a function across one or more sequences, returning a sequence. -TYPE is the sequence type to return, FUNC is the function, and SEQS -are the argument sequences." - (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) - (and cl-type (coerce cl-res cl-type)))) - -(defun maplist (cl-func cl-list &rest cl-rest) - "Map FUNC to each sublist of LIST or LISTS. -Like `mapcar', except applies to lists and their cdr's rather than to -the elements themselves." - (if cl-rest - (let ((cl-res nil) - (cl-args (cons cl-list (copy-sequence cl-rest))) - cl-p) - (while (not (memq nil cl-args)) - (cl-push (apply cl-func cl-args) cl-res) - (setq cl-p cl-args) - (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) ))) - (nreverse cl-res)) - (let ((cl-res nil)) - (while cl-list - (cl-push (funcall cl-func cl-list) cl-res) - (setq cl-list (cdr cl-list))) - (nreverse cl-res)))) - -(defun mapc (cl-func cl-seq &rest cl-rest) - "Like `mapcar', but does not accumulate values returned by the function." - (if cl-rest - (apply 'map nil cl-func cl-seq cl-rest) - (mapcar cl-func cl-seq)) - cl-seq) - -(defun mapl (cl-func cl-list &rest cl-rest) - "Like `maplist', but does not accumulate values returned by the function." - (if cl-rest - (apply 'maplist cl-func cl-list cl-rest) - (let ((cl-p cl-list)) - (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) - cl-list) - -(defun mapcan (cl-func cl-seq &rest cl-rest) - "Like `mapcar', but nconc's together the values returned by the function." - (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) - -(defun mapcon (cl-func cl-list &rest cl-rest) - "Like `maplist', but nconc's together the values returned by the function." - (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) - -(defun some (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is true of any element of SEQ or SEQs. -If so, return the true (non-nil) value returned by PREDICATE." - (if (or cl-rest (nlistp cl-seq)) - (catch 'cl-some - (apply 'map nil - (function (lambda (&rest cl-x) - (let ((cl-res (apply cl-pred cl-x))) - (if cl-res (throw 'cl-some cl-res))))) - cl-seq cl-rest) nil) - (let ((cl-x nil)) - (while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq)))))) - cl-x))) - -(defun every (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is true of every element of SEQ or SEQs." - (if (or cl-rest (nlistp cl-seq)) - (catch 'cl-every - (apply 'map nil - (function (lambda (&rest cl-x) - (or (apply cl-pred cl-x) (throw 'cl-every nil)))) - cl-seq cl-rest) t) - (while (and cl-seq (funcall cl-pred (car cl-seq))) - (setq cl-seq (cdr cl-seq))) - (null cl-seq))) - -(defun notany (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is false of every element of SEQ or SEQs." - (not (apply 'some cl-pred cl-seq cl-rest))) - -(defun notevery (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is false of some element of SEQ or SEQs." - (not (apply 'every cl-pred cl-seq cl-rest))) - -;;; Support for `loop'. -(defun cl-map-keymap (cl-func cl-map) - (while (symbolp cl-map) (setq cl-map (symbol-function cl-map))) - (if (eq cl-emacs-type 'lucid) (funcall 'map-keymap cl-func cl-map) - (if (listp cl-map) - (let ((cl-p cl-map)) - (while (consp (setq cl-p (cdr cl-p))) - (cond ((consp (car cl-p)) - (funcall cl-func (car (car cl-p)) (cdr (car cl-p)))) - ((vectorp (car cl-p)) - (cl-map-keymap cl-func (car cl-p))) - ((eq (car cl-p) 'keymap) - (setq cl-p nil))))) - (let ((cl-i -1)) - (while (< (setq cl-i (1+ cl-i)) (length cl-map)) - (if (aref cl-map cl-i) - (funcall cl-func cl-i (aref cl-map cl-i)))))))) - -(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) - (or cl-base - (setq cl-base (copy-sequence (if (eq cl-emacs-type 18) "0" [0])))) - (cl-map-keymap - (function - (lambda (cl-key cl-bind) - (aset cl-base (1- (length cl-base)) cl-key) - (if (keymapp cl-bind) - (cl-map-keymap-recursively - cl-func-rec cl-bind - (funcall (if (eq cl-emacs-type 18) 'concat 'vconcat) - cl-base (list 0))) - (funcall cl-func-rec cl-base cl-bind)))) - cl-map)) - -(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) - (or cl-what (setq cl-what (current-buffer))) - (if (bufferp cl-what) - (let (cl-mark cl-mark2 (cl-next t) cl-next2) - (save-excursion - (set-buffer cl-what) - (setq cl-mark (copy-marker (or cl-start (point-min)))) - (setq cl-mark2 (and cl-end (copy-marker cl-end)))) - (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) - (setq cl-next (and (fboundp 'next-property-change) - (if cl-prop (next-single-property-change - cl-mark cl-prop cl-what) - (next-property-change cl-mark cl-what))) - cl-next2 (or cl-next (save-excursion - (set-buffer cl-what) (point-max)))) - (funcall cl-func (prog1 (marker-position cl-mark) - (set-marker cl-mark cl-next2)) - (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) - (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) - (or cl-start (setq cl-start 0)) - (or cl-end (setq cl-end (length cl-what))) - (while (< cl-start cl-end) - (let ((cl-next (or (and (fboundp 'next-property-change) - (if cl-prop (next-single-property-change - cl-start cl-prop cl-what) - (next-property-change cl-start cl-what))) - cl-end))) - (funcall cl-func cl-start (min cl-next cl-end)) - (setq cl-start cl-next))))) - -(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) - (or cl-buffer (setq cl-buffer (current-buffer))) - (if (fboundp 'overlay-lists) - - ;; This is the preferred algorithm, though overlay-lists is undocumented. - (let (cl-ovl) - (save-excursion - (set-buffer cl-buffer) - (setq cl-ovl (overlay-lists)) - (if cl-start (setq cl-start (copy-marker cl-start))) - (if cl-end (setq cl-end (copy-marker cl-end)))) - (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) - (while (and cl-ovl - (or (not (overlay-start (car cl-ovl))) - (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) - (and cl-start (<= (overlay-end (car cl-ovl)) cl-start)) - (not (funcall cl-func (car cl-ovl) cl-arg)))) - (setq cl-ovl (cdr cl-ovl))) - (if cl-start (set-marker cl-start nil)) - (if cl-end (set-marker cl-end nil))) - - ;; This alternate algorithm fails to find zero-length overlays. - (let ((cl-mark (save-excursion (set-buffer cl-buffer) - (copy-marker (or cl-start (point-min))))) - (cl-mark2 (and cl-end (save-excursion (set-buffer cl-buffer) - (copy-marker cl-end)))) - cl-pos cl-ovl) - (while (save-excursion - (and (setq cl-pos (marker-position cl-mark)) - (< cl-pos (or cl-mark2 (point-max))) - (progn - (set-buffer cl-buffer) - (setq cl-ovl (overlays-at cl-pos)) - (set-marker cl-mark (next-overlay-change cl-pos))))) - (while (and cl-ovl - (or (/= (overlay-start (car cl-ovl)) cl-pos) - (not (and (funcall cl-func (car cl-ovl) cl-arg) - (set-marker cl-mark nil))))) - (setq cl-ovl (cdr cl-ovl)))) - (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))) - -;;; Support for `setf'. -(defun cl-set-frame-visible-p (frame val) - (cond ((null val) (make-frame-invisible frame)) - ((eq val 'icon) (iconify-frame frame)) - (t (make-frame-visible frame))) - val) - -;;; Support for `progv'. -(defvar cl-progv-save) -(defun cl-progv-before (syms values) - (while syms - (cl-push (if (boundp (car syms)) - (cons (car syms) (symbol-value (car syms))) - (car syms)) cl-progv-save) - (if values - (set (cl-pop syms) (cl-pop values)) - (makunbound (cl-pop syms))))) - -(defun cl-progv-after () - (while cl-progv-save - (if (consp (car cl-progv-save)) - (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) - (makunbound (car cl-progv-save))) - (cl-pop cl-progv-save))) - - -;;; Numbers. - -(defun gcd (&rest args) - "Return the greatest common divisor of the arguments." - (let ((a (abs (or (cl-pop args) 0)))) - (while args - (let ((b (abs (cl-pop args)))) - (while (> b 0) (setq b (% a (setq a b)))))) - a)) - -(defun lcm (&rest args) - "Return the least common multiple of the arguments." - (if (memq 0 args) - 0 - (let ((a (abs (or (cl-pop args) 1)))) - (while args - (let ((b (abs (cl-pop args)))) - (setq a (* (/ a (gcd a b)) b)))) - a))) - -(defun isqrt (a) - "Return the integer square root of the argument." - (if (and (integerp a) (> a 0)) - (let ((g (cond ((<= a 100) 10) ((<= a 10000) 100) - ((<= a 1000000) 1000) (t a))) - g2) - (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) - (setq g g2)) - g) - (if (eq a 0) 0 (signal 'arith-error nil)))) - -(defun cl-expt (x y) - "Return X raised to the power of Y. Works only for integer arguments." - (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) - (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) -(or (and (fboundp 'expt) (subrp (symbol-function 'expt))) - (defalias 'expt 'cl-expt)) - -(defun floor* (x &optional y) - "Return a list of the floor of X and the fractional part of X. -With two arguments, return floor and remainder of their quotient." - (let ((q (floor x y))) - (list q (- x (if y (* y q) q))))) - -(defun ceiling* (x &optional y) - "Return a list of the ceiling of X and the fractional part of X. -With two arguments, return ceiling and remainder of their quotient." - (let ((res (floor* x y))) - (if (= (car (cdr res)) 0) res - (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) - -(defun truncate* (x &optional y) - "Return a list of the integer part of X and the fractional part of X. -With two arguments, return truncation and remainder of their quotient." - (if (eq (>= x 0) (or (null y) (>= y 0))) - (floor* x y) (ceiling* x y))) - -(defun round* (x &optional y) - "Return a list of X rounded to the nearest integer and the remainder. -With two arguments, return rounding and remainder of their quotient." - (if y - (if (and (integerp x) (integerp y)) - (let* ((hy (/ y 2)) - (res (floor* (+ x hy) y))) - (if (and (= (car (cdr res)) 0) - (= (+ hy hy) y) - (/= (% (car res) 2) 0)) - (list (1- (car res)) hy) - (list (car res) (- (car (cdr res)) hy)))) - (let ((q (round (/ x y)))) - (list q (- x (* q y))))) - (if (integerp x) (list x 0) - (let ((q (round x))) - (list q (- x q)))))) - -(defun mod* (x y) - "The remainder of X divided by Y, with the same sign as Y." - (nth 1 (floor* x y))) - -(defun rem* (x y) - "The remainder of X divided by Y, with the same sign as X." - (nth 1 (truncate* x y))) - -(defun signum (a) - "Return 1 if A is positive, -1 if negative, 0 if zero." - (cond ((> a 0) 1) ((< a 0) -1) (t 0))) - - -;; Random numbers. - -(defvar *random-state*) -(defun random* (lim &optional state) - "Return a random nonnegative number less than LIM, an integer or float. -Optional second arg STATE is a random-state object." - (or state (setq state *random-state*)) - ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. - (let ((vec (aref state 3))) - (if (integerp vec) - (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1) ii) - (aset state 3 (setq vec (make-vector 55 nil))) - (aset vec 0 j) - (while (> (setq i (% (+ i 21) 55)) 0) - (aset vec i (setq j (prog1 k (setq k (- j k)))))) - (while (< (setq i (1+ i)) 200) (random* 2 state)))) - (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) - (j (aset state 2 (% (1+ (aref state 2)) 55))) - (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) - (if (integerp lim) - (if (<= lim 512) (% n lim) - (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state)))) - (let ((mask 1023)) - (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) - (if (< (setq n (logand n mask)) lim) n (random* lim state)))) - (* (/ n '8388608e0) lim))))) - -(defun make-random-state (&optional state) - "Return a copy of random-state STATE, or of `*random-state*' if omitted. -If STATE is t, return a new state object seeded from the time of day." - (cond ((null state) (make-random-state *random-state*)) - ((vectorp state) (cl-copy-tree state t)) - ((integerp state) (vector 'cl-random-state-tag -1 30 state)) - (t (make-random-state (cl-random-time))))) - -(defun 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))) - - -;; Implementation limits. - -(defun cl-finite-do (func a b) - (condition-case err - (let ((res (funcall func a b))) ; check for IEEE infinity - (and (numberp res) (/= res (/ res 2)) res)) - (arith-error nil))) - -(defvar most-positive-float) -(defvar most-negative-float) -(defvar least-positive-float) -(defvar least-negative-float) -(defvar least-positive-normalized-float) -(defvar least-negative-normalized-float) -(defvar float-epsilon) -(defvar float-negative-epsilon) - -(defun cl-float-limits () - (or most-positive-float (not (numberp '2e1)) - (let ((x '2e0) y z) - ;; Find maximum exponent (first two loops are optimizations) - (while (cl-finite-do '* x x) (setq x (* x x))) - (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) - (while (cl-finite-do '+ x x) (setq x (+ x x))) - (setq z x y (/ x 2)) - ;; Now fill in 1's in the mantissa. - (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) - (setq x (+ x y) y (/ y 2))) - (setq most-positive-float x - most-negative-float (- x)) - ;; Divide down until mantissa starts rounding. - (setq x (/ x z) y (/ 16 z) x (* x y)) - (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) - (arith-error nil)) - (setq x (/ x 2) y (/ y 2))) - (setq least-positive-normalized-float y - least-negative-normalized-float (- y)) - ;; Divide down until value underflows to zero. - (setq x (/ 1 z) y x) - (while (condition-case err (> (/ x 2) 0) (arith-error nil)) - (setq x (/ x 2))) - (setq least-positive-float x - least-negative-float (- x)) - (setq x '1e0) - (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-epsilon (* x 2)) - (setq x '1e0) - (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-negative-epsilon (* x 2)))) - nil) - - -;;; Sequence functions. - -(defun subseq (seq start &optional end) - "Return the subsequence of SEQ from START to END. -If END is omitted, it defaults to the length of the sequence. -If START or END is negative, it counts from the end." - (if (stringp seq) (substring seq start end) - (let (len) - (and end (< end 0) (setq end (+ end (setq len (length seq))))) - (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) - (cond ((listp seq) - (if (> start 0) (setq seq (nthcdr start seq))) - (if end - (let ((res nil)) - (while (>= (setq end (1- end)) start) - (cl-push (cl-pop seq) res)) - (nreverse res)) - (copy-sequence seq))) - (t - (or end (setq end (or len (length seq)))) - (let ((res (make-vector (max (- end start) 0) nil)) - (i 0)) - (while (< start end) - (aset res i (aref seq start)) - (setq i (1+ i) start (1+ start))) - res)))))) - -(defun concatenate (type &rest seqs) - "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." - (cond ((eq type 'vector) (apply 'vconcat seqs)) - ((eq type 'string) (apply 'concat seqs)) - ((eq type 'list) (apply 'append (append seqs '(nil)))) - (t (error "Not a sequence type name: %s" type)))) - - -;;; List functions. - -(defun revappend (x y) - "Equivalent to (append (reverse X) Y)." - (nconc (reverse x) y)) - -(defun nreconc (x y) - "Equivalent to (nconc (nreverse X) Y)." - (nconc (nreverse x) y)) - -(defun list-length (x) - "Return the length of a list. Return nil if list is circular." - (let ((n 0) (fast x) (slow x)) - (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) - (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) - (if fast (if (cdr fast) nil (1+ n)) n))) - -(defun tailp (sublist list) - "Return true if SUBLIST is a tail of LIST." - (while (and (consp list) (not (eq sublist list))) - (setq list (cdr list))) - (if (numberp sublist) (equal sublist list) (eq sublist list))) - -(defun cl-copy-tree (tree &optional vecp) - "Make a copy of TREE. -If TREE is a cons cell, this recursively copies both its car and its cdr. -Contrast to copy-sequence, which copies only along the cdrs. With second -argument VECP, this copies vectors as well as conses." - (if (consp tree) - (let ((p (setq tree (copy-list tree)))) - (while (consp p) - (if (or (consp (car p)) (and vecp (vectorp (car p)))) - (setcar p (cl-copy-tree (car p) vecp))) - (or (listp (cdr p)) (setcdr p (cl-copy-tree (cdr p) vecp))) - (cl-pop p))) - (if (and vecp (vectorp tree)) - (let ((i (length (setq tree (copy-sequence tree))))) - (while (>= (setq i (1- i)) 0) - (aset tree i (cl-copy-tree (aref tree i) vecp)))))) - tree) -(or (and (fboundp 'copy-tree) (subrp (symbol-function 'copy-tree))) - (defalias 'copy-tree 'cl-copy-tree)) - - -;;; Property lists. - -(defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el - "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none." - (or (get sym tag) - (and def - (let ((plist (symbol-plist sym))) - (while (and plist (not (eq (car plist) tag))) - (setq plist (cdr (cdr plist)))) - (if plist (car (cdr plist)) def))))) - -(defun getf (plist tag &optional def) - "Search PROPLIST for property PROPNAME; return its value or DEFAULT. -PROPLIST is a list of the sort returned by `symbol-plist'." - (setplist '--cl-getf-symbol-- plist) - (or (get '--cl-getf-symbol-- tag) - (and def (get* '--cl-getf-symbol-- tag def)))) - -(defun cl-set-getf (plist tag val) - (let ((p plist)) - (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) - (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) - -(defun cl-do-remf (plist tag) - (let ((p (cdr plist))) - (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) - (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) - -(defun cl-remprop (sym tag) - "Remove from SYMBOL's plist the property PROP and its value." - (let ((plist (symbol-plist sym))) - (if (and plist (eq tag (car plist))) - (progn (setplist sym (cdr (cdr plist))) t) - (cl-do-remf plist tag)))) -(or (and (fboundp 'remprop) (subrp (symbol-function 'remprop))) - (defalias 'remprop 'cl-remprop)) - - - -;;; Hash tables. - -(defun make-hash-table (&rest cl-keys) - "Make an empty Common Lisp-style hash-table. -If :test is `eq', this can use Lucid Emacs built-in hash-tables. -In non-Lucid Emacs, or with non-`eq' test, this internally uses a-lists. -Keywords supported: :test :size -The Common Lisp keywords :rehash-size and :rehash-threshold are ignored." - (let ((cl-test (or (car (cdr (memq ':test cl-keys))) 'eql)) - (cl-size (or (car (cdr (memq ':size cl-keys))) 20))) - (if (and (eq cl-test 'eq) (fboundp 'make-hashtable)) - (funcall 'make-hashtable cl-size) - (list 'cl-hash-table-tag cl-test - (if (> cl-size 1) (make-vector cl-size 0) - (let ((sym (make-symbol "--hashsym--"))) (set sym nil) sym)) - 0)))) - -(defvar cl-lucid-hash-tag - (if (and (fboundp 'make-hashtable) (vectorp (make-hashtable 1))) - (aref (make-hashtable 1) 0) (make-symbol "--cl-hash-tag--"))) - -(defun hash-table-p (x) - "Return t if OBJECT is a hash table." - (or (eq (car-safe x) 'cl-hash-table-tag) - (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag)) - (and (fboundp 'hashtablep) (funcall 'hashtablep x)))) - -(defun cl-not-hash-table (x &optional y &rest z) - (signal 'wrong-type-argument (list 'hash-table-p (or y x)))) - -(defun cl-hash-lookup (key table) - (or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table)) - (let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym) - (if (symbolp array) (setq str nil sym (symbol-value array)) - (while (or (consp str) (and (vectorp str) (> (length str) 0))) - (setq str (elt str 0))) - (cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str)))) - ((symbolp str) (setq str (symbol-name str))) - ((and (numberp str) (> str -8000000) (< str 8000000)) - (or (integerp str) (setq str (truncate str))) - (setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" - "11" "12" "13" "14" "15"] (logand str 15)))) - (t (setq str "*"))) - (setq sym (symbol-value (intern-soft str array)))) - (list (and sym (cond ((or (eq test 'eq) - (and (eq test 'eql) (not (numberp key)))) - (assq key sym)) - ((memq test '(eql equal)) (assoc key sym)) - (t (assoc* key sym ':test test)))) - sym str))) - -(defvar cl-builtin-gethash - (if (and (fboundp 'gethash) (subrp (symbol-function 'gethash))) - (symbol-function 'gethash) 'cl-not-hash-table)) -(defvar cl-builtin-remhash - (if (and (fboundp 'remhash) (subrp (symbol-function 'remhash))) - (symbol-function 'remhash) 'cl-not-hash-table)) -(defvar cl-builtin-clrhash - (if (and (fboundp 'clrhash) (subrp (symbol-function 'clrhash))) - (symbol-function 'clrhash) 'cl-not-hash-table)) -(defvar cl-builtin-maphash - (if (and (fboundp 'maphash) (subrp (symbol-function 'maphash))) - (symbol-function 'maphash) 'cl-not-hash-table)) - -(defun cl-gethash (key table &optional def) - "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT." - (if (consp table) - (let ((found (cl-hash-lookup key table))) - (if (car found) (cdr (car found)) def)) - (funcall cl-builtin-gethash key table def))) -(defalias 'gethash 'cl-gethash) - -(defun cl-puthash (key val table) - (if (consp table) - (let ((found (cl-hash-lookup key table))) - (if (car found) (setcdr (car found) val) - (if (nth 2 found) - (progn - (if (> (nth 3 table) (* (length (nth 2 table)) 3)) - (let ((new-table (make-vector (nth 3 table) 0))) - (mapatoms (function - (lambda (sym) - (set (intern (symbol-name sym) new-table) - (symbol-value sym)))) - (nth 2 table)) - (setcar (cdr (cdr table)) new-table))) - (set (intern (nth 2 found) (nth 2 table)) - (cons (cons key val) (nth 1 found)))) - (set (nth 2 table) (cons (cons key val) (nth 1 found)))) - (setcar (cdr (cdr (cdr table))) (1+ (nth 3 table))))) - (funcall 'puthash key val table)) val) - -(defun cl-remhash (key table) - "Remove KEY from HASH-TABLE." - (if (consp table) - (let ((found (cl-hash-lookup key table))) - (and (car found) - (let ((del (delq (car found) (nth 1 found)))) - (setcar (cdr (cdr (cdr table))) (1- (nth 3 table))) - (if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del) - (set (nth 2 table) del)) t))) - (prog1 (not (eq (funcall cl-builtin-gethash key table '--cl--) '--cl--)) - (funcall cl-builtin-remhash key table)))) -(defalias 'remhash 'cl-remhash) - -(defun cl-clrhash (table) - "Clear HASH-TABLE." - (if (consp table) - (progn - (or (hash-table-p table) (cl-not-hash-table table)) - (if (symbolp (nth 2 table)) (set (nth 2 table) nil) - (setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0))) - (setcar (cdr (cdr (cdr table))) 0)) - (funcall cl-builtin-clrhash table)) - nil) -(defalias 'clrhash 'cl-clrhash) - -(defun cl-maphash (cl-func cl-table) - "Call FUNCTION on keys and values from HASH-TABLE." - (or (hash-table-p cl-table) (cl-not-hash-table cl-table)) - (if (consp cl-table) - (mapatoms (function (lambda (cl-x) - (setq cl-x (symbol-value cl-x)) - (while cl-x - (funcall cl-func (car (car cl-x)) - (cdr (car cl-x))) - (setq cl-x (cdr cl-x))))) - (if (symbolp (nth 2 cl-table)) - (vector (nth 2 cl-table)) (nth 2 cl-table))) - (funcall cl-builtin-maphash cl-func cl-table))) -(defalias 'maphash 'cl-maphash) - -(defun hash-table-count (table) - "Return the number of entries in HASH-TABLE." - (or (hash-table-p table) (cl-not-hash-table table)) - (if (consp table) (nth 3 table) (funcall 'hashtable-fullness table))) - - -;;; Some debugging aids. - -(defun cl-prettyprint (form) - "Insert a pretty-printed rendition of a Lisp FORM in current buffer." - (let ((pt (point)) last) - (insert "\n" (prin1-to-string form) "\n") - (setq last (point)) - (goto-char (1+ pt)) - (while (search-forward "(quote " last t) - (delete-backward-char 7) - (insert "'") - (forward-sexp) - (delete-char 1)) - (goto-char (1+ pt)) - (cl-do-prettyprint))) - -(defun cl-do-prettyprint () - (skip-chars-forward " ") - (if (looking-at "(") - (let ((skip (or (looking-at "((") (looking-at "(prog") - (looking-at "(unwind-protect ") - (looking-at "(function (") - (looking-at "(cl-block-wrapper "))) - (two (or (looking-at "(defun ") (looking-at "(defmacro "))) - (let (or (looking-at "(let\\*? ") (looking-at "(while "))) - (set (looking-at "(p?set[qf] "))) - (if (or skip let - (progn - (forward-sexp) - (and (>= (current-column) 78) (progn (backward-sexp) t)))) - (let ((nl t)) - (forward-char 1) - (cl-do-prettyprint) - (or skip (looking-at ")") (cl-do-prettyprint)) - (or (not two) (looking-at ")") (cl-do-prettyprint)) - (while (not (looking-at ")")) - (if set (setq nl (not nl))) - (if nl (insert "\n")) - (lisp-indent-line) - (cl-do-prettyprint)) - (forward-char 1)))) - (forward-sexp))) - -(defvar cl-macroexpand-cmacs nil) -(defvar cl-closure-vars nil) - -(defun cl-macroexpand-all (form &optional env) - "Expand all macro calls through a Lisp FORM. -This also does some trivial optimizations to make the form prettier." - (while (or (not (eq form (setq form (macroexpand form env)))) - (and cl-macroexpand-cmacs - (not (eq form (setq form (compiler-macroexpand form))))))) - (cond ((not (consp form)) form) - ((memq (car form) '(let let*)) - (if (null (nth 1 form)) - (cl-macroexpand-all (cons 'progn (cddr form)) env) - (let ((letf nil) (res nil) (lets (cadr form))) - (while lets - (cl-push (if (consp (car lets)) - (let ((exp (cl-macroexpand-all (caar lets) env))) - (or (symbolp exp) (setq letf t)) - (cons exp (cl-macroexpand-body (cdar lets) env))) - (let ((exp (cl-macroexpand-all (car lets) env))) - (if (symbolp exp) exp - (setq letf t) (list exp nil)))) res) - (setq lets (cdr lets))) - (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form)) - (nreverse res) (cl-macroexpand-body (cddr form) env))))) - ((eq (car form) 'cond) - (cons (car form) - (mapcar (function (lambda (x) (cl-macroexpand-body x env))) - (cdr form)))) - ((eq (car form) 'condition-case) - (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) - (mapcar (function - (lambda (x) - (cons (car x) (cl-macroexpand-body (cdr x) env)))) - (cdddr form)))) - ((memq (car form) '(quote function)) - (if (eq (car-safe (nth 1 form)) 'lambda) - (let ((body (cl-macroexpand-body (cddadr form) env))) - (if (and cl-closure-vars (eq (car form) 'function) - (cl-expr-contains-any body cl-closure-vars)) - (let* ((new (mapcar 'gensym cl-closure-vars)) - (sub (pairlis cl-closure-vars new)) (decls nil)) - (while (or (stringp (car body)) - (eq (car-safe (car body)) 'interactive)) - (cl-push (list 'quote (cl-pop body)) decls)) - (put (car (last cl-closure-vars)) 'used t) - (append - (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) - (sublis sub (nreverse decls)) - (list - (list* 'list '(quote apply) - (list 'list '(quote quote) - (list 'function - (list* 'lambda - (append new (cadadr form)) - (sublis sub body)))) - (nconc (mapcar (function - (lambda (x) - (list 'list '(quote quote) x))) - cl-closure-vars) - '((quote --cl-rest--))))))) - (list (car form) (list* 'lambda (cadadr form) body)))) - (let ((found (assq (cadr form) env))) - (if (eq (cadr (caddr found)) 'cl-labels-args) - (cl-macroexpand-all (cadr (caddr (cadddr found))) env) - form)))) - ((memq (car form) '(defun defmacro)) - (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) - ((and (eq (car form) 'progn) (not (cddr form))) - (cl-macroexpand-all (nth 1 form) env)) - ((eq (car form) 'setq) - (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) - (while (and p (symbolp (car p))) (setq p (cddr p))) - (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) - (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) - -(defun cl-macroexpand-body (body &optional env) - (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) - -(defun cl-prettyexpand (form &optional full) - (message "Expanding...") - (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) - (byte-compile-macro-environment nil)) - (setq form (cl-macroexpand-all form - (and (not full) '((block) (eval-when))))) - (message "Formatting...") - (prog1 (cl-prettyprint form) - (message "")))) - - - -(run-hooks 'cl-extra-load-hook) - -;;; cl-extra.el ends here diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el deleted file mode 100644 index 8d199c14452..00000000000 --- a/lisp/emacs-lisp/cl-indent.el +++ /dev/null @@ -1,474 +0,0 @@ -;;; cl-indent.el --- enhanced lisp-indent mode - -;; Copyright (C) 1987 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik <mly@eddie.mit.edu> -;; Created: July 1987 -;; Maintainer: FSF -;; Keywords: lisp, tools - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package supplies a single entry point, common-lisp-indent-function, -;; which performs indentation in the preferred style for Common Lisp code. -;; To enable it: -;; -;; (setq lisp-indent-function 'common-lisp-indent-function) - -;;>> TODO -;; :foo -;; bar -;; :baz -;; zap -;; &key (like &body)?? - -;; &rest 1 in lambda-lists doesn't work -;; -- really want (foo bar -;; baz) -;; not (foo bar -;; baz) -;; Need something better than &rest for such cases - -;;; Code: - -(defvar lisp-indent-maximum-backtracking 3 - "*Maximum depth to backtrack out from a sublist for structured indentation. -If this variable is 0, no backtracking will occur and forms such as flet -may not be correctly indented.") - -(defvar lisp-tag-indentation 1 - "*Indentation of tags relative to containing list. -This variable is used by the function `lisp-indent-tagbody'.") - -(defvar lisp-tag-body-indentation 3 - "*Indentation of non-tagged lines relative to containing list. -This variable is used by the function `lisp-indent-tagbody' to indent normal -lines (lines without tags). -The indentation is relative to the indentation of the parenthesis enclosing -the special form. If the value is t, the body of tags will be indented -as a block at the same indentation as the first s-expression following -the tag. In this case, any forms before the first tag are indented -by `lisp-body-indent'.") - - -;;;###autoload -(defun common-lisp-indent-function (indent-point state) - (let ((normal-indent (current-column))) - ;; Walk up list levels until we see something - ;; which does special things with subforms. - (let ((depth 0) - ;; Path describes the position of point in terms of - ;; list-structure with respect to containing lists. - ;; `foo' has a path of (0 4 1) in `((a b c (d foo) f) g)' - (path ()) - ;; set non-nil when somebody works out the indentation to use - calculated - (last-point indent-point) - ;; the position of the open-paren of the innermost containing list - (containing-form-start (elt state 1)) - ;; the column of the above - sexp-column) - ;; Move to start of innermost containing list - (goto-char containing-form-start) - (setq sexp-column (current-column)) - ;; Look over successively less-deep containing forms - (while (and (not calculated) - (< depth lisp-indent-maximum-backtracking)) - (let ((containing-sexp (point))) - (forward-char 1) - (parse-partial-sexp (point) indent-point 1 t) - ;; Move to the car of the relevant containing form - (let (tem function method) - (if (not (looking-at "\\sw\\|\\s_")) - ;; This form doesn't seem to start with a symbol - (setq function nil method nil) - (setq tem (point)) - (forward-sexp 1) - (setq function (downcase (buffer-substring tem (point)))) - (goto-char tem) - (setq tem (intern-soft function) - method (get tem 'common-lisp-indent-function)) - (cond ((and (null method) - (string-match ":[^:]+" function)) - ;; The pleblisp package feature - (setq function (substring function - (1+ (match-beginning 0))) - method (get (intern-soft function) - 'common-lisp-indent-function))) - ((and (null method)) - ;; backwards compatibility - (setq method (get tem 'lisp-indent-function))))) - (let ((n 0)) - ;; How far into the containing form is the current form? - (if (< (point) indent-point) - (while (condition-case () - (progn - (forward-sexp 1) - (if (>= (point) indent-point) - nil - (parse-partial-sexp (point) - indent-point 1 t) - (setq n (1+ n)) - t)) - (error nil)))) - (setq path (cons n path))) - - ;; backwards compatibility. - (cond ((null function)) - ((null method) - (if (null (cdr path)) - ;; (package prefix was stripped off above) - (setq method (cond ((string-match "\\`def" - function) - '(4 (&whole 4 &rest 1) &body)) - ((string-match "\\`\\(with\\|do\\)-" - function) - '(4 &body)))))) - ;; backwards compatibility. Bletch. - ((eq method 'defun) - (setq method '(4 (&whole 4 &rest 1) &body)))) - - (cond ((and (memq (char-after (1- containing-sexp)) '(?\' ?\`)) - (not (eql (char-after (- containing-sexp 2)) ?\#))) - ;; No indentation for "'(...)" elements - (setq calculated (1+ sexp-column))) - ((or (eql (char-after (1- containing-sexp)) ?\,) - (and (eql (char-after (1- containing-sexp)) ?\@) - (eql (char-after (- containing-sexp 2)) ?\,))) - ;; ",(...)" or ",@(...)" - (setq calculated normal-indent)) - ((eql (char-after (1- containing-sexp)) ?\#) - ;; "#(...)" - (setq calculated (1+ sexp-column))) - ((null method)) - ((integerp method) - ;; convenient top-level hack. - ;; (also compatible with lisp-indent-function) - ;; The number specifies how many `distinguished' - ;; forms there are before the body starts - ;; Equivalent to (4 4 ... &body) - (setq calculated (cond ((cdr path) - normal-indent) - ((<= (car path) method) - ;; `distinguished' form - (list (+ sexp-column 4) - containing-form-start)) - ((= (car path) (1+ method)) - ;; first body form. - (+ sexp-column lisp-body-indent)) - (t - ;; other body form - normal-indent)))) - ((symbolp method) - (setq calculated (funcall method - path state indent-point - sexp-column normal-indent))) - (t - (setq calculated (lisp-indent-259 - method path state indent-point - sexp-column normal-indent))))) - (goto-char containing-sexp) - (setq last-point containing-sexp) - (if (not calculated) - (condition-case () - (progn (backward-up-list 1) - (setq depth (1+ depth))) - (error (setq depth lisp-indent-maximum-backtracking)))))) - calculated))) - - -(defun lisp-indent-report-bad-format (m) - (error "%s has a badly-formed %s property: %s" - ;; Love those free variable references!! - function 'common-lisp-indent-function m)) - -;; Blame the crufty control structure on dynamic scoping -;; -- not on me! -(defun lisp-indent-259 (method path state indent-point - sexp-column normal-indent) - (catch 'exit - (let ((p path) - (containing-form-start (elt state 1)) - n tem tail) - ;; Isn't tail-recursion wonderful? - (while p - ;; This while loop is for destructuring. - ;; p is set to (cdr p) each iteration. - (if (not (consp method)) (lisp-indent-report-bad-format method)) - (setq n (1- (car p)) - p (cdr p) - tail nil) - (while n - ;; This while loop is for advancing along a method - ;; until the relevant (possibly &rest/&body) pattern - ;; is reached. - ;; n is set to (1- n) and method to (cdr method) - ;; each iteration. - (setq tem (car method)) - - (or (eq tem 'nil) ;default indentation -; (eq tem '&lambda) ;abbrev for (&whole 4 (&rest 1)) - (and (eq tem '&body) (null (cdr method))) - (and (eq tem '&rest) - (consp (cdr method)) (null (cdr (cdr method)))) - (integerp tem) ;explicit indentation specified - (and (consp tem) ;destructuring - (eq (car tem) '&whole) - (or (symbolp (car (cdr tem))) - (integerp (car (cdr tem))))) - (and (symbolp tem) ;a function to call to do the work. - (null (cdr method))) - (lisp-indent-report-bad-format method)) - - (cond ((and tail (not (consp tem))) - ;; indent tail of &rest in same way as first elt of rest - (throw 'exit normal-indent)) - ((eq tem '&body) - ;; &body means (&rest <lisp-body-indent>) - (throw 'exit - (if (and (= n 0) ;first body form - (null p)) ;not in subforms - (+ sexp-column - lisp-body-indent) - normal-indent))) - ((eq tem '&rest) - ;; this pattern holds for all remaining forms - (setq tail (> n 0) - n 0 - method (cdr method))) - ((> n 0) - ;; try next element of pattern - (setq n (1- n) - method (cdr method)) - (if (< n 0) - ;; Too few elements in pattern. - (throw 'exit normal-indent))) - ((eq tem 'nil) - (throw 'exit (list normal-indent containing-form-start))) -; ((eq tem '&lambda) -; ;; abbrev for (&whole 4 &rest 1) -; (throw 'exit -; (cond ((null p) -; (list (+ sexp-column 4) containing-form-start)) -; ((null (cdr p)) -; (+ sexp-column 1)) -; (t normal-indent)))) - ((integerp tem) - (throw 'exit - (if (null p) ;not in subforms - (list (+ sexp-column tem) containing-form-start) - normal-indent))) - ((symbolp tem) ;a function to call - (throw 'exit - (funcall tem path state indent-point - sexp-column normal-indent))) - (t - ;; must be a destructing frob - (if (not (null p)) - ;; descend - (setq method (cdr (cdr tem)) - n nil) - (setq tem (car (cdr tem))) - (throw 'exit - (cond (tail - normal-indent) - ((eq tem 'nil) - (list normal-indent - containing-form-start)) - ((integerp tem) - (list (+ sexp-column tem) - containing-form-start)) - (t - (funcall tem path state indent-point - sexp-column normal-indent)))))))))))) - -(defun lisp-indent-tagbody (path state indent-point sexp-column normal-indent) - (if (not (null (cdr path))) - normal-indent - (save-excursion - (goto-char indent-point) - (beginning-of-line) - (skip-chars-forward " \t") - (list (cond ((looking-at "\\sw\\|\\s_") - ;; a tagbody tag - (+ sexp-column lisp-tag-indentation)) - ((integerp lisp-tag-body-indentation) - (+ sexp-column lisp-tag-body-indentation)) - ((eq lisp-tag-body-indentation 't) - (condition-case () - (progn (backward-sexp 1) (current-column)) - (error (1+ sexp-column)))) - (t (+ sexp-column lisp-body-indent))) -; (cond ((integerp lisp-tag-body-indentation) -; (+ sexp-column lisp-tag-body-indentation)) -; ((eq lisp-tag-body-indentation 't) -; normal-indent) -; (t -; (+ sexp-column lisp-body-indent))) - (elt state 1) - )))) - -(defun lisp-indent-do (path state indent-point sexp-column normal-indent) - (if (>= (car path) 3) - (let ((lisp-tag-body-indentation lisp-body-indent)) - (funcall (function lisp-indent-tagbody) - path state indent-point sexp-column normal-indent)) - (funcall (function lisp-indent-259) - '((&whole nil &rest - ;; the following causes weird indentation - ;;(&whole 1 1 2 nil) - ) - (&whole nil &rest 1)) - path state indent-point sexp-column normal-indent))) - -(defun lisp-indent-function-lambda-hack (path state indent-point - sexp-column normal-indent) - ;; indent (function (lambda () <newline> <body-forms>)) kludgily. - (if (or (cdr path) ; wtf? - (> (car path) 3)) - ;; line up under previous body form - normal-indent - ;; line up under function rather than under lambda in order to - ;; conserve horizontal space. (Which is what #' is for.) - (condition-case () - (save-excursion - (backward-up-list 2) - (forward-char 1) - (if (looking-at "\\(lisp:+\\)?function\\(\\Sw\\|\\S_\\)") - (+ lisp-body-indent -1 (current-column)) - (+ sexp-column lisp-body-indent))) - (error (+ sexp-column lisp-body-indent))))) - - -(let ((l '((block 1) - (catch 1) - (case (4 &rest (&whole 2 &rest 1))) - (ccase . case) (ecase . case) - (typecase . case) (etypecase . case) (ctypecase . case) - (catch 1) - (cond (&rest (&whole 2 &rest 1))) - (block 1) - (defvar (4 2 2)) - (defconstant . defvar) (defparameter . defvar) - (define-modify-macro - (4 &body)) - (define-setf-method - (4 (&whole 4 &rest 1) &body)) - (defsetf (4 (&whole 4 &rest 1) 4 &body)) - (defun (4 (&whole 4 &rest 1) &body)) - (defmacro . defun) (deftype . defun) - (defstruct ((&whole 4 &rest (&whole 2 &rest 1)) - &rest (&whole 2 &rest 1))) - (destructuring-bind - ((&whole 6 &rest 1) 4 &body)) - (do lisp-indent-do) - (do* . do) - (dolist ((&whole 4 2 1) &body)) - (dotimes . dolist) - (eval-when 1) - (flet ((&whole 4 &rest (&whole 1 (&whole 4 &rest 1) &body)) - &body)) - (labels . flet) - (macrolet . flet) - ;; `else-body' style - (if (nil nil &body)) - ;; single-else style (then and else equally indented) - (if (&rest nil)) - ;(lambda ((&whole 4 &rest 1) &body)) - (lambda ((&whole 4 &rest 1) - &rest lisp-indent-function-lambda-hack)) - (let ((&whole 4 &rest (&whole 1 1 2)) &body)) - (let* . let) - (compiler-let . let) ;barf - (locally 1) - ;(loop ...) - (multiple-value-bind - ((&whole 6 &rest 1) 4 &body)) - (multiple-value-call - (4 &body)) - (multiple-value-list 1) - (multiple-value-prog1 1) - (multiple-value-setq - (4 2)) - ;; Combines the worst features of BLOCK, LET and TAGBODY - (prog ((&whole 4 &rest 1) &rest lisp-indent-tagbody)) - (prog* . prog) - (prog1 1) - (prog2 2) - (progn 0) - (progv (4 4 &body)) - (return 0) - (return-from (nil &body)) - (tagbody lisp-indent-tagbody) - (throw 1) - (unless 1) - (unwind-protect - (5 &body)) - (when 1)))) - (while l - (put (car (car l)) 'common-lisp-indent-function - (if (symbolp (cdr (car l))) - (get (cdr (car l)) 'common-lisp-indent-function) - (car (cdr (car l))))) - (setq l (cdr l)))) - - -;(defun foo (x) -; (tagbody -; foo -; (bar) -; baz -; (when (losing) -; (with-big-loser -; (yow) -; ((lambda () -; foo) -; big))) -; (flet ((foo (bar baz zap) -; (zip)) -; (zot () -; quux)) -; (do () -; ((lose) -; (foo 1)) -; (quux) -; foo -; (lose)) -; (cond ((x) -; (win 1 2 -; (foo))) -; (t -; (lose -; 3)))))) - - -;(put 'while 'common-lisp-indent-function 1) -;(put 'defwrapper'common-lisp-indent-function ...) -;(put 'def 'common-lisp-indent-function ...) -;(put 'defflavor 'common-lisp-indent-function ...) -;(put 'defsubst 'common-lisp-indent-function ...) - -;(put 'with-restart 'common-lisp-indent-function '((1 4 ((* 1))) (2 &body))) -;(put 'restart-case 'common-lisp-indent-function '((1 4) (* 2 ((0 1) (* 1))))) -;(put 'define-condition 'common-lisp-indent-function '((1 6) (2 6 ((* 1))) (3 4 ((* 1))) (4 &body))) -;(put 'with-condition-handler 'common-lisp-indent-function '((1 4 ((* 1))) (2 &body))) -;(put 'condition-case 'common-lisp-indent-function '((1 4) (* 2 ((0 1) (1 3) (2 &body))))) - -;;; cl-indent.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el deleted file mode 100644 index 37d02b564cb..00000000000 --- a/lisp/emacs-lisp/cl-macs.el +++ /dev/null @@ -1,2635 +0,0 @@ -;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*- - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains the portions of the Common Lisp extensions -;; package which should be autoloaded, but need only be present -;; if the compiler or interpreter is used---this file is not -;; necessary for executing compiled code. - -;; See cl.el for Change Log. - - -;;; Code: - -(or (memq 'cl-19 features) - (error "Tried to load `cl-macs' before `cl'!")) - - -;;; We define these here so that this file can compile without having -;;; loaded the cl.el file already. - -(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) -(defmacro cl-pop (place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) -(defmacro cl-pop2 (place) - (list 'prog1 (list 'car (list 'cdr place)) - (list 'setq place (list 'cdr (list 'cdr place))))) -(put 'cl-push 'edebug-form-spec 'edebug-sexps) -(put 'cl-pop 'edebug-form-spec 'edebug-sexps) -(put 'cl-pop2 'edebug-form-spec 'edebug-sexps) - -(defvar cl-emacs-type) -(defvar cl-optimize-safety) -(defvar cl-optimize-speed) - - -;;; This kludge allows macros which use cl-transform-function-property -;;; to be called at compile-time. - -(require - (progn - (or (fboundp 'defalias) (fset 'defalias 'fset)) - (or (fboundp 'cl-transform-function-property) - (defalias 'cl-transform-function-property - (function (lambda (n p f) - (list 'put (list 'quote n) (list 'quote p) - (list 'function (cons 'lambda f))))))) - (car (or features (setq features (list 'cl-kludge)))))) - - -;;; Initialization. - -(defvar cl-old-bc-file-form nil) - -;; Patch broken Emacs 18 compiler (re top-level macros). -;; Emacs 19 compiler doesn't need this patch. -;; Also, undo broken definition of `eql' that uses same bytecode as `eq'. -(defun cl-compile-time-init () - (setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form)) - (or (fboundp 'byte-compile-flush-pending) ; Emacs 19 compiler? - (defalias 'byte-compile-file-form - (function - (lambda (form) - (setq form (macroexpand form byte-compile-macro-environment)) - (if (eq (car-safe form) 'progn) - (cons 'progn (mapcar 'byte-compile-file-form (cdr form))) - (funcall cl-old-bc-file-form form)))))) - (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro) - (run-hooks 'cl-hack-bytecomp-hook)) - - -;;; Symbols. - -(defvar *gensym-counter*) -(defun gensym (&optional arg) - "Generate a new uninterned symbol. -The name is made by appending a number to PREFIX, default \"G\"." - (let ((prefix (if (stringp arg) arg "G")) - (num (if (integerp arg) arg - (prog1 *gensym-counter* - (setq *gensym-counter* (1+ *gensym-counter*)))))) - (make-symbol (format "%s%d" prefix num)))) - -(defun gentemp (&optional arg) - "Generate a new interned symbol with a unique name. -The name is made by appending a number to PREFIX, default \"G\"." - (let ((prefix (if (stringp arg) arg "G")) - name) - (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*))) - (setq *gensym-counter* (1+ *gensym-counter*))) - (intern name))) - - -;;; Program structure. - -(defmacro defun* (name args &rest body) - "(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. -Like normal `defun', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...)." - (let* ((res (cl-transform-lambda (cons args body) name)) - (form (list* 'defun name (cdr res)))) - (if (car res) (list 'progn (car res) form) form))) - -(defmacro defmacro* (name args &rest body) - "(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro. -Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...)." - (let* ((res (cl-transform-lambda (cons args body) name)) - (form (list* 'defmacro name (cdr res)))) - (if (car res) (list 'progn (car res) form) form))) - -(defmacro function* (func) - "(function* SYMBOL-OR-LAMBDA): introduce a function. -Like normal `function', except that if argument is a lambda form, its -ARGLIST allows full Common Lisp conventions." - (if (eq (car-safe func) 'lambda) - (let* ((res (cl-transform-lambda (cdr func) 'cl-none)) - (form (list 'function (cons 'lambda (cdr res))))) - (if (car res) (list 'progn (car res) form) form)) - (list 'function func))) - -(defun cl-transform-function-property (func prop form) - (let ((res (cl-transform-lambda form func))) - (append '(progn) (cdr (cdr (car res))) - (list (list 'put (list 'quote func) (list 'quote prop) - (list 'function (cons 'lambda (cdr res)))))))) - -(defconst lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) - -(defvar cl-macro-environment nil) -(defvar bind-block) (defvar bind-defs) (defvar bind-enquote) -(defvar bind-inits) (defvar bind-lets) (defvar bind-forms) - -(defun cl-transform-lambda (form bind-block) - (let* ((args (car form)) (body (cdr form)) - (bind-defs nil) (bind-enquote nil) - (bind-inits nil) (bind-lets nil) (bind-forms nil) - (header nil) (simple-args nil)) - (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) - (cl-push (cl-pop body) header)) - (setq args (if (listp args) (copy-list args) (list '&rest args))) - (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq bind-defs args)) - bind-defs (cadr bind-defs))) - (if (setq bind-enquote (memq '&cl-quote args)) - (setq args (delq '&cl-quote args))) - (if (memq '&whole args) (error "&whole not currently implemented")) - (let* ((p (memq '&environment args)) (v (cadr p))) - (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v 'cl-macro-environment)))))) - (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or bind-defs (consp (cadr args)))))) - (cl-push (cl-pop args) simple-args)) - (or (eq bind-block 'cl-none) - (setq body (list (list* 'block bind-block body)))) - (if (null args) - (list* nil (nreverse simple-args) (nconc (nreverse header) body)) - (if (memq '&optional simple-args) (cl-push '&optional args)) - (cl-do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) - (setq bind-lets (nreverse bind-lets)) - (list* (and bind-inits (list* 'eval-when '(compile load eval) - (nreverse bind-inits))) - (nconc (nreverse simple-args) - (list '&rest (car (cl-pop bind-lets)))) - (nconc (nreverse header) - (list (nconc (list 'let* bind-lets) - (nreverse bind-forms) body))))))) - -(defun cl-do-arglist (args expr &optional num) ; uses bind-* - (if (nlistp args) - (if (or (memq args lambda-list-keywords) (not (symbolp args))) - (error "Invalid argument name: %s" args) - (cl-push (list args expr) bind-lets)) - (setq args (copy-list args)) - (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (let ((p (memq '&body args))) (if p (setcar p '&rest))) - (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)) - (keys nil) - (laterarg nil) (exactarg nil) minarg) - (or num (setq num 0)) - (if (listp (cadr restarg)) - (setq restarg (gensym "--rest--")) - (setq restarg (cadr restarg))) - (cl-push (list restarg expr) bind-lets) - (if (eq (car args) '&whole) - (cl-push (list (cl-pop2 args) restarg) bind-lets)) - (let ((p args)) - (setq minarg restarg) - (while (and p (not (memq (car p) lambda-list-keywords))) - (or (eq p args) (setq minarg (list 'cdr minarg))) - (setq p (cdr p))) - (if (memq (car p) '(nil &aux)) - (setq minarg (list '= (list 'length restarg) - (length (ldiff args p))) - exactarg (not (eq args p))))) - (while (and args (not (memq (car args) lambda-list-keywords))) - (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) - restarg))) - (cl-do-arglist - (cl-pop args) - (if (or laterarg (= safety 0)) poparg - (list 'if minarg poparg - (list 'signal '(quote wrong-number-of-arguments) - (list 'list (and (not (eq bind-block 'cl-none)) - (list 'quote bind-block)) - (list 'length restarg))))))) - (setq num (1+ num) laterarg t)) - (while (and (eq (car args) '&optional) (cl-pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) - (let ((arg (cl-pop args))) - (or (consp arg) (setq arg (list arg))) - (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t))) - (let ((def (if (cdr arg) (nth 1 arg) - (or (car bind-defs) - (nth 1 (assq (car arg) bind-defs))))) - (poparg (list 'pop restarg))) - (and def bind-enquote (setq def (list 'quote def))) - (cl-do-arglist (car arg) - (if def (list 'if restarg poparg def) poparg)) - (setq num (1+ num)))))) - (if (eq (car args) '&rest) - (let ((arg (cl-pop2 args))) - (if (consp arg) (cl-do-arglist arg restarg))) - (or (eq (car args) '&key) (= safety 0) exactarg - (cl-push (list 'if restarg - (list 'signal '(quote wrong-number-of-arguments) - (list 'list - (and (not (eq bind-block 'cl-none)) - (list 'quote bind-block)) - (list '+ num (list 'length restarg))))) - bind-forms))) - (while (and (eq (car args) '&key) (cl-pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) - (let ((arg (cl-pop args))) - (or (consp arg) (setq arg (list arg))) - (let* ((karg (if (consp (car arg)) (caar arg) - (intern (format ":%s" (car arg))))) - (varg (if (consp (car arg)) (cadar arg) (car arg))) - (def (if (cdr arg) (cadr arg) - (or (car bind-defs) (cadr (assq varg bind-defs))))) - (look (list 'memq (list 'quote karg) restarg))) - (and def bind-enquote (setq def (list 'quote def))) - (if (cddr arg) - (let* ((temp (or (nth 2 arg) (gensym))) - (val (list 'car (list 'cdr temp)))) - (cl-do-arglist temp look) - (cl-do-arglist varg - (list 'if temp - (list 'prog1 val (list 'setq temp t)) - def))) - (cl-do-arglist - varg - (list 'car - (list 'cdr - (if (null def) - look - (list 'or look - (if (eq (cl-const-expr-p def) t) - (list - 'quote - (list nil (cl-const-expr-val def))) - (list 'list nil def)))))))) - (cl-push karg keys) - (if (= (aref (symbol-name karg) 0) ?:) - (progn (set karg karg) - (cl-push (list 'setq karg (list 'quote karg)) - bind-inits))))))) - (setq keys (nreverse keys)) - (or (and (eq (car args) '&allow-other-keys) (cl-pop args)) - (null keys) (= safety 0) - (let* ((var (gensym "--keys--")) - (allow '(:allow-other-keys)) - (check (list - 'while var - (list - 'cond - (list (list 'memq (list 'car var) - (list 'quote (append keys allow))) - (list 'setq var (list 'cdr (list 'cdr var)))) - (list (list 'car - (list 'cdr - (list 'memq (cons 'quote allow) - restarg))) - (list 'setq var nil)) - (list t - (list - 'error - (format "Keyword argument %%s not one of %s" - keys) - (list 'car var))))))) - (cl-push (list 'let (list (list var restarg)) check) bind-forms))) - (while (and (eq (car args) '&aux) (cl-pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) - (if (consp (car args)) - (if (and bind-enquote (cadar args)) - (cl-do-arglist (caar args) - (list 'quote (cadr (cl-pop args)))) - (cl-do-arglist (caar args) (cadr (cl-pop args)))) - (cl-do-arglist (cl-pop args) nil)))) - (if args (error "Malformed argument list %s" save-args))))) - -(defun cl-arglist-args (args) - (if (nlistp args) (list args) - (let ((res nil) (kind nil) arg) - (while (consp args) - (setq arg (cl-pop args)) - (if (memq arg lambda-list-keywords) (setq kind arg) - (if (eq arg '&cl-defs) (cl-pop args) - (and (consp arg) kind (setq arg (car arg))) - (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) - (setq res (nconc res (cl-arglist-args arg)))))) - (nconc res (and args (list args)))))) - -(defmacro destructuring-bind (args expr &rest body) - (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) - (bind-defs nil) (bind-block 'cl-none)) - (cl-do-arglist (or args '(&aux)) expr) - (append '(progn) bind-inits - (list (nconc (list 'let* (nreverse bind-lets)) - (nreverse bind-forms) body))))) - - -;;; The `eval-when' form. - -(defvar cl-not-toplevel nil) - -(defmacro eval-when (when &rest body) - "(eval-when (WHEN...) BODY...): control when BODY is evaluated. -If `compile' is in WHEN, BODY is evaluated when compiled at top-level. -If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. -If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level." - (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) - (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge - (let ((comp (or (memq 'compile when) (memq ':compile-toplevel when))) - (cl-not-toplevel t)) - (if (or (memq 'load when) (memq ':load-toplevel when)) - (if comp (cons 'progn (mapcar 'cl-compile-time-too body)) - (list* 'if nil nil body)) - (progn (if comp (eval (cons 'progn body))) nil))) - (and (or (memq 'eval when) (memq ':execute when)) - (cons 'progn body)))) - -(defun cl-compile-time-too (form) - (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) - (setq form (macroexpand - form (cons '(eval-when) byte-compile-macro-environment)))) - (cond ((eq (car-safe form) 'progn) - (cons 'progn (mapcar 'cl-compile-time-too (cdr form)))) - ((eq (car-safe form) 'eval-when) - (let ((when (nth 1 form))) - (if (or (memq 'eval when) (memq ':execute when)) - (list* 'eval-when (cons 'compile when) (cddr form)) - form))) - (t (eval form) form))) - -(or (and (fboundp 'eval-when-compile) - (not (eq (car-safe (symbol-function 'eval-when-compile)) 'autoload))) - (eval '(defmacro eval-when-compile (&rest body) - "Like `progn', but evaluates the body at compile time. -The result of the body appears to the compiler as a quoted constant." - (list 'quote (eval (cons 'progn body)))))) - -(defmacro load-time-value (form &optional read-only) - "Like `progn', but evaluates the body at load time. -The result of the body appears to the compiler as a quoted constant." - (if (cl-compiling-file) - (let* ((temp (gentemp "--cl-load-time--")) - (set (list 'set (list 'quote temp) form))) - (if (and (fboundp 'byte-compile-file-form-defmumble) - (boundp 'this-kind) (boundp 'that-one)) - (fset 'byte-compile-file-form - (list 'lambda '(form) - (list 'fset '(quote byte-compile-file-form) - (list 'quote - (symbol-function 'byte-compile-file-form))) - (list 'byte-compile-file-form (list 'quote set)) - '(byte-compile-file-form form))) - (print set (symbol-value 'outbuffer))) - (list 'symbol-value (list 'quote temp))) - (list 'quote (eval form)))) - - -;;; Conditional control structures. - -(defmacro case (expr &rest clauses) - "(case EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. -Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared -against each key in each KEYLIST; the corresponding BODY is evaluated. -If no clause succeeds, case returns nil. A single atom may be used in -place of a KEYLIST of one atom. A KEYLIST of `t' or `otherwise' is -allowed only in the final clause, and matches if no other keys match. -Key values are compared by `eql'." - (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) - (head-list nil) - (body (cons - 'cond - (mapcar - (function - (lambda (c) - (cons (cond ((memq (car c) '(t otherwise)) t) - ((eq (car c) 'ecase-error-flag) - (list 'error "ecase failed: %s, %s" - temp (list 'quote (reverse head-list)))) - ((listp (car c)) - (setq head-list (append (car c) head-list)) - (list 'member* temp (list 'quote (car c)))) - (t - (if (memq (car c) head-list) - (error "Duplicate key in case: %s" - (car c))) - (cl-push (car c) head-list) - (list 'eql temp (list 'quote (car c))))) - (or (cdr c) '(nil))))) - clauses)))) - (if (eq temp expr) body - (list 'let (list (list temp expr)) body)))) - -(defmacro ecase (expr &rest clauses) - "(ecase EXPR CLAUSES...): like `case', but error if no case fits. -`otherwise'-clauses are not allowed." - (list* 'case expr (append clauses '((ecase-error-flag))))) - -(defmacro typecase (expr &rest clauses) - "(typecase EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. -Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it -satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, -typecase returns nil. A TYPE of `t' or `otherwise' is allowed only in the -final clause, and matches if no other keys match." - (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) - (type-list nil) - (body (cons - 'cond - (mapcar - (function - (lambda (c) - (cons (cond ((eq (car c) 'otherwise) t) - ((eq (car c) 'ecase-error-flag) - (list 'error "etypecase failed: %s, %s" - temp (list 'quote (reverse type-list)))) - (t - (cl-push (car c) type-list) - (cl-make-type-test temp (car c)))) - (or (cdr c) '(nil))))) - clauses)))) - (if (eq temp expr) body - (list 'let (list (list temp expr)) body)))) - -(defmacro etypecase (expr &rest clauses) - "(etypecase EXPR CLAUSES...): like `typecase', but error if no case fits. -`otherwise'-clauses are not allowed." - (list* 'typecase expr (append clauses '((ecase-error-flag))))) - - -;;; Blocks and exits. - -(defmacro block (name &rest body) - "(block NAME BODY...): define a lexically-scoped block named NAME. -NAME may be any symbol. Code inside the BODY forms can call `return-from' -to jump prematurely out of the block. This differs from `catch' and `throw' -in two respects: First, the NAME is an unevaluated symbol rather than a -quoted symbol or other form; and second, NAME is lexically rather than -dynamically scoped: Only references to it within BODY will work. These -references may appear inside macro expansions, but not inside functions -called from BODY." - (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body) - (list 'cl-block-wrapper - (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) - body)))) - -(defvar cl-active-block-names nil) - -(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) -(defun cl-byte-compile-block (cl-form) - (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler - (progn - (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) - (cl-active-block-names (cons cl-entry cl-active-block-names)) - (cl-body (byte-compile-top-level - (cons 'progn (cddr (nth 1 cl-form)))))) - (if (cdr cl-entry) - (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body)) - (byte-compile-form cl-body)))) - (byte-compile-form (nth 1 cl-form)))) - -(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw) -(defun cl-byte-compile-throw (cl-form) - (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) - (if cl-found (setcdr cl-found t))) - (byte-compile-normal-call (cons 'throw (cdr cl-form)))) - -(defmacro return (&optional res) - "(return [RESULT]): return from the block named nil. -This is equivalent to `(return-from nil RESULT)'." - (list 'return-from nil res)) - -(defmacro return-from (name &optional res) - "(return-from NAME [RESULT]): return from the block named NAME. -This jump out to the innermost enclosing `(block NAME ...)' form, -returning RESULT from that form (or nil if RESULT is omitted). -This is compatible with Common Lisp, but note that `defun' and -`defmacro' do not create implicit blocks as they do in Common Lisp." - (let ((name2 (intern (format "--cl-block-%s--" name)))) - (list 'cl-block-throw (list 'quote name2) res))) - - -;;; The "loop" macro. - -(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars) -(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) -(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag) -(defvar loop-initially) (defvar loop-map-form) (defvar loop-name) -(defvar loop-result) (defvar loop-result-explicit) -(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) - -(defmacro loop (&rest args) - "(loop CLAUSE...): The Common Lisp `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." - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args)))))) - (list 'block nil (list* 'while t args)) - (let ((loop-name nil) (loop-bindings nil) - (loop-body nil) (loop-steps nil) - (loop-result nil) (loop-result-explicit nil) - (loop-result-var nil) (loop-finish-flag nil) - (loop-accum-var nil) (loop-accum-vars nil) - (loop-initially nil) (loop-finally nil) - (loop-map-form nil) (loop-first-flag nil) - (loop-destr-temps nil) (loop-symbol-macs nil)) - (setq args (append args '(cl-end-loop))) - (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) - (if loop-finish-flag - (cl-push (list (list loop-finish-flag t)) loop-bindings)) - (if loop-first-flag - (progn (cl-push (list (list loop-first-flag t)) loop-bindings) - (cl-push (list 'setq loop-first-flag nil) loop-steps))) - (let* ((epilogue (nconc (nreverse loop-finally) - (list (or loop-result-explicit loop-result)))) - (ands (cl-loop-build-ands (nreverse loop-body))) - (while-body (nconc (cadr ands) (nreverse loop-steps))) - (body (append - (nreverse loop-initially) - (list (if loop-map-form - (list 'block '--cl-finish-- - (subst - (if (eq (car ands) t) while-body - (cons (list 'or (car ands) - '(return-from --cl-finish-- - nil)) - while-body)) - '--cl-map loop-map-form)) - (list* 'while (car ands) while-body))) - (if loop-finish-flag - (if (equal epilogue '(nil)) (list loop-result-var) - (list (list 'if loop-finish-flag - (cons 'progn epilogue) loop-result-var))) - epilogue)))) - (if loop-result-var (cl-push (list loop-result-var) loop-bindings)) - (while loop-bindings - (if (cdar loop-bindings) - (setq body (list (cl-loop-let (cl-pop loop-bindings) body t))) - (let ((lets nil)) - (while (and loop-bindings - (not (cdar loop-bindings))) - (cl-push (car (cl-pop loop-bindings)) lets)) - (setq body (list (cl-loop-let lets body nil)))))) - (if loop-symbol-macs - (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) - (list* 'block loop-name body))))) - -(defun cl-parse-loop-clause () ; uses args, loop-* - (let ((word (cl-pop args)) - (hash-types '(hash-key hash-keys hash-value hash-values)) - (key-types '(key-code key-codes key-seq key-seqs - key-binding key-bindings))) - (cond - - ((null args) - (error "Malformed `loop' macro")) - - ((eq word 'named) - (setq loop-name (cl-pop args))) - - ((eq word 'initially) - (if (memq (car args) '(do doing)) (cl-pop args)) - (or (consp (car args)) (error "Syntax error on `initially' clause")) - (while (consp (car args)) - (cl-push (cl-pop args) loop-initially))) - - ((eq word 'finally) - (if (eq (car args) 'return) - (setq loop-result-explicit (or (cl-pop2 args) '(quote nil))) - (if (memq (car args) '(do doing)) (cl-pop args)) - (or (consp (car args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar args) 'return) (null loop-name)) - (setq loop-result-explicit (or (nth 1 (cl-pop args)) '(quote nil))) - (while (consp (car args)) - (cl-push (cl-pop args) loop-finally))))) - - ((memq word '(for as)) - (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) - (ands nil)) - (while - (let ((var (or (cl-pop args) (gensym)))) - (setq word (cl-pop args)) - (if (eq word 'being) (setq word (cl-pop args))) - (if (memq word '(the each)) (setq word (cl-pop args))) - (if (memq word '(buffer buffers)) - (setq word 'in args (cons '(buffer-list) args))) - (cond - - ((memq word '(from downfrom upfrom to downto upto - above below by)) - (cl-push word args) - (if (memq (car args) '(downto above)) - (error "Must specify `from' value for downward loop")) - (let* ((down (or (eq (car args) 'downfrom) - (memq (caddr args) '(downto above)))) - (excl (or (memq (car args) '(above below)) - (memq (caddr args) '(above below)))) - (start (and (memq (car args) '(from upfrom downfrom)) - (cl-pop2 args))) - (end (and (memq (car args) - '(to upto downto above below)) - (cl-pop2 args))) - (step (and (eq (car args) 'by) (cl-pop2 args))) - (end-var (and (not (cl-const-expr-p end)) (gensym))) - (step-var (and (not (cl-const-expr-p step)) - (gensym)))) - (and step (numberp step) (<= step 0) - (error "Loop `by' value is not positive: %s" step)) - (cl-push (list var (or start 0)) loop-for-bindings) - (if end-var (cl-push (list end-var end) loop-for-bindings)) - (if step-var (cl-push (list step-var step) - loop-for-bindings)) - (if end - (cl-push (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) loop-body)) - (cl-push (list var (list (if down '- '+) var - (or step-var step 1))) - loop-for-steps))) - - ((memq word '(in in-ref on)) - (let* ((on (eq word 'on)) - (temp (if (and on (symbolp var)) var (gensym)))) - (cl-push (list temp (cl-pop args)) loop-for-bindings) - (cl-push (list 'consp temp) loop-body) - (if (eq word 'in-ref) - (cl-push (list var (list 'car temp)) loop-symbol-macs) - (or (eq temp var) - (progn - (cl-push (list var nil) loop-for-bindings) - (cl-push (list var (if on temp (list 'car temp))) - loop-for-sets)))) - (cl-push (list temp - (if (eq (car args) 'by) - (let ((step (cl-pop2 args))) - (if (and (memq (car-safe step) - '(quote function - function*)) - (symbolp (nth 1 step))) - (list (nth 1 step) temp) - (list 'funcall step temp))) - (list 'cdr temp))) - loop-for-steps))) - - ((eq word '=) - (let* ((start (cl-pop args)) - (then (if (eq (car args) 'then) (cl-pop2 args) start))) - (cl-push (list var nil) loop-for-bindings) - (if (or ands (eq (car args) 'and)) - (progn - (cl-push (list var - (list 'if - (or loop-first-flag - (setq loop-first-flag - (gensym))) - start var)) - loop-for-sets) - (cl-push (list var then) loop-for-steps)) - (cl-push (list var - (if (eq start then) start - (list 'if - (or loop-first-flag - (setq loop-first-flag (gensym))) - start then))) - loop-for-sets)))) - - ((memq word '(across across-ref)) - (let ((temp-vec (gensym)) (temp-idx (gensym))) - (cl-push (list temp-vec (cl-pop args)) loop-for-bindings) - (cl-push (list temp-idx -1) loop-for-bindings) - (cl-push (list '< (list 'setq temp-idx (list '1+ temp-idx)) - (list 'length temp-vec)) loop-body) - (if (eq word 'across-ref) - (cl-push (list var (list 'aref temp-vec temp-idx)) - loop-symbol-macs) - (cl-push (list var nil) loop-for-bindings) - (cl-push (list var (list 'aref temp-vec temp-idx)) - loop-for-sets)))) - - ((memq word '(element elements)) - (let ((ref (or (memq (car args) '(in-ref of-ref)) - (and (not (memq (car args) '(in of))) - (error "Expected `of'")))) - (seq (cl-pop2 args)) - (temp-seq (gensym)) - (temp-idx (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (eq (caadr args) 'index)) - (cadr (cl-pop2 args)) - (error "Bad `using' clause")) - (gensym)))) - (cl-push (list temp-seq seq) loop-for-bindings) - (cl-push (list temp-idx 0) loop-for-bindings) - (if ref - (let ((temp-len (gensym))) - (cl-push (list temp-len (list 'length temp-seq)) - loop-for-bindings) - (cl-push (list var (list 'elt temp-seq temp-idx)) - loop-symbol-macs) - (cl-push (list '< temp-idx temp-len) loop-body)) - (cl-push (list var nil) loop-for-bindings) - (cl-push (list 'and temp-seq - (list 'or (list 'consp temp-seq) - (list '< temp-idx - (list 'length temp-seq)))) - loop-body) - (cl-push (list var (list 'if (list 'consp temp-seq) - (list 'pop temp-seq) - (list 'aref temp-seq temp-idx))) - loop-for-sets)) - (cl-push (list temp-idx (list '1+ temp-idx)) - loop-for-steps))) - - ((memq word hash-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) hash-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) - (error "Bad `using' clause")) - (gensym)))) - (if (memq word '(hash-value hash-values)) - (setq var (prog1 other (setq other var)))) - (setq loop-map-form - (list 'maphash (list 'function - (list* 'lambda (list var other) - '--cl-map)) table)))) - - ((memq word '(symbol present-symbol external-symbol - symbols present-symbols external-symbols)) - (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args)))) - (setq loop-map-form - (list 'mapatoms (list 'function - (list* 'lambda (list var) - '--cl-map)) ob)))) - - ((memq word '(overlay overlays extent extents)) - (let ((buf nil) (from nil) (to nil)) - (while (memq (car args) '(in of from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) - (setq loop-map-form - (list 'cl-map-extents - (list 'function (list 'lambda (list var (gensym)) - '(progn . --cl-map) nil)) - buf from to)))) - - ((memq word '(interval intervals)) - (let ((buf nil) (prop nil) (from nil) (to nil) - (var1 (gensym)) (var2 (gensym))) - (while (memq (car args) '(in of property from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - ((eq (car args) 'property) - (setq prop (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) - (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) - (setq var1 (car var) var2 (cdr var)) - (cl-push (list var (list 'cons var1 var2)) loop-for-sets)) - (setq loop-map-form - (list 'cl-map-intervals - (list 'function (list 'lambda (list var1 var2) - '(progn . --cl-map))) - buf prop from to)))) - - ((memq word key-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let ((map (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) key-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) - (error "Bad `using' clause")) - (gensym)))) - (if (memq word '(key-binding key-bindings)) - (setq var (prog1 other (setq other var)))) - (setq loop-map-form - (list (if (memq word '(key-seq key-seqs)) - 'cl-map-keymap-recursively 'cl-map-keymap) - (list 'function (list* 'lambda (list var other) - '--cl-map)) map)))) - - ((memq word '(frame frames screen screens)) - (let ((temp (gensym))) - (cl-push (list var (if (eq cl-emacs-type 'lucid) - '(selected-screen) '(selected-frame))) - loop-for-bindings) - (cl-push (list temp nil) loop-for-bindings) - (cl-push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) - (cl-push (list var (list (if (eq cl-emacs-type 'lucid) - 'next-screen 'next-frame) var)) - loop-for-steps))) - - ((memq word '(window windows)) - (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) - (temp (gensym))) - (cl-push (list var (if scr - (list (if (eq cl-emacs-type 'lucid) - 'screen-selected-window - 'frame-selected-window) scr) - '(selected-window))) - loop-for-bindings) - (cl-push (list temp nil) loop-for-bindings) - (cl-push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) - (cl-push (list var (list 'next-window var)) loop-for-steps))) - - (t - (let ((handler (and (symbolp word) - (get word 'cl-loop-for-handler)))) - (if handler - (funcall handler var) - (error "Expected a `for' preposition, found %s" word))))) - (eq (car args) 'and)) - (setq ands t) - (cl-pop args)) - (if (and ands loop-for-bindings) - (cl-push (nreverse loop-for-bindings) loop-bindings) - (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) - loop-bindings))) - (if loop-for-sets - (cl-push (list 'progn - (cl-loop-let (nreverse loop-for-sets) 'setq ands) - t) loop-body)) - (if loop-for-steps - (cl-push (cons (if ands 'psetq 'setq) - (apply 'append (nreverse loop-for-steps))) - loop-steps)))) - - ((eq word 'repeat) - (let ((temp (gensym))) - (cl-push (list (list temp (cl-pop args))) loop-bindings) - (cl-push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) - - ((eq word 'collect) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (if (eq var loop-accum-var) - (cl-push (list 'progn (list 'push what var) t) loop-body) - (cl-push (list 'progn - (list 'setq var (list 'nconc var (list 'list what))) - t) loop-body)))) - - ((memq word '(nconc nconcing append appending)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (cl-push (list 'progn - (list 'setq var - (if (eq var loop-accum-var) - (list 'nconc - (list (if (memq word '(nconc nconcing)) - 'nreverse 'reverse) - what) - var) - (list (if (memq word '(nconc nconcing)) - 'nconc 'append) - var what))) t) loop-body))) - - ((memq word '(concat concating)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum ""))) - (cl-push (list 'progn (list 'callf 'concat var what) t) loop-body))) - - ((memq word '(vconcat vconcating)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum []))) - (cl-push (list 'progn (list 'callf 'vconcat var what) t) loop-body))) - - ((memq word '(sum summing)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum 0))) - (cl-push (list 'progn (list 'incf var what) t) loop-body))) - - ((memq word '(count counting)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum 0))) - (cl-push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) - - ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (cl-pop args)) - (temp (if (cl-simple-expr-p what) what (gensym))) - (var (cl-loop-handle-accum nil)) - (func (intern (substring (symbol-name word) 0 3))) - (set (list 'setq var (list 'if var (list func var temp) temp)))) - (cl-push (list 'progn (if (eq temp what) set - (list 'let (list (list temp what)) set)) - t) loop-body))) - - ((eq word 'with) - (let ((bindings nil)) - (while (progn (cl-push (list (cl-pop args) - (and (eq (car args) '=) (cl-pop2 args))) - bindings) - (eq (car args) 'and)) - (cl-pop args)) - (cl-push (nreverse bindings) loop-bindings))) - - ((eq word 'while) - (cl-push (cl-pop args) loop-body)) - - ((eq word 'until) - (cl-push (list 'not (cl-pop args)) loop-body)) - - ((eq word 'always) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (cl-push (list 'setq loop-finish-flag (cl-pop args)) loop-body) - (setq loop-result t)) - - ((eq word 'never) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (cl-push (list 'setq loop-finish-flag (list 'not (cl-pop args))) - loop-body) - (setq loop-result t)) - - ((eq word 'thereis) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (or loop-result-var (setq loop-result-var (gensym))) - (cl-push (list 'setq loop-finish-flag - (list 'not (list 'setq loop-result-var (cl-pop args)))) - loop-body)) - - ((memq word '(if when unless)) - (let* ((cond (cl-pop args)) - (then (let ((loop-body nil)) - (cl-parse-loop-clause) - (cl-loop-build-ands (nreverse loop-body)))) - (else (let ((loop-body nil)) - (if (eq (car args) 'else) - (progn (cl-pop args) (cl-parse-loop-clause))) - (cl-loop-build-ands (nreverse loop-body)))) - (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car args) 'end) (cl-pop args)) - (if (eq word 'unless) (setq then (prog1 else (setq else then)))) - (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) - (if simple (nth 1 else) (list (nth 2 else)))))) - (if (cl-expr-contains form 'it) - (let ((temp (gensym))) - (cl-push (list temp) loop-bindings) - (setq form (list* 'if (list 'setq temp cond) - (subst temp 'it form)))) - (setq form (list* 'if cond form))) - (cl-push (if simple (list 'progn form t) form) loop-body)))) - - ((memq word '(do doing)) - (let ((body nil)) - (or (consp (car args)) (error "Syntax error on `do' clause")) - (while (consp (car args)) (cl-push (cl-pop args) body)) - (cl-push (cons 'progn (nreverse (cons t body))) loop-body))) - - ((eq word 'return) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (or loop-result-var (setq loop-result-var (gensym))) - (cl-push (list 'setq loop-result-var (cl-pop args) - loop-finish-flag nil) loop-body)) - - (t - (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) - (or handler (error "Expected a loop keyword, found %s" word)) - (funcall handler)))) - (if (eq (car args) 'and) - (progn (cl-pop args) (cl-parse-loop-clause))))) - -(defun cl-loop-let (specs body par) ; uses loop-* - (let ((p specs) (temps nil) (new nil)) - (while (and p (or (symbolp (car-safe (car p))) (null (cadar p)))) - (setq p (cdr p))) - (and par p - (progn - (setq par nil p specs) - (while p - (or (cl-const-expr-p (cadar p)) - (let ((temp (gensym))) - (cl-push (list temp (cadar p)) temps) - (setcar (cdar p) temp))) - (setq p (cdr p))))) - (while specs - (if (and (consp (car specs)) (listp (caar specs))) - (let* ((spec (caar specs)) (nspecs nil) - (expr (cadr (cl-pop specs))) - (temp (cdr (or (assq spec loop-destr-temps) - (car (cl-push (cons spec (or (last spec 0) - (gensym))) - loop-destr-temps)))))) - (cl-push (list temp expr) new) - (while (consp spec) - (cl-push (list (cl-pop spec) - (and expr (list (if spec 'pop 'car) temp))) - nspecs)) - (setq specs (nconc (nreverse nspecs) specs))) - (cl-push (cl-pop specs) new))) - (if (eq body 'setq) - (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new))))) - (if temps (list 'let* (nreverse temps) set) set)) - (list* (if par 'let 'let*) - (nconc (nreverse temps) (nreverse new)) body)))) - -(defun cl-loop-handle-accum (def &optional func) ; uses args, loop-* - (if (eq (car args) 'into) - (let ((var (cl-pop2 args))) - (or (memq var loop-accum-vars) - (progn (cl-push (list (list var def)) loop-bindings) - (cl-push var loop-accum-vars))) - var) - (or loop-accum-var - (progn - (cl-push (list (list (setq loop-accum-var (gensym)) def)) - loop-bindings) - (setq loop-result (if func (list func loop-accum-var) - loop-accum-var)) - loop-accum-var)))) - -(defun cl-loop-build-ands (clauses) - (let ((ands nil) - (body nil)) - (while clauses - (if (and (eq (car-safe (car clauses)) 'progn) - (eq (car (last (car clauses))) t)) - (if (cdr clauses) - (setq clauses (cons (nconc (butlast (car clauses)) - (if (eq (car-safe (cadr clauses)) - 'progn) - (cdadr clauses) - (list (cadr clauses)))) - (cddr clauses))) - (setq body (cdr (butlast (cl-pop clauses))))) - (cl-push (cl-pop clauses) ands))) - (setq ands (or (nreverse ands) (list t))) - (list (if (cdr ands) (cons 'and ands) (car ands)) - body - (let ((full (if body - (append ands (list (cons 'progn (append body '(t))))) - ands))) - (if (cdr full) (cons 'and full) (car full)))))) - - -;;; Other iteration control structures. - -(defmacro do (steps endtest &rest body) - "The Common Lisp `do' loop. -Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" - (cl-expand-do-loop steps endtest body nil)) - -(defmacro do* (steps endtest &rest body) - "The Common Lisp `do*' loop. -Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" - (cl-expand-do-loop steps endtest body t)) - -(defun cl-expand-do-loop (steps endtest body star) - (list 'block nil - (list* (if star 'let* 'let) - (mapcar (function (lambda (c) - (if (consp c) (list (car c) (nth 1 c)) c))) - steps) - (list* 'while (list 'not (car endtest)) - (append body - (let ((sets (mapcar - (function - (lambda (c) - (and (consp c) (cdr (cdr c)) - (list (car c) (nth 2 c))))) - steps))) - (setq sets (delq nil sets)) - (and sets - (list (cons (if (or star (not (cdr sets))) - 'setq 'psetq) - (apply 'append sets))))))) - (or (cdr endtest) '(nil))))) - -(defmacro dolist (spec &rest body) - "(dolist (VAR LIST [RESULT]) BODY...): loop over a list. -Evaluate BODY with VAR bound to each `car' from LIST, in turn. -Then evaluate RESULT to get return value, default nil." - (let ((temp (gensym "--dolist-temp--"))) - (list 'block nil - (list* 'let (list (list temp (nth 1 spec)) (car spec)) - (list* 'while temp (list 'setq (car spec) (list 'car temp)) - (append body (list (list 'setq temp - (list 'cdr temp))))) - (if (cdr (cdr spec)) - (cons (list 'setq (car spec) nil) (cdr (cdr spec))) - '(nil)))))) - -(defmacro dotimes (spec &rest body) - "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times. -Evaluate BODY with VAR bound to successive integers from 0, inclusive, -to COUNT, exclusive. Then evaluate RESULT to get return value, default -nil." - (let ((temp (gensym "--dotimes-temp--"))) - (list 'block nil - (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) - (list* 'while (list '< (car spec) temp) - (append body (list (list 'incf (car spec))))) - (or (cdr (cdr spec)) '(nil)))))) - -(defmacro do-symbols (spec &rest body) - "(dosymbols (VAR [OBARRAY [RESULT]]) BODY...): loop over all symbols. -Evaluate BODY with VAR bound to each interned symbol, or to each symbol -from OBARRAY." - ;; Apparently this doesn't have an implicit block. - (list 'block nil - (list 'let (list (car spec)) - (list* 'mapatoms - (list 'function (list* 'lambda (list (car spec)) body)) - (and (cadr spec) (list (cadr spec)))) - (caddr spec)))) - -(defmacro do-all-symbols (spec &rest body) - (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) - - -;;; Assignments. - -(defmacro psetq (&rest args) - "(psetq SYM VAL SYM VAL ...): set SYMs to the values VALs in parallel. -This is like `setq', except that all VAL forms are evaluated (in order) -before assigning any symbols SYM to the corresponding values." - (cons 'psetf args)) - - -;;; Binding control structures. - -(defmacro progv (symbols values &rest body) - "(progv SYMBOLS VALUES BODY...): 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 -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." - (list 'let '((cl-progv-save nil)) - (list 'unwind-protect - (list* 'progn (list 'cl-progv-before symbols values) body) - '(cl-progv-after)))) - -;;; This should really have some way to shadow 'byte-compile properties, etc. -(defmacro flet (bindings &rest body) - "(flet ((FUNC ARGLIST BODY...) ...) FORM...): make temporary function defns. -This is an analogue of `let' that operates on the function cell of FUNC -rather than its value cell. The FORMs are evaluated with the specified -function definitions in place, then the definitions are undone (the FUNCs -go back to their previous definitions, or lack thereof)." - (list* 'letf* - (mapcar - (function - (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) cl-macro-environment))) - (error "Use `labels', not `flet', to rebind macro names")) - (let ((func (list 'function* - (list 'lambda (cadr x) - (list* 'block (car x) (cddr x)))))) - (if (and (cl-compiling-file) - (boundp 'byte-compile-function-environment)) - (cl-push (cons (car x) (eval func)) - byte-compile-function-environment)) - (list (list 'symbol-function (list 'quote (car x))) func)))) - bindings) - body)) - -(defmacro labels (bindings &rest body) - "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings. -This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully complaint with the Common Lisp standard." - (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) - (while bindings - (let ((var (gensym))) - (cl-push var vars) - (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets) - (cl-push var sets) - (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args) - (list 'list* '(quote funcall) (list 'quote var) - 'cl-labels-args)) - cl-macro-environment))) - (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body)) - cl-macro-environment))) - -;; The following ought to have a better definition for use with newer -;; byte compilers. -(defmacro macrolet (bindings &rest body) - "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns. -This is like `flet', but for macros instead of functions." - (if (cdr bindings) - (list 'macrolet - (list (car bindings)) (list* 'macrolet (cdr bindings) body)) - (if (null bindings) (cons 'progn body) - (let* ((name (caar bindings)) - (res (cl-transform-lambda (cdar bindings) name))) - (eval (car res)) - (cl-macroexpand-all (cons 'progn body) - (cons (list* name 'lambda (cdr res)) - cl-macro-environment)))))) - -(defmacro symbol-macrolet (bindings &rest body) - "(symbol-macrolet ((NAME EXPANSION) ...) FORM...): make symbol macro defns. -Within the body FORMs, references to the variable NAME will be replaced -by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)." - (if (cdr bindings) - (list 'symbol-macrolet - (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) - (if (null bindings) (cons 'progn body) - (cl-macroexpand-all (cons 'progn body) - (cons (list (symbol-name (caar bindings)) - (cadar bindings)) - cl-macro-environment))))) - -(defvar cl-closure-vars nil) -(defmacro lexical-let (bindings &rest body) - "(lexical-let BINDINGS BODY...): like `let', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp." - (let* ((cl-closure-vars cl-closure-vars) - (vars (mapcar (function - (lambda (x) - (or (consp x) (setq x (list x))) - (cl-push (gensym (format "--%s--" (car x))) - cl-closure-vars) - (set (car cl-closure-vars) [bad-lexical-ref]) - (list (car x) (cadr x) (car cl-closure-vars)))) - bindings)) - (ebody - (cl-macroexpand-all - (cons 'progn body) - (nconc (mapcar (function (lambda (x) - (list (symbol-name (car x)) - (list 'symbol-value (caddr x)) - t))) vars) - (list '(defun . cl-defun-expander)) - cl-macro-environment)))) - (if (not (get (car (last cl-closure-vars)) 'used)) - (list 'let (mapcar (function (lambda (x) - (list (caddr x) (cadr x)))) vars) - (sublis (mapcar (function (lambda (x) - (cons (caddr x) - (list 'quote (caddr x))))) - vars) - ebody)) - (list 'let (mapcar (function (lambda (x) - (list (caddr x) - (list 'make-symbol - (format "--%s--" (car x)))))) - vars) - (apply 'append '(setf) - (mapcar (function - (lambda (x) - (list (list 'symbol-value (caddr x)) (cadr x)))) - vars)) - ebody)))) - -(defmacro lexical-let* (bindings &rest body) - "(lexical-let* BINDINGS BODY...): like `let*', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp." - (if (null bindings) (cons 'progn body) - (setq bindings (reverse bindings)) - (while bindings - (setq body (list (list* 'lexical-let (list (cl-pop bindings)) body)))) - (car body))) - -(defun cl-defun-expander (func &rest rest) - (list 'progn - (list 'defalias (list 'quote func) - (list 'function (cons 'lambda rest))) - (list 'quote func))) - - -;;; Multiple values. - -(defmacro multiple-value-bind (vars form &rest body) - "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values. -FORM must return a list; the BODY is then executed with the first N elements -of this list bound (`let'-style) to each of the symbols SYM in turn. This -is analogous to the Common Lisp `multiple-value-bind' macro, using lists to -simulate true multiple return values. For compatibility, (values A B C) is -a synonym for (list A B C)." - (let ((temp (gensym)) (n -1)) - (list* 'let* (cons (list temp form) - (mapcar (function - (lambda (v) - (list v (list 'nth (setq n (1+ n)) temp)))) - vars)) - body))) - -(defmacro multiple-value-setq (vars form) - "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values. -FORM must return a list; the first N elements of this list are stored in -each of the symbols SYM in turn. This is analogous to the Common Lisp -`multiple-value-setq' macro, using lists to simulate true multiple return -values. For compatibility, (values A B C) is a synonym for (list A B C)." - (cond ((null vars) (list 'progn form nil)) - ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) - (t - (let* ((temp (gensym)) (n 0)) - (list 'let (list (list temp form)) - (list 'prog1 (list 'setq (cl-pop vars) (list 'car temp)) - (cons 'setq (apply 'nconc - (mapcar (function - (lambda (v) - (list v (list - 'nth - (setq n (1+ n)) - temp)))) - vars))))))))) - - -;;; Declarations. - -(defmacro locally (&rest body) (cons 'progn body)) -(defmacro the (type form) form) - -(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) (cl-push spec cl-proclaim-history)) - (cond ((eq (car-safe spec) 'special) - (if (boundp 'byte-compile-bound-variables) - (setq byte-compile-bound-variables - (append (cdr spec) byte-compile-bound-variables)))) - - ((eq (car-safe spec) 'inline) - (while (setq spec (cdr spec)) - (or (memq (get (car spec) 'byte-optimizer) - '(nil byte-compile-inline-expand)) - (error "%s already has a byte-optimizer, can't make it inline" - (car spec))) - (put (car spec) 'byte-optimizer 'byte-compile-inline-expand))) - - ((eq (car-safe spec) 'notinline) - (while (setq spec (cdr spec)) - (if (eq (get (car spec) 'byte-optimizer) - 'byte-compile-inline-expand) - (put (car spec) 'byte-optimizer nil)))) - - ((eq (car-safe spec) 'optimize) - (let ((speed (assq (nth 1 (assq 'speed (cdr spec))) - '((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) - byte-optimize (nth 1 speed))) - (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)) - (if (eq byte-compile-warnings t) - (setq byte-compile-warnings byte-compile-warning-types)) - (while (setq spec (cdr spec)) - (if (consp (car spec)) - (if (eq (cadar spec) 0) - (setq byte-compile-warnings - (delq (caar spec) byte-compile-warnings)) - (setq byte-compile-warnings - (adjoin (caar spec) byte-compile-warnings))))))) - 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 (cl-pop p) t)) - (setq cl-proclaims-deferred nil)) - -(defmacro declare (&rest specs) - (if (cl-compiling-file) - (while specs - (if (listp cl-declare-stack) (cl-push (car specs) cl-declare-stack)) - (cl-do-proclaim (cl-pop specs) nil))) - nil) - - - -;;; Generalized variables. - -(defmacro define-setf-method (func args &rest body) - "(define-setf-method NAME ARGLIST 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 `defsetf' for a simpler way to define most setf-methods." - (append '(eval-when (compile load eval)) - (if (stringp (car body)) - (list (list 'put (list 'quote func) '(quote setf-documentation) - (cl-pop body)))) - (list (cl-transform-function-property - func 'setf-method (cons args body))))) - -(defmacro defsetf (func arg1 &rest args) - "(defsetf NAME FUNC): define a `setf' method. -This macro is an easy-to-use substitute for `define-setf-method' 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: (defsetf aref aset). -Alternate form: (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: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." - (if (listp arg1) - (let* ((largs nil) (largsr nil) - (temps nil) (tempsr nil) - (restarg nil) (rest-temps nil) - (store-var (car (prog1 (car args) (setq args (cdr args))))) - (store-temp (intern (format "--%s--temp--" store-var))) - (lets1 nil) (lets2 nil) - (docstr nil) (p arg1)) - (if (stringp (car args)) - (setq docstr (prog1 (car args) (setq args (cdr args))))) - (while (and p (not (eq (car p) '&aux))) - (if (eq (car p) '&rest) - (setq p (cdr p) restarg (car p)) - (or (memq (car p) '(&optional &key &allow-other-keys)) - (setq largs (cons (if (consp (car p)) (car (car p)) (car p)) - largs) - temps (cons (intern (format "--%s--temp--" (car largs))) - temps)))) - (setq p (cdr p))) - (setq largs (nreverse largs) temps (nreverse temps)) - (if restarg - (setq largsr (append largs (list restarg)) - rest-temps (intern (format "--%s--temp--" restarg)) - tempsr (append temps (list rest-temps))) - (setq largsr largs tempsr temps)) - (let ((p1 largs) (p2 temps)) - (while p1 - (setq lets1 (cons (list (car p2) - (list 'gensym (format "--%s--" (car p1)))) - lets1) - lets2 (cons (list (car p1) (car p2)) lets2) - p1 (cdr p1) p2 (cdr p2)))) - (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) - (append (list 'define-setf-method func arg1) - (and docstr (list docstr)) - (list - (list 'let* - (nreverse - (cons (list store-temp - (list 'gensym (format "--%s--" store-var))) - (if restarg - (append - (list - (list rest-temps - (list 'mapcar '(quote gensym) - restarg))) - lets1) - lets1))) - (list 'list ; 'values - (cons (if restarg 'list* 'list) tempsr) - (cons (if restarg 'list* 'list) largsr) - (list 'list store-temp) - (cons 'let* - (cons (nreverse - (cons (list store-var store-temp) - lets2)) - args)) - (cons (if restarg 'list* 'list) - (cons (list 'quote func) tempsr))))))) - (list 'defsetf func '(&rest args) '(store) - (let ((call (list 'cons (list 'quote arg1) - '(append args (list store))))) - (if (car args) - (list 'list '(quote progn) call 'store) - call))))) - -;;; Some standard place types from Common Lisp. -(defsetf aref aset) -(defsetf car setcar) -(defsetf cdr setcdr) -(defsetf elt (seq n) (store) - (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store) - (list 'aset seq n store))) -(defsetf get put) -(defsetf get* (x y &optional d) (store) (list 'put x y store)) -(defsetf gethash (x h &optional d) (store) (list 'cl-puthash x store h)) -(defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) -(defsetf subseq (seq start &optional end) (new) - (list 'progn (list 'replace seq new ':start1 start ':end1 end) new)) -(defsetf symbol-function fset) -(defsetf symbol-plist setplist) -(defsetf symbol-value set) - -;;; Various car/cdr aliases. Note that `cadr' is handled specially. -(defsetf first setcar) -(defsetf second (x) (store) (list 'setcar (list 'cdr x) store)) -(defsetf third (x) (store) (list 'setcar (list 'cddr x) store)) -(defsetf fourth (x) (store) (list 'setcar (list 'cdddr x) store)) -(defsetf fifth (x) (store) (list 'setcar (list 'nthcdr 4 x) store)) -(defsetf sixth (x) (store) (list 'setcar (list 'nthcdr 5 x) store)) -(defsetf seventh (x) (store) (list 'setcar (list 'nthcdr 6 x) store)) -(defsetf eighth (x) (store) (list 'setcar (list 'nthcdr 7 x) store)) -(defsetf ninth (x) (store) (list 'setcar (list 'nthcdr 8 x) store)) -(defsetf tenth (x) (store) (list 'setcar (list 'nthcdr 9 x) store)) -(defsetf rest setcdr) - -;;; Some more Emacs-related place types. -(defsetf buffer-file-name set-visited-file-name t) -(defsetf buffer-modified-p set-buffer-modified-p t) -(defsetf buffer-name rename-buffer t) -(defsetf buffer-string () (store) - (list 'progn '(erase-buffer) (list 'insert store))) -(defsetf buffer-substring cl-set-buffer-substring) -(defsetf current-buffer set-buffer) -(defsetf current-case-table set-case-table) -(defsetf current-column move-to-column t) -(defsetf current-global-map use-global-map t) -(defsetf current-input-mode () (store) - (list 'progn (list 'apply 'set-input-mode store) store)) -(defsetf current-local-map use-local-map t) -(defsetf current-window-configuration set-window-configuration t) -(defsetf default-file-modes set-default-file-modes t) -(defsetf default-value set-default) -(defsetf documentation-property put) -(defsetf extent-data set-extent-data) -(defsetf extent-face set-extent-face) -(defsetf extent-priority set-extent-priority) -(defsetf extent-end-position (ext) (store) - (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) - store) store)) -(defsetf extent-start-position (ext) (store) - (list 'progn (list 'set-extent-endpoints store - (list 'extent-end-position ext)) store)) -(defsetf face-background (f &optional s) (x) (list 'set-face-background f x s)) -(defsetf face-background-pixmap (f &optional s) (x) - (list 'set-face-background-pixmap f x s)) -(defsetf face-font (f &optional s) (x) (list 'set-face-font f x s)) -(defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s)) -(defsetf face-underline-p (f &optional s) (x) - (list 'set-face-underline-p f x s)) -(defsetf file-modes set-file-modes t) -(defsetf frame-height set-screen-height t) -(defsetf frame-parameters modify-frame-parameters t) -(defsetf frame-visible-p cl-set-frame-visible-p) -(defsetf frame-width set-screen-width t) -(defsetf getenv setenv t) -(defsetf get-register set-register) -(defsetf global-key-binding global-set-key) -(defsetf keymap-parent set-keymap-parent) -(defsetf local-key-binding local-set-key) -(defsetf mark set-mark t) -(defsetf mark-marker set-mark t) -(defsetf marker-position set-marker t) -(defsetf match-data store-match-data t) -(defsetf mouse-position (scr) (store) - (list 'set-mouse-position scr (list 'car store) (list 'cadr store) - (list 'cddr store))) -(defsetf overlay-get overlay-put) -(defsetf overlay-start (ov) (store) - (list 'progn (list 'move-overlay ov store (list 'overlay-end ov)) store)) -(defsetf overlay-end (ov) (store) - (list 'progn (list 'move-overlay ov (list 'overlay-start ov) store) store)) -(defsetf point goto-char) -(defsetf point-marker goto-char t) -(defsetf point-max () (store) - (list 'progn (list 'narrow-to-region '(point-min) store) store)) -(defsetf point-min () (store) - (list 'progn (list 'narrow-to-region store '(point-max)) store)) -(defsetf process-buffer set-process-buffer) -(defsetf process-filter set-process-filter) -(defsetf process-sentinel set-process-sentinel) -(defsetf read-mouse-position (scr) (store) - (list 'set-mouse-position scr (list 'car store) (list 'cdr store))) -(defsetf screen-height set-screen-height t) -(defsetf screen-width set-screen-width t) -(defsetf selected-window select-window) -(defsetf selected-screen select-screen) -(defsetf selected-frame select-frame) -(defsetf standard-case-table set-standard-case-table) -(defsetf syntax-table set-syntax-table) -(defsetf visited-file-modtime set-visited-file-modtime t) -(defsetf window-buffer set-window-buffer t) -(defsetf window-display-table set-window-display-table t) -(defsetf window-dedicated-p set-window-dedicated-p t) -(defsetf window-height () (store) - (list 'progn (list 'enlarge-window (list '- store '(window-height))) store)) -(defsetf window-hscroll set-window-hscroll) -(defsetf window-point set-window-point) -(defsetf window-start set-window-start) -(defsetf window-width () (store) - (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store)) -(defsetf x-get-cutbuffer x-store-cutbuffer t) -(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan. -(defsetf x-get-secondary-selection x-own-secondary-selection t) -(defsetf x-get-selection x-own-selection t) - -;;; More complex setf-methods. -;;; These should take &environment arguments, but since full arglists aren't -;;; available while compiling cl-macs, we fake it by referring to the global -;;; variable cl-macro-environment directly. - -(define-setf-method apply (func arg1 &rest rest) - (or (and (memq (car-safe func) '(quote function function*)) - (symbolp (car-safe (cdr-safe func)))) - (error "First arg to apply in setf is not (function SYM): %s" func)) - (let* ((form (cons (nth 1 func) (cons arg1 rest))) - (method (get-setf-method form cl-macro-environment))) - (list (car method) (nth 1 method) (nth 2 method) - (cl-setf-make-apply (nth 3 method) (cadr func) (car method)) - (cl-setf-make-apply (nth 4 method) (cadr func) (car method))))) - -(defun cl-setf-make-apply (form func temps) - (if (eq (car form) 'progn) - (list* 'progn (cl-setf-make-apply (cadr form) func temps) (cddr form)) - (or (equal (last form) (last temps)) - (error "%s is not suitable for use with setf-of-apply" func)) - (list* 'apply (list 'quote (car form)) (cdr form)))) - -(define-setf-method nthcdr (n place) - (let ((method (get-setf-method place cl-macro-environment)) - (n-temp (gensym "--nthcdr-n--")) - (store-temp (gensym "--nthcdr-store--"))) - (list (cons n-temp (car method)) - (cons n (nth 1 method)) - (list store-temp) - (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-nthcdr n-temp (nth 4 method) - store-temp))) - (nth 3 method) store-temp) - (list 'nthcdr n-temp (nth 4 method))))) - -(define-setf-method getf (place tag &optional def) - (let ((method (get-setf-method place cl-macro-environment)) - (tag-temp (gensym "--getf-tag--")) - (def-temp (gensym "--getf-def--")) - (store-temp (gensym "--getf-store--"))) - (list (append (car method) (list tag-temp def-temp)) - (append (nth 1 method) (list tag def)) - (list store-temp) - (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-getf (nth 4 method) - tag-temp store-temp))) - (nth 3 method) store-temp) - (list 'getf (nth 4 method) tag-temp def-temp)))) - -(define-setf-method substring (place from &optional to) - (let ((method (get-setf-method place cl-macro-environment)) - (from-temp (gensym "--substring-from--")) - (to-temp (gensym "--substring-to--")) - (store-temp (gensym "--substring-store--"))) - (list (append (car method) (list from-temp to-temp)) - (append (nth 1 method) (list from to)) - (list store-temp) - (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-substring (nth 4 method) - from-temp to-temp store-temp))) - (nth 3 method) store-temp) - (list 'substring (nth 4 method) from-temp to-temp)))) - -;;; Getting and optimizing setf-methods. -(defun get-setf-method (place &optional env) - "Return a list of five values describing the setf-method for PLACE. -PLACE may be any Lisp form which can appear as the PLACE argument to -a macro like `setf' or `incf'." - (if (symbolp place) - (let ((temp (gensym "--setf--"))) - (list nil nil (list temp) (list 'setq place temp) place)) - (or (and (symbolp (car place)) - (let* ((func (car place)) - (name (symbol-name func)) - (method (get func 'setf-method)) - (case-fold-search nil)) - (or (and method - (let ((cl-macro-environment env)) - (setq method (apply method (cdr place)))) - (if (and (consp method) (= (length method) 5)) - method - (error "Setf-method for %s returns malformed method" - func))) - (and (save-match-data - (string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name)) - (get-setf-method (compiler-macroexpand place))) - (and (eq func 'edebug-after) - (get-setf-method (nth (1- (length place)) place) - env))))) - (if (eq place (setq place (macroexpand place env))) - (if (and (symbolp (car place)) (fboundp (car place)) - (symbolp (symbol-function (car place)))) - (get-setf-method (cons (symbol-function (car place)) - (cdr place)) env) - (error "No setf-method known for %s" (car place))) - (get-setf-method place env))))) - -(defun cl-setf-do-modify (place opt-expr) - (let* ((method (get-setf-method place cl-macro-environment)) - (temps (car method)) (values (nth 1 method)) - (lets nil) (subs nil) - (optimize (and (not (eq opt-expr 'no-opt)) - (or (and (not (eq opt-expr 'unsafe)) - (cl-safe-expr-p opt-expr)) - (cl-setf-simple-store-p (car (nth 2 method)) - (nth 3 method))))) - (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place))))) - (while values - (if (or simple (cl-const-expr-p (car values))) - (cl-push (cons (cl-pop temps) (cl-pop values)) subs) - (cl-push (list (cl-pop temps) (cl-pop values)) lets))) - (list (nreverse lets) - (cons (car (nth 2 method)) (sublis subs (nth 3 method))) - (sublis subs (nth 4 method))))) - -(defun cl-setf-do-store (spec val) - (let ((sym (car spec)) - (form (cdr spec))) - (if (or (cl-const-expr-p val) - (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) - (cl-setf-simple-store-p sym form)) - (subst val sym form) - (list 'let (list (list sym val)) form)))) - -(defun cl-setf-simple-store-p (sym form) - (and (consp form) (eq (cl-expr-contains form sym) 1) - (eq (nth (1- (length form)) form) sym) - (symbolp (car form)) (fboundp (car form)) - (not (eq (car-safe (symbol-function (car form))) 'macro)))) - -;;; The standard modify macros. -(defmacro setf (&rest args) - "(setf PLACE VAL PLACE VAL ...): set each PLACE to the value of its VAL. -This is a generalized version of `setq'; the PLACEs may be symbolic -references such as (car x) or (aref x i), as well as plain symbols. -For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). -The return value is the last VAL in the list." - (if (cdr (cdr args)) - (let ((sets nil)) - (while args (cl-push (list 'setf (cl-pop args) (cl-pop args)) sets)) - (cons 'progn (nreverse sets))) - (if (symbolp (car args)) - (and args (cons 'setq args)) - (let* ((method (cl-setf-do-modify (car args) (nth 1 args))) - (store (cl-setf-do-store (nth 1 method) (nth 1 args)))) - (if (car method) (list 'let* (car method) store) store))))) - -(defmacro psetf (&rest args) - "(psetf PLACE VAL PLACE VAL ...): set PLACEs to the values VALs in parallel. -This is like `setf', except that all VAL forms are evaluated (in order) -before assigning any PLACEs to the corresponding values." - (let ((p args) (simple t) (vars nil)) - (while p - (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) - (setq simple nil)) - (if (memq (car p) vars) - (error "Destination duplicated in psetf: %s" (car p))) - (cl-push (cl-pop p) vars) - (or p (error "Odd number of arguments to psetf")) - (cl-pop p)) - (if simple - (list 'progn (cons 'setf args) nil) - (setq args (reverse args)) - (let ((expr (list 'setf (cadr args) (car args)))) - (while (setq args (cddr args)) - (setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr)))) - (list 'progn expr nil))))) - -(defun cl-do-pop (place) - (if (cl-simple-expr-p place) - (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) - (let* ((method (cl-setf-do-modify place t)) - (temp (gensym "--pop--"))) - (list 'let* - (append (car method) - (list (list temp (nth 2 method)))) - (list 'prog1 - (list 'car temp) - (cl-setf-do-store (nth 1 method) (list 'cdr temp))))))) - -(defmacro remf (place tag) - "(remf PLACE TAG): remove TAG from property list PLACE. -PLACE may be a symbol, or any generalized variable allowed by `setf'. -The form returns true if TAG was found and removed, nil otherwise." - (let* ((method (cl-setf-do-modify place t)) - (tag-temp (and (not (cl-const-expr-p tag)) (gensym "--remf-tag--"))) - (val-temp (and (not (cl-simple-expr-p place)) - (gensym "--remf-place--"))) - (ttag (or tag-temp tag)) - (tval (or val-temp (nth 2 method)))) - (list 'let* - (append (car method) - (and val-temp (list (list val-temp (nth 2 method)))) - (and tag-temp (list (list tag-temp tag)))) - (list 'if (list 'eq ttag (list 'car tval)) - (list 'progn - (cl-setf-do-store (nth 1 method) (list 'cddr tval)) - t) - (list 'cl-do-remf tval ttag))))) - -(defmacro shiftf (place &rest args) - "(shiftf PLACE PLACE... VAL): shift left among PLACEs. -Example: (shiftf A B C) sets A to B, B to C, and returns the old A. -Each PLACE may be a symbol, or any generalized variable allowed by `setf'." - (if (not (memq nil (mapcar 'symbolp (butlast (cons place args))))) - (list* 'prog1 place - (let ((sets nil)) - (while args - (cl-push (list 'setq place (car args)) sets) - (setq place (cl-pop args))) - (nreverse sets))) - (let* ((places (reverse (cons place args))) - (form (cl-pop places))) - (while places - (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe))) - (setq form (list 'let* (car method) - (list 'prog1 (nth 2 method) - (cl-setf-do-store (nth 1 method) form)))))) - form))) - -(defmacro rotatef (&rest args) - "(rotatef PLACE...): rotate left among PLACEs. -Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. -Each PLACE may be a symbol, or any generalized variable allowed by `setf'." - (if (not (memq nil (mapcar 'symbolp args))) - (and (cdr args) - (let ((sets nil) - (first (car args))) - (while (cdr args) - (setq sets (nconc sets (list (cl-pop args) (car args))))) - (nconc (list 'psetf) sets (list (car args) first)))) - (let* ((places (reverse args)) - (temp (gensym "--rotatef--")) - (form temp)) - (while (cdr places) - (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe))) - (setq form (list 'let* (car method) - (list 'prog1 (nth 2 method) - (cl-setf-do-store (nth 1 method) form)))))) - (let ((method (cl-setf-do-modify (car places) 'unsafe))) - (list 'let* (append (car method) (list (list temp (nth 2 method)))) - (cl-setf-do-store (nth 1 method) form) nil))))) - -(defmacro letf (bindings &rest body) - "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. -This is the analogue of `let', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding -VALUE, then the BODY forms are executed. On exit, either normally or -because of a `throw' or error, the PLACEs are set back to their original -values. Note that this macro is *not* available in Common Lisp. -As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY." - (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) - (list* 'let bindings body) - (let ((lets nil) (sets nil) - (unsets nil) (rev (reverse bindings))) - (while rev - (let* ((place (if (symbolp (caar rev)) - (list 'symbol-value (list 'quote (caar rev))) - (caar rev))) - (value (cadar rev)) - (method (cl-setf-do-modify place 'no-opt)) - (save (gensym "--letf-save--")) - (bound (and (memq (car place) '(symbol-value symbol-function)) - (gensym "--letf-bound--"))) - (temp (and (not (cl-const-expr-p value)) (cdr bindings) - (gensym "--letf-val--")))) - (setq lets (nconc (car method) - (if bound - (list (list bound - (list (if (eq (car place) - 'symbol-value) - 'boundp 'fboundp) - (nth 1 (nth 2 method)))) - (list save (list 'and bound - (nth 2 method)))) - (list (list save (nth 2 method)))) - (and temp (list (list temp value))) - lets) - body (list - (list 'unwind-protect - (cons 'progn - (if (cdr (car rev)) - (cons (cl-setf-do-store (nth 1 method) - (or temp value)) - body) - body)) - (if bound - (list 'if bound - (cl-setf-do-store (nth 1 method) save) - (list (if (eq (car place) 'symbol-value) - 'makunbound 'fmakunbound) - (nth 1 (nth 2 method)))) - (cl-setf-do-store (nth 1 method) save)))) - rev (cdr rev)))) - (list* 'let* lets body)))) - -(defmacro letf* (bindings &rest body) - "(letf* ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. -This is the analogue of `let*', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding -VALUE, then the BODY forms are executed. On exit, either normally or -because of a `throw' or error, the PLACEs are set back to their original -values. Note that this macro is *not* available in Common Lisp. -As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY." - (if (null bindings) - (cons 'progn body) - (setq bindings (reverse bindings)) - (while bindings - (setq body (list (list* 'letf (list (cl-pop bindings)) body)))) - (car body))) - -(defmacro callf (func place &rest args) - "(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...). -FUNC should be an unquoted function name. PLACE may be a symbol, -or any generalized variable allowed by `setf'." - (let* ((method (cl-setf-do-modify place (cons 'list args))) - (rargs (cons (nth 2 method) args))) - (list 'let* (car method) - (cl-setf-do-store (nth 1 method) - (if (symbolp func) (cons func rargs) - (list* 'funcall (list 'function func) - rargs)))))) - -(defmacro callf2 (func arg1 place &rest args) - "(callf2 FUNC ARG1 PLACE ARGS...): set PLACE to (FUNC ARG1 PLACE ARGS...). -Like `callf', but PLACE is the second argument of FUNC, not the first." - (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) - (list 'setf place (list* func arg1 place args)) - (let* ((method (cl-setf-do-modify place (cons 'list args))) - (temp (and (not (cl-const-expr-p arg1)) (gensym "--arg1--"))) - (rargs (list* (or temp arg1) (nth 2 method) args))) - (list 'let* (append (and temp (list (list temp arg1))) (car method)) - (cl-setf-do-store (nth 1 method) - (if (symbolp func) (cons func rargs) - (list* 'funcall (list 'function func) - rargs))))))) - -(defmacro define-modify-macro (name arglist func &optional doc) - "(define-modify-macro NAME ARGLIST FUNC): 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 (memq '&key arglist) (error "&key not allowed in define-modify-macro")) - (let ((place (gensym "--place--"))) - (list 'defmacro* name (cons place arglist) doc - (list* (if (memq '&rest arglist) 'list* 'list) - '(quote callf) (list 'quote func) place - (cl-arglist-args arglist))))) - - -;;; Structures. - -(defmacro defstruct (struct &rest descs) - "(defstruct (NAME OPTIONS...) (SLOT SLOT-OPTS...)...): define a struct type. -This macro defines a new Lisp data type called NAME, which contains data -stored in SLOTs. This defines a `make-NAME' constructor, a `copy-NAME' -copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." - (let* ((name (if (consp struct) (car struct) struct)) - (opts (cdr-safe struct)) - (slots nil) - (defaults nil) - (conc-name (concat (symbol-name name) "-")) - (constructor (intern (format "make-%s" name))) - (constrs nil) - (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)) - (include nil) - (tag (intern (format "cl-struct-%s" name))) - (tag-symbol (intern (format "cl-struct-%s-tags" name))) - (include-descs nil) - (side-eff nil) - (type nil) - (named nil) - (forms nil) - pred-form pred-check) - (if (stringp (car descs)) - (cl-push (list 'put (list 'quote name) '(quote structure-documentation) - (cl-pop descs)) forms)) - (setq descs (cons '(cl-tag-slot) - (mapcar (function (lambda (x) (if (consp x) x (list x)))) - descs))) - (while opts - (let ((opt (if (consp (car opts)) (caar opts) (car opts))) - (args (cdr-safe (cl-pop opts)))) - (cond ((eq opt ':conc-name) - (if args - (setq conc-name (if (car args) - (symbol-name (car args)) "")))) - ((eq opt ':constructor) - (if (cdr args) - (cl-push args constrs) - (if args (setq constructor (car args))))) - ((eq opt ':copier) - (if args (setq copier (car args)))) - ((eq opt ':predicate) - (if args (setq predicate (car args)))) - ((eq opt ':include) - (setq include (car args) - include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) - (cdr args)))) - ((eq opt ':print-function) - (setq print-func (car args))) - ((eq opt ':type) - (setq type (car args))) - ((eq opt ':named) - (setq named t)) - ((eq opt ':initial-offset) - (setq descs (nconc (make-list (car args) '(cl-skip-slot)) - descs))) - (t - (error "Slot option %s unrecognized" opt))))) - (if print-func - (setq print-func (list 'progn - (list 'funcall (list 'function print-func) - 'cl-x 'cl-s 'cl-n) t)) - (or type (and include (not (get include 'cl-struct-print))) - (setq print-auto t - print-func (and (or (not (or include type)) (null print-func)) - (list 'progn - (list 'princ (format "#S(%s" name) - 'cl-s)))))) - (if include - (let ((inc-type (get include 'cl-struct-type)) - (old-descs (get include 'cl-struct-slots))) - (or inc-type (error "%s is not a struct name" include)) - (and type (not (eq (car inc-type) type)) - (error ":type disagrees with :include for %s" name)) - (while include-descs - (setcar (memq (or (assq (caar include-descs) old-descs) - (error "No slot %s in included struct %s" - (caar include-descs) include)) - old-descs) - (cl-pop include-descs))) - (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) - type (car inc-type) - named (assq 'cl-tag-slot descs)) - (if (cadr inc-type) (setq tag name named t)) - (let ((incl include)) - (while incl - (cl-push (list 'pushnew (list 'quote tag) - (intern (format "cl-struct-%s-tags" incl))) - forms) - (setq incl (get incl 'cl-struct-include))))) - (if type - (progn - (or (memq type '(vector list)) - (error "Illegal :type specifier: %s" type)) - (if named (setq tag name))) - (setq type 'vector named 'true))) - (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) - (cl-push (list 'defvar tag-symbol) forms) - (setq pred-form (and named - (let ((pos (- (length descs) - (length (memq (assq 'cl-tag-slot descs) - descs))))) - (if (eq type 'vector) - (list 'and '(vectorp cl-x) - (list '>= '(length cl-x) (length descs)) - (list 'memq (list 'aref 'cl-x pos) - tag-symbol)) - (if (= pos 0) - (list 'memq '(car-safe cl-x) tag-symbol) - (list 'and '(consp cl-x) - (list 'memq (list 'nth pos 'cl-x) - tag-symbol)))))) - pred-check (and pred-form (> safety 0) - (if (and (eq (caadr pred-form) 'vectorp) - (= safety 1)) - (cons 'and (cdddr pred-form)) pred-form))) - (let ((pos 0) (descp descs)) - (while descp - (let* ((desc (cl-pop descp)) - (slot (car desc))) - (if (memq slot '(cl-tag-slot cl-skip-slot)) - (progn - (cl-push nil slots) - (cl-push (and (eq slot 'cl-tag-slot) (list 'quote tag)) - defaults)) - (if (assq slot descp) - (error "Duplicate slots named %s in %s" slot name)) - (let ((accessor (intern (format "%s%s" conc-name slot)))) - (cl-push slot slots) - (cl-push (nth 1 desc) defaults) - (cl-push (list* - 'defsubst* accessor '(cl-x) - (append - (and pred-check - (list (list 'or pred-check - (list 'error - (format "%s accessing a non-%s" - accessor name) - 'cl-x)))) - (list (if (eq type 'vector) (list 'aref 'cl-x pos) - (if (= pos 0) '(car cl-x) - (list 'nth pos 'cl-x)))))) forms) - (cl-push (cons accessor t) side-eff) - (cl-push (list 'define-setf-method accessor '(cl-x) - (if (cadr (memq ':read-only (cddr desc))) - (list 'error (format "%s is a read-only slot" - accessor)) - (list 'cl-struct-setf-expander 'cl-x - (list 'quote name) (list 'quote accessor) - (and pred-check (list 'quote pred-check)) - pos))) - forms) - (if print-auto - (nconc print-func - (list (list 'princ (format " %s" slot) 'cl-s) - (list 'prin1 (list accessor 'cl-x) 'cl-s))))))) - (setq pos (1+ pos)))) - (setq slots (nreverse slots) - defaults (nreverse defaults)) - (and predicate pred-form - (progn (cl-push (list 'defsubst* predicate '(cl-x) - (if (eq (car pred-form) 'and) - (append pred-form '(t)) - (list 'and pred-form t))) forms) - (cl-push (cons predicate 'error-free) side-eff))) - (and copier - (progn (cl-push (list 'defun copier '(x) '(copy-sequence x)) forms) - (cl-push (cons copier t) side-eff))) - (if constructor - (cl-push (list constructor - (cons '&key (delq nil (copy-sequence slots)))) - constrs)) - (while constrs - (let* ((name (caar constrs)) - (args (cadr (cl-pop constrs))) - (anames (cl-arglist-args args)) - (make (mapcar* (function (lambda (s d) (if (memq s anames) s d))) - slots defaults))) - (cl-push (list 'defsubst* name - (list* '&cl-defs (list 'quote (cons nil descs)) args) - (cons type make)) forms) - (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs))) - (cl-push (cons name t) side-eff)))) - (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) - (if print-func - (cl-push (list 'push - (list 'function - (list 'lambda '(cl-x cl-s cl-n) - (list 'and pred-form print-func))) - 'custom-print-functions) forms)) - (cl-push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) - (cl-push (list* 'eval-when '(compile load eval) - (list 'put (list 'quote name) '(quote cl-struct-slots) - (list 'quote descs)) - (list 'put (list 'quote name) '(quote cl-struct-type) - (list 'quote (list type (eq named t)))) - (list 'put (list 'quote name) '(quote cl-struct-include) - (list 'quote include)) - (list 'put (list 'quote name) '(quote cl-struct-print) - print-auto) - (mapcar (function (lambda (x) - (list 'put (list 'quote (car x)) - '(quote side-effect-free) - (list 'quote (cdr x))))) - side-eff)) - forms) - (cons 'progn (nreverse (cons (list 'quote name) forms))))) - -(defun cl-struct-setf-expander (x name accessor pred-form pos) - (let* ((temp (gensym "--x--")) (store (gensym "--store--"))) - (list (list temp) (list x) (list store) - (append '(progn) - (and pred-form - (list (list 'or (subst temp 'cl-x pred-form) - (list 'error - (format - "%s storing a non-%s" accessor name) - temp)))) - (list (if (eq (car (get name 'cl-struct-type)) 'vector) - (list 'aset temp pos store) - (list 'setcar - (if (<= pos 5) - (let ((xx temp)) - (while (>= (setq pos (1- pos)) 0) - (setq xx (list 'cdr xx))) - xx) - (list 'nthcdr pos temp)) - store)))) - (list accessor temp)))) - - -;;; Types and assertions. - -(defmacro deftype (name args &rest body) - "(deftype NAME ARGLIST BODY...): define NAME as a new data type. -The type name can then be used in `typecase', `check-type', etc." - (list 'eval-when '(compile load eval) - (cl-transform-function-property - name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) args) body)))) - -(defun cl-make-type-test (val type) - (if (memq type '(character string-char)) (setq type '(integer 0 255))) - (if (symbolp type) - (cond ((get type 'cl-deftype-handler) - (cl-make-type-test val (funcall (get type 'cl-deftype-handler)))) - ((memq type '(nil t)) type) - ((eq type 'null) (list 'null val)) - ((eq type 'float) (list 'floatp-safe val)) - ((eq type 'real) (list 'numberp val)) - ((eq type 'fixnum) (list 'integerp val)) - (t - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (if (fboundp namep) (list namep val) - (list (intern (concat name "-p")) val))))) - (cond ((get (car type) 'cl-deftype-handler) - (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler) - (cdr type)))) - ((memq (car-safe type) '(integer float real number)) - (delq t (list 'and (cl-make-type-test val (car type)) - (if (memq (cadr type) '(* nil)) t - (if (consp (cadr type)) (list '> val (caadr type)) - (list '>= val (cadr type)))) - (if (memq (caddr type) '(* nil)) t - (if (consp (caddr type)) (list '< val (caaddr type)) - (list '<= val (caddr type))))))) - ((memq (car-safe type) '(and or not)) - (cons (car type) - (mapcar (function (lambda (x) (cl-make-type-test val x))) - (cdr type)))) - ((memq (car-safe type) '(member member*)) - (list 'and (list 'member* val (list 'quote (cdr type))) t)) - ((eq (car-safe type) 'satisfies) (list (cadr type) val)) - (t (error "Bad type spec: %s" type))))) - -(defun typep (val type) ; See compiler macro below. - "Check that OBJECT is of type TYPE. -TYPE is a Common Lisp-style type specifier." - (eval (cl-make-type-test 'val type))) - -(defmacro check-type (form type &optional string) - "Verify that FORM is of type TYPE; signal an error if not. -STRING is an optional description of the desired type." - (and (or (not (cl-compiling-file)) - (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let* ((temp (if (cl-simple-expr-p form 3) form (gensym))) - (body (list 'or (cl-make-type-test temp type) - (list 'signal '(quote wrong-type-argument) - (list 'list (or string (list 'quote type)) - temp (list 'quote form)))))) - (if (eq temp form) (list 'progn body nil) - (list 'let (list (list temp form)) body nil))))) - -(defmacro assert (form &optional show-args string &rest args) - "Verify that FORM returns non-nil; signal an error if not. -Second arg SHOW-ARGS means to include arguments of FORM in message. -Other args STRING and ARGS... are arguments to be passed to `error'. -They are not evaluated unless the assertion fails. If STRING is -omitted, a default message listing FORM itself is used." - (and (or (not (cl-compiling-file)) - (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let ((sargs (and show-args (delq nil (mapcar - (function - (lambda (x) - (and (not (cl-const-expr-p x)) - x))) (cdr form)))))) - (list 'progn - (list 'or form - (if string - (list* 'error string (append sargs args)) - (list 'signal '(quote cl-assertion-failed) - (list* 'list (list 'quote form) sargs)))) - nil)))) - -(defmacro ignore-errors (&rest body) - "Execute FORMS; if an error occurs, return nil. -Otherwise, return result of last FORM." - (let ((err (gensym))) - (list 'condition-case err (cons 'progn body) '(error nil)))) - - -;;; Some predicates for analyzing Lisp forms. These are used by various -;;; macro expanders to optimize the results in certain common cases. - -(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max - car-safe cdr-safe progn prog1 prog2)) -(defconst cl-safe-funcs '(* / % length memq list vector vectorp - < > <= >= = error)) - -;;; Check if no side effects, and executes quickly. -(defun cl-simple-expr-p (x &optional size) - (or size (setq size 10)) - (if (and (consp x) (not (memq (car x) '(quote function function*)))) - (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) - (get (car x) 'side-effect-free)) - (progn - (setq size (1- size)) - (while (and (setq x (cdr x)) - (setq size (cl-simple-expr-p (car x) size)))) - (and (null x) (>= size 0) size))) - (and (> size 0) (1- size)))) - -(defun cl-simple-exprs-p (xs) - (while (and xs (cl-simple-expr-p (car xs))) - (setq xs (cdr xs))) - (not xs)) - -;;; Check if no side effects. -(defun cl-safe-expr-p (x) - (or (not (and (consp x) (not (memq (car x) '(quote function function*))))) - (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) - (memq (car x) cl-safe-funcs) - (get (car x) 'side-effect-free)) - (progn - (while (and (setq x (cdr x)) (cl-safe-expr-p (car x)))) - (null x))))) - -;;; Check if constant (i.e., no side effects or dependencies). -(defun cl-const-expr-p (x) - (cond ((consp x) - (or (eq (car x) 'quote) - (and (memq (car x) '(function function*)) - (or (symbolp (nth 1 x)) - (and (eq (car-safe (nth 1 x)) 'lambda) 'func))))) - ((symbolp x) (and (memq x '(nil t)) t)) - (t t))) - -(defun cl-const-exprs-p (xs) - (while (and xs (cl-const-expr-p (car xs))) - (setq xs (cdr xs))) - (not xs)) - -(defun cl-const-expr-val (x) - (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) - -(defun cl-expr-access-order (x v) - (if (cl-const-expr-p x) v - (if (consp x) - (progn - (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v))) - v) - (if (eq x (car v)) (cdr v) '(t))))) - -;;; Count number of times X refers to Y. Return NIL for 0 times. -(defun cl-expr-contains (x y) - (cond ((equal y x) 1) - ((and (consp x) (not (memq (car-safe x) '(quote function function*)))) - (let ((sum 0)) - (while x - (setq sum (+ sum (or (cl-expr-contains (cl-pop x) y) 0)))) - (and (> sum 0) sum))) - (t nil))) - -(defun cl-expr-contains-any (x y) - (while (and y (not (cl-expr-contains x (car y)))) (cl-pop y)) - y) - -;;; Check whether X may depend on any of the symbols in Y. -(defun cl-expr-depends-p (x y) - (and (not (cl-const-expr-p x)) - (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y)))) - - -;;; Compiler macros. - -(defmacro define-compiler-macro (func args &rest body) - "(define-compiler-macro FUNC ARGLIST BODY...): Define a compiler-only macro. -This is like `defmacro', but macro expansion occurs only if the call to -FUNC is compiled (i.e., not interpreted). Compiler macros should be used -for optimizing the way calls to FUNC are compiled; the form returned by -BODY should do the same thing as a call to the normal function called -FUNC, though possibly more efficiently. Note that, like regular macros, -compiler macros are expanded repeatedly until no further expansions are -possible. Unlike regular macros, BODY can decide to \"punt\" and leave the -original function call alone by declaring an initial `&whole foo' parameter -and then returning foo." - (let ((p (if (listp args) args (list '&rest args))) (res nil)) - (while (consp p) (cl-push (cl-pop p) res)) - (setq args (nreverse res)) (setcdr res (and p (list '&rest p)))) - (list 'eval-when '(compile load eval) - (cl-transform-function-property - func 'cl-compiler-macro - (cons (if (memq '&whole args) (delq '&whole args) - (cons '--cl-whole-arg-- args)) body)) - (list 'or (list 'get (list 'quote func) '(quote byte-compile)) - (list 'put (list 'quote func) '(quote byte-compile) - '(quote cl-byte-compile-compiler-macro))))) - -(defun compiler-macroexpand (form) - (while - (let ((func (car-safe form)) (handler nil)) - (while (and (symbolp func) - (not (setq handler (get func 'cl-compiler-macro))) - (fboundp func) - (or (not (eq (car-safe (symbol-function func)) 'autoload)) - (load (nth 1 (symbol-function func))))) - (setq func (symbol-function func))) - (and handler - (not (eq form (setq form (apply handler form (cdr form)))))))) - form) - -(defun cl-byte-compile-compiler-macro (form) - (if (eq form (setq form (compiler-macroexpand form))) - (byte-compile-normal-call form) - (byte-compile-form form))) - -(defmacro defsubst* (name args &rest body) - "(defsubst* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. -Like `defun', except the function is automatically declared `inline', -ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (block NAME ...)." - (let* ((argns (cl-arglist-args args)) (p argns) - (pbody (cons 'progn body)) - (unsafe (not (cl-safe-expr-p pbody)))) - (while (and p (eq (cl-expr-contains args (car p)) 1)) (cl-pop p)) - (list 'progn - (if p nil ; give up if defaults refer to earlier args - (list 'define-compiler-macro name - (list* '&whole 'cl-whole '&cl-quote args) - (list* 'cl-defsubst-expand (list 'quote argns) - (list 'quote (list* 'block name body)) - (not (or unsafe (cl-expr-access-order pbody argns))) - (and (memq '&key args) 'cl-whole) unsafe argns))) - (list* 'defun* name args body)))) - -(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) - (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole - (if (cl-simple-exprs-p argvs) (setq simple t)) - (let ((lets (delq nil - (mapcar* (function - (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) - (progn (setq body (subst argv argn body)) - (and unsafe (list argn argv))) - (list argn argv)))) - argns argvs)))) - (if lets (list 'let lets body) body)))) - - -;;; Compile-time optimizations for some functions defined in this package. -;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, -;;; mainly to make sure these macros will be present. - -(put 'eql 'byte-compile nil) -(define-compiler-macro eql (&whole form a b) - (cond ((eq (cl-const-expr-p a) t) - (let ((val (cl-const-expr-val a))) - (if (and (numberp val) (not (integerp val))) - (list 'equal a b) - (list 'eq a b)))) - ((eq (cl-const-expr-p b) t) - (let ((val (cl-const-expr-val b))) - (if (and (numberp val) (not (integerp val))) - (list 'equal a b) - (list 'eq a b)))) - ((cl-simple-expr-p a 5) - (list 'if (list 'numberp a) - (list 'equal a b) - (list 'eq a b))) - ((and (cl-safe-expr-p a) - (cl-simple-expr-p b 5)) - (list 'if (list 'numberp b) - (list 'equal a b) - (list 'eq a b))) - (t form))) - -(define-compiler-macro member* (&whole form a list &rest keys) - (let ((test (and (= (length keys) 2) (eq (car keys) ':test) - (cl-const-expr-val (nth 1 keys))))) - (cond ((eq test 'eq) (list 'memq a list)) - ((eq test 'equal) (list 'member a list)) - ((or (null keys) (eq test 'eql)) - (if (eq (cl-const-expr-p a) t) - (list (if (floatp-safe (cl-const-expr-val a)) 'member 'memq) - a list) - (if (eq (cl-const-expr-p list) t) - (let ((p (cl-const-expr-val list)) (mb nil) (mq nil)) - (if (not (cdr p)) - (and p (list 'eql a (list 'quote (car p)))) - (while p - (if (floatp-safe (car p)) (setq mb t) - (or (integerp (car p)) (symbolp (car p)) (setq mq t))) - (setq p (cdr p))) - (if (not mb) (list 'memq a list) - (if (not mq) (list 'member a list) form)))) - form))) - (t form)))) - -(define-compiler-macro assoc* (&whole form a list &rest keys) - (let ((test (and (= (length keys) 2) (eq (car keys) ':test) - (cl-const-expr-val (nth 1 keys))))) - (cond ((eq test 'eq) (list 'assq a list)) - ((eq test 'equal) (list 'assoc a list)) - ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql))) - (if (floatp-safe (cl-const-expr-val a)) - (list 'assoc a list) (list 'assq a list))) - (t form)))) - -(define-compiler-macro adjoin (&whole form a list &rest keys) - (if (and (cl-simple-expr-p a) (cl-simple-expr-p list) - (not (memq ':key keys))) - (list 'if (list* 'member* a list keys) list (list 'cons a list)) - form)) - -(define-compiler-macro list* (arg &rest others) - (let* ((args (reverse (cons arg others))) - (form (car args))) - (while (setq args (cdr args)) - (setq form (list 'cons (car args) form))) - form)) - -(define-compiler-macro get* (sym prop &optional def) - (if def - (list 'getf (list 'symbol-plist sym) prop def) - (list 'get sym prop))) - -(define-compiler-macro typep (&whole form val type) - (if (cl-const-expr-p type) - (let ((res (cl-make-type-test val (cl-const-expr-val type)))) - (if (or (memq (cl-expr-contains res val) '(nil 1)) - (cl-simple-expr-p val)) res - (let ((temp (gensym))) - (list 'let (list (list temp val)) (subst temp val res))))) - form)) - - -(mapcar (function - (lambda (y) - (put (car y) 'side-effect-free t) - (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) - (put (car y) 'cl-compiler-macro - (list 'lambda '(w x) - (if (symbolp (cadr y)) - (list 'list (list 'quote (cadr y)) - (list 'list (list 'quote (caddr y)) 'x)) - (cons 'list (cdr y))))))) - '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) - (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) - (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) - (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) - (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) - (caaar car caar) (caadr car cadr) (cadar car cdar) - (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) - (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) - (caaadr car caadr) (caadar car cadar) (caaddr car caddr) - (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) - (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) - (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) - (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) - -;;; Things that are inline. -(proclaim '(inline floatp-safe acons map concatenate notany notevery - cl-set-elt revappend nreconc gethash)) - -;;; Things that are side-effect-free. -(mapcar (function (lambda (x) (put x 'side-effect-free t))) - '(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm - isqrt floor* ceiling* truncate* round* mod* rem* subseq - list-length get* getf gethash hash-table-count)) - -;;; Things that are side-effect-and-error-free. -(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) - '(eql floatp-safe list* subst acons equalp random-state-p - copy-tree sublis hash-table-p)) - - -(run-hooks 'cl-macs-load-hook) - -;;; cl-macs.el ends here diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el deleted file mode 100644 index eaac88a4e22..00000000000 --- a/lisp/emacs-lisp/cl-seq.el +++ /dev/null @@ -1,919 +0,0 @@ -;;; cl-seq.el --- Common Lisp features, part 3 -*-byte-compile-dynamic: t;-*- - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains the Common Lisp sequence and list functions -;; which take keyword arguments. - -;; See cl.el for Change Log. - - -;;; Code: - -(or (memq 'cl-19 features) - (error "Tried to load `cl-seq' before `cl'!")) - - -;;; We define these here so that this file can compile without having -;;; loaded the cl.el file already. - -(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) -(defmacro cl-pop (place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) - - -;;; Keyword parsing. This is special-cased here so that we can compile -;;; this file independent from cl-macs. - -(defmacro cl-parsing-keywords (kwords other-keys &rest body) - (cons - 'let* - (cons (mapcar - (function - (lambda (x) - (let* ((var (if (consp x) (car x) x)) - (mem (list 'car (list 'cdr (list 'memq (list 'quote var) - 'cl-keys))))) - (if (eq var ':test-not) - (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) - (if (eq var ':if-not) - (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) - (list (intern - (format "cl-%s" (substring (symbol-name var) 1))) - (if (consp x) (list 'or mem (car (cdr x))) mem))))) - kwords) - (append - (and (not (eq other-keys t)) - (list - (list 'let '((cl-keys-temp cl-keys)) - (list 'while 'cl-keys-temp - (list 'or (list 'memq '(car cl-keys-temp) - (list 'quote - (mapcar - (function - (lambda (x) - (if (consp x) - (car x) x))) - (append kwords - other-keys)))) - '(car (cdr (memq (quote :allow-other-keys) - cl-keys))) - '(error "Bad keyword argument %s" - (car cl-keys-temp))) - '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) - body)))) -(put 'cl-parsing-keywords 'lisp-indent-function 2) -(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) - -(defmacro cl-check-key (x) - (list 'if 'cl-key (list 'funcall 'cl-key x) x)) - -(defmacro cl-check-test-nokey (item x) - (list 'cond - (list 'cl-test - (list 'eq (list 'not (list 'funcall 'cl-test item x)) - 'cl-test-not)) - (list 'cl-if - (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not)) - (list 't (list 'if (list 'numberp item) - (list 'equal item x) (list 'eq item x))))) - -(defmacro cl-check-test (item x) - (list 'cl-check-test-nokey item (list 'cl-check-key x))) - -(defmacro cl-check-match (x y) - (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) - (list 'if 'cl-test - (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) - (list 'if (list 'numberp x) - (list 'equal x y) (list 'eq x y)))) - -(put 'cl-check-key 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) -(put 'cl-check-match 'edebug-form-spec 'edebug-forms) - -(defvar cl-test) (defvar cl-test-not) -(defvar cl-if) (defvar cl-if-not) -(defvar cl-key) - - -(defun reduce (cl-func cl-seq &rest cl-keys) - "Reduce two-argument FUNCTION across SEQUENCE. -Keywords supported: :start :end :from-end :initial-value :key" - (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () - (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) - (setq cl-seq (subseq cl-seq cl-start cl-end)) - (if cl-from-end (setq cl-seq (nreverse cl-seq))) - (let ((cl-accum (cond ((memq ':initial-value cl-keys) cl-initial-value) - (cl-seq (cl-check-key (cl-pop cl-seq))) - (t (funcall cl-func))))) - (if cl-from-end - (while cl-seq - (setq cl-accum (funcall cl-func (cl-check-key (cl-pop cl-seq)) - cl-accum))) - (while cl-seq - (setq cl-accum (funcall cl-func cl-accum - (cl-check-key (cl-pop cl-seq)))))) - cl-accum))) - -(defun fill (seq item &rest cl-keys) - "Fill the elements of SEQ with ITEM. -Keywords supported: :start :end" - (cl-parsing-keywords ((:start 0) :end) () - (if (listp seq) - (let ((p (nthcdr cl-start seq)) - (n (if cl-end (- cl-end cl-start) 8000000))) - (while (and p (>= (setq n (1- n)) 0)) - (setcar p item) - (setq p (cdr p)))) - (or cl-end (setq cl-end (length seq))) - (if (and (= cl-start 0) (= cl-end (length seq))) - (fillarray seq item) - (while (< cl-start cl-end) - (aset seq cl-start item) - (setq cl-start (1+ cl-start))))) - seq)) - -(defun replace (cl-seq1 cl-seq2 &rest cl-keys) - "Replace the elements of SEQ1 with the elements of SEQ2. -SEQ1 is destructively modified, then returned. -Keywords supported: :start1 :end1 :start2 :end2" - (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () - (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) - (or (= cl-start1 cl-start2) - (let* ((cl-len (length cl-seq1)) - (cl-n (min (- (or cl-end1 cl-len) cl-start1) - (- (or cl-end2 cl-len) cl-start2)))) - (while (>= (setq cl-n (1- cl-n)) 0) - (cl-set-elt cl-seq1 (+ cl-start1 cl-n) - (elt cl-seq2 (+ cl-start2 cl-n)))))) - (if (listp cl-seq1) - (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) - (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000))) - (if (listp cl-seq2) - (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) - (cl-n (min cl-n1 - (if cl-end2 (- cl-end2 cl-start2) 4000000)))) - (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0)) - (setcar cl-p1 (car cl-p2)) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) - (setq cl-end2 (min (or cl-end2 (length cl-seq2)) - (+ cl-start2 cl-n1))) - (while (and cl-p1 (< cl-start2 cl-end2)) - (setcar cl-p1 (aref cl-seq2 cl-start2)) - (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) - (setq cl-end1 (min (or cl-end1 (length cl-seq1)) - (+ cl-start1 (- (or cl-end2 (length cl-seq2)) - cl-start2)))) - (if (listp cl-seq2) - (let ((cl-p2 (nthcdr cl-start2 cl-seq2))) - (while (< cl-start1 cl-end1) - (aset cl-seq1 cl-start1 (car cl-p2)) - (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1)))) - (while (< cl-start1 cl-end1) - (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2)) - (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))) - cl-seq1)) - -(defun remove* (cl-item cl-seq &rest cl-keys) - "Remove all occurrences of ITEM in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :test :test-not :key :count :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end - (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) - cl-seq - (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) - (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end - cl-from-end))) - (if cl-i - (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) - (append (if cl-from-end - (list ':end (1+ cl-i)) - (list ':start cl-i)) - cl-keys)))) - (if (listp cl-seq) cl-res - (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) - cl-seq)) - (setq cl-end (- (or cl-end 8000000) cl-start)) - (if (= cl-start 0) - (while (and cl-seq (> cl-end 0) - (cl-check-test cl-item (car cl-seq)) - (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) - (> (setq cl-count (1- cl-count)) 0)))) - (if (and (> cl-count 0) (> cl-end 0)) - (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) - (setq cl-end (1- cl-end)) (cdr cl-seq)))) - (while (and cl-p (> cl-end 0) - (not (cl-check-test cl-item (car cl-p)))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end))) - (if (and cl-p (> cl-end 0)) - (nconc (ldiff cl-seq cl-p) - (if (= cl-count 1) (cdr cl-p) - (and (cdr cl-p) - (apply 'delete* cl-item - (copy-sequence (cdr cl-p)) - ':start 0 ':end (1- cl-end) - ':count (1- cl-count) cl-keys)))) - cl-seq)) - cl-seq))))) - -(defun remove-if (cl-pred cl-list &rest cl-keys) - "Remove all items satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end" - (apply 'remove* nil cl-list ':if cl-pred cl-keys)) - -(defun remove-if-not (cl-pred cl-list &rest cl-keys) - "Remove all items not satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end" - (apply 'remove* nil cl-list ':if-not cl-pred cl-keys)) - -(defun delete* (cl-item cl-seq &rest cl-keys) - "Remove all occurrences of ITEM in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :test :test-not :key :count :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end - (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) - cl-seq - (if (listp cl-seq) - (if (and cl-from-end (< cl-count 4000000)) - (let (cl-i) - (while (and (>= (setq cl-count (1- cl-count)) 0) - (setq cl-i (cl-position cl-item cl-seq cl-start - cl-end cl-from-end))) - (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) - (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) - (setcdr cl-tail (cdr (cdr cl-tail))))) - (setq cl-end cl-i)) - cl-seq) - (setq cl-end (- (or cl-end 8000000) cl-start)) - (if (= cl-start 0) - (progn - (while (and cl-seq - (> cl-end 0) - (cl-check-test cl-item (car cl-seq)) - (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) - (> (setq cl-count (1- cl-count)) 0))) - (setq cl-end (1- cl-end))) - (setq cl-start (1- cl-start))) - (if (and (> cl-count 0) (> cl-end 0)) - (let ((cl-p (nthcdr cl-start cl-seq))) - (while (and (cdr cl-p) (> cl-end 0)) - (if (cl-check-test cl-item (car (cdr cl-p))) - (progn - (setcdr cl-p (cdr (cdr cl-p))) - (if (= (setq cl-count (1- cl-count)) 0) - (setq cl-end 1))) - (setq cl-p (cdr cl-p))) - (setq cl-end (1- cl-end))))) - cl-seq) - (apply 'remove* cl-item cl-seq cl-keys))))) - -(defun delete-if (cl-pred cl-list &rest cl-keys) - "Remove all items satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end" - (apply 'delete* nil cl-list ':if cl-pred cl-keys)) - -(defun delete-if-not (cl-pred cl-list &rest cl-keys) - "Remove all items not satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end" - (apply 'delete* nil cl-list ':if-not cl-pred cl-keys)) - -(or (and (fboundp 'delete) (subrp (symbol-function 'delete))) - (defalias 'delete (function (lambda (x y) (delete* x y ':test 'equal))))) -(defun remove (x y) (remove* x y ':test 'equal)) -(defun remq (x y) (if (memq x y) (delq x (copy-list y)) y)) - -(defun remove-duplicates (cl-seq &rest cl-keys) - "Return a copy of SEQ with all duplicate elements removed. -Keywords supported: :test :test-not :key :start :end :from-end" - (cl-delete-duplicates cl-seq cl-keys t)) - -(defun delete-duplicates (cl-seq &rest cl-keys) - "Remove all duplicate elements from SEQ (destructively). -Keywords supported: :test :test-not :key :start :end :from-end" - (cl-delete-duplicates cl-seq cl-keys nil)) - -(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) - () - (if cl-from-end - (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) - (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) - (while (> cl-end 1) - (setq cl-i 0) - (while (setq cl-i (cl-position (cl-check-key (car cl-p)) - (cdr cl-p) cl-i (1- cl-end))) - (if cl-copy (setq cl-seq (copy-sequence cl-seq) - cl-p (nthcdr cl-start cl-seq) cl-copy nil)) - (let ((cl-tail (nthcdr cl-i cl-p))) - (setcdr cl-tail (cdr (cdr cl-tail)))) - (setq cl-end (1- cl-end))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end) - cl-start (1+ cl-start))) - cl-seq) - (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) - (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) - (cl-position (cl-check-key (car cl-seq)) - (cdr cl-seq) 0 (1- cl-end))) - (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) - (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) - (setq cl-end (1- cl-end) cl-start 1) cl-seq))) - (while (and (cdr (cdr cl-p)) (> cl-end 1)) - (if (cl-position (cl-check-key (car (cdr cl-p))) - (cdr (cdr cl-p)) 0 (1- cl-end)) - (progn - (if cl-copy (setq cl-seq (copy-sequence cl-seq) - cl-p (nthcdr (1- cl-start) cl-seq) - cl-copy nil)) - (setcdr cl-p (cdr (cdr cl-p)))) - (setq cl-p (cdr cl-p))) - (setq cl-end (1- cl-end) cl-start (1+ cl-start))) - cl-seq))) - (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) - (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) - -(defun substitute (cl-new cl-old cl-seq &rest cl-keys) - "Substitute NEW for OLD in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :test :test-not :key :count :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count - (:start 0) :end :from-end) () - (if (or (eq cl-old cl-new) - (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) - cl-seq - (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) - (if (not cl-i) - cl-seq - (setq cl-seq (copy-sequence cl-seq)) - (or cl-from-end - (progn (cl-set-elt cl-seq cl-i cl-new) - (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) - (apply 'nsubstitute cl-new cl-old cl-seq ':count cl-count - ':start cl-i cl-keys)))))) - -(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end" - (apply 'substitute cl-new nil cl-list ':if cl-pred cl-keys)) - -(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items not satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end" - (apply 'substitute cl-new nil cl-list ':if-not cl-pred cl-keys)) - -(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) - "Substitute NEW for OLD in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :test :test-not :key :count :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count - (:start 0) :end :from-end) () - (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) - (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) - (let ((cl-p (nthcdr cl-start cl-seq))) - (setq cl-end (- (or cl-end 8000000) cl-start)) - (while (and cl-p (> cl-end 0) (> cl-count 0)) - (if (cl-check-test cl-old (car cl-p)) - (progn - (setcar cl-p cl-new) - (setq cl-count (1- cl-count)))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) - (or cl-end (setq cl-end (length cl-seq))) - (if cl-from-end - (while (and (< cl-start cl-end) (> cl-count 0)) - (setq cl-end (1- cl-end)) - (if (cl-check-test cl-old (elt cl-seq cl-end)) - (progn - (cl-set-elt cl-seq cl-end cl-new) - (setq cl-count (1- cl-count))))) - (while (and (< cl-start cl-end) (> cl-count 0)) - (if (cl-check-test cl-old (aref cl-seq cl-start)) - (progn - (aset cl-seq cl-start cl-new) - (setq cl-count (1- cl-count)))) - (setq cl-start (1+ cl-start)))))) - cl-seq)) - -(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end" - (apply 'nsubstitute cl-new nil cl-list ':if cl-pred cl-keys)) - -(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items not satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end" - (apply 'nsubstitute cl-new nil cl-list ':if-not cl-pred cl-keys)) - -(defun find (cl-item cl-seq &rest cl-keys) - "Find the first occurrence of ITEM in LIST. -Return the matching ITEM, or nil if not found. -Keywords supported: :test :test-not :key :start :end :from-end" - (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) - (and cl-pos (elt cl-seq cl-pos)))) - -(defun find-if (cl-pred cl-list &rest cl-keys) - "Find the first item satisfying PREDICATE in LIST. -Return the matching ITEM, or nil if not found. -Keywords supported: :key :start :end :from-end" - (apply 'find nil cl-list ':if cl-pred cl-keys)) - -(defun find-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item not satisfying PREDICATE in LIST. -Return the matching ITEM, or nil if not found. -Keywords supported: :key :start :end :from-end" - (apply 'find nil cl-list ':if-not cl-pred cl-keys)) - -(defun position (cl-item cl-seq &rest cl-keys) - "Find the first occurrence of ITEM in LIST. -Return the index of the matching item, or nil if not found. -Keywords supported: :test :test-not :key :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not - (:start 0) :end :from-end) () - (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) - -(defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) - (if (listp cl-seq) - (let ((cl-p (nthcdr cl-start cl-seq))) - (or cl-end (setq cl-end 8000000)) - (let ((cl-res nil)) - (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) - (if (cl-check-test cl-item (car cl-p)) - (setq cl-res cl-start)) - (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) - cl-res)) - (or cl-end (setq cl-end (length cl-seq))) - (if cl-from-end - (progn - (while (and (>= (setq cl-end (1- cl-end)) cl-start) - (not (cl-check-test cl-item (aref cl-seq cl-end))))) - (and (>= cl-end cl-start) cl-end)) - (while (and (< cl-start cl-end) - (not (cl-check-test cl-item (aref cl-seq cl-start)))) - (setq cl-start (1+ cl-start))) - (and (< cl-start cl-end) cl-start)))) - -(defun position-if (cl-pred cl-list &rest cl-keys) - "Find the first item satisfying PREDICATE in LIST. -Return the index of the matching item, or nil if not found. -Keywords supported: :key :start :end :from-end" - (apply 'position nil cl-list ':if cl-pred cl-keys)) - -(defun position-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item not satisfying PREDICATE in LIST. -Return the index of the matching item, or nil if not found. -Keywords supported: :key :start :end :from-end" - (apply 'position nil cl-list ':if-not cl-pred cl-keys)) - -(defun count (cl-item cl-seq &rest cl-keys) - "Count the number of occurrences of ITEM in LIST. -Keywords supported: :test :test-not :key :start :end" - (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () - (let ((cl-count 0) cl-x) - (or cl-end (setq cl-end (length cl-seq))) - (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) - (while (< cl-start cl-end) - (setq cl-x (if (consp cl-seq) (cl-pop cl-seq) (aref cl-seq cl-start))) - (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) - (setq cl-start (1+ cl-start))) - cl-count))) - -(defun count-if (cl-pred cl-list &rest cl-keys) - "Count the number of items satisfying PREDICATE in LIST. -Keywords supported: :key :start :end" - (apply 'count nil cl-list ':if cl-pred cl-keys)) - -(defun count-if-not (cl-pred cl-list &rest cl-keys) - "Count the number of items not satisfying PREDICATE in LIST. -Keywords supported: :key :start :end" - (apply 'count nil cl-list ':if-not cl-pred cl-keys)) - -(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) - "Compare SEQ1 with SEQ2, return index of first mismatching element. -Return nil if the sequences match. If one sequence is a prefix of the -other, the return value indicates the end of the shorted sequence. -Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" - (cl-parsing-keywords (:test :test-not :key :from-end - (:start1 0) :end1 (:start2 0) :end2) () - (or cl-end1 (setq cl-end1 (length cl-seq1))) - (or cl-end2 (setq cl-end2 (length cl-seq2))) - (if cl-from-end - (progn - (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (elt cl-seq1 (1- cl-end1)) - (elt cl-seq2 (1- cl-end2)))) - (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) - (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) - (1- cl-end1))) - (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) - (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) - (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (if cl-p1 (car cl-p1) - (aref cl-seq1 cl-start1)) - (if cl-p2 (car cl-p2) - (aref cl-seq2 cl-start2)))) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) - cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) - (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) - cl-start1))))) - -(defun search (cl-seq1 cl-seq2 &rest cl-keys) - "Search for SEQ1 as a subsequence of SEQ2. -Return the index of the leftmost element of the first match found; -return nil if there are no matches. -Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" - (cl-parsing-keywords (:test :test-not :key :from-end - (:start1 0) :end1 (:start2 0) :end2) () - (or cl-end1 (setq cl-end1 (length cl-seq1))) - (or cl-end2 (setq cl-end2 (length cl-seq2))) - (if (>= cl-start1 cl-end1) - (if cl-from-end cl-end2 cl-start2) - (let* ((cl-len (- cl-end1 cl-start1)) - (cl-first (cl-check-key (elt cl-seq1 cl-start1))) - (cl-if nil) cl-pos) - (setq cl-end2 (- cl-end2 (1- cl-len))) - (while (and (< cl-start2 cl-end2) - (setq cl-pos (cl-position cl-first cl-seq2 - cl-start2 cl-end2 cl-from-end)) - (apply 'mismatch cl-seq1 cl-seq2 - ':start1 (1+ cl-start1) ':end1 cl-end1 - ':start2 (1+ cl-pos) ':end2 (+ cl-pos cl-len) - ':from-end nil cl-keys)) - (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) - (and (< cl-start2 cl-end2) cl-pos))))) - -(defun sort* (cl-seq cl-pred &rest cl-keys) - "Sort the argument SEQUENCE according to PREDICATE. -This is a destructive function; it reuses the storage of SEQUENCE if possible. -Keywords supported: :key" - (if (nlistp cl-seq) - (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys)) - (cl-parsing-keywords (:key) () - (if (memq cl-key '(nil identity)) - (sort cl-seq cl-pred) - (sort cl-seq (function (lambda (cl-x cl-y) - (funcall cl-pred (funcall cl-key cl-x) - (funcall cl-key cl-y))))))))) - -(defun stable-sort (cl-seq cl-pred &rest cl-keys) - "Sort the argument SEQUENCE stably according to PREDICATE. -This is a destructive function; it reuses the storage of SEQUENCE if possible. -Keywords supported: :key" - (apply 'sort* cl-seq cl-pred cl-keys)) - -(defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) - "Destructively merge the two sequences to produce a new sequence. -TYPE is the sequence type to return, SEQ1 and SEQ2 are the two -argument sequences, and PRED is a `less-than' predicate on the elements. -Keywords supported: :key" - (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) - (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) - (cl-parsing-keywords (:key) () - (let ((cl-res nil)) - (while (and cl-seq1 cl-seq2) - (if (funcall cl-pred (cl-check-key (car cl-seq2)) - (cl-check-key (car cl-seq1))) - (cl-push (cl-pop cl-seq2) cl-res) - (cl-push (cl-pop cl-seq1) cl-res))) - (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) - -;;; See compiler macro in cl-macs.el -(defun member* (cl-item cl-list &rest cl-keys) - "Find the first occurrence of ITEM in LIST. -Return the sublist of LIST whose car is ITEM. -Keywords supported: :test :test-not :key" - (if cl-keys - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) - (setq cl-list (cdr cl-list))) - cl-list) - (if (and (numberp cl-item) (not (integerp cl-item))) - (member cl-item cl-list) - (memq cl-item cl-list)))) - -(defun member-if (cl-pred cl-list &rest cl-keys) - "Find the first item satisfying PREDICATE in LIST. -Return the sublist of LIST whose car matches. -Keywords supported: :key" - (apply 'member* nil cl-list ':if cl-pred cl-keys)) - -(defun member-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item not satisfying PREDICATE in LIST. -Return the sublist of LIST whose car matches. -Keywords supported: :key" - (apply 'member* nil cl-list ':if-not cl-pred cl-keys)) - -(defun cl-adjoin (cl-item cl-list &rest cl-keys) - (if (cl-parsing-keywords (:key) t - (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) - cl-list - (cons cl-item cl-list))) - -;;; See compiler macro in cl-macs.el -(defun assoc* (cl-item cl-alist &rest cl-keys) - "Find the first item whose car matches ITEM in LIST. -Keywords supported: :test :test-not :key" - (if cl-keys - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-alist - (or (not (consp (car cl-alist))) - (not (cl-check-test cl-item (car (car cl-alist)))))) - (setq cl-alist (cdr cl-alist))) - (and cl-alist (car cl-alist))) - (if (and (numberp cl-item) (not (integerp cl-item))) - (assoc cl-item cl-alist) - (assq cl-item cl-alist)))) - -(defun assoc-if (cl-pred cl-list &rest cl-keys) - "Find the first item whose car satisfies PREDICATE in LIST. -Keywords supported: :key" - (apply 'assoc* nil cl-list ':if cl-pred cl-keys)) - -(defun assoc-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item whose car does not satisfy PREDICATE in LIST. -Keywords supported: :key" - (apply 'assoc* nil cl-list ':if-not cl-pred cl-keys)) - -(defun rassoc* (cl-item cl-alist &rest cl-keys) - "Find the first item whose cdr matches ITEM in LIST. -Keywords supported: :test :test-not :key" - (if (or cl-keys (numberp cl-item)) - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-alist - (or (not (consp (car cl-alist))) - (not (cl-check-test cl-item (cdr (car cl-alist)))))) - (setq cl-alist (cdr cl-alist))) - (and cl-alist (car cl-alist))) - (rassq cl-item cl-alist))) - -(defun rassoc-if (cl-pred cl-list &rest cl-keys) - "Find the first item whose cdr satisfies PREDICATE in LIST. -Keywords supported: :key" - (apply 'rassoc* nil cl-list ':if cl-pred cl-keys)) - -(defun rassoc-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item whose cdr does not satisfy PREDICATE in LIST. -Keywords supported: :key" - (apply 'rassoc* nil cl-list ':if-not cl-pred cl-keys)) - -(defun union (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-union operation. -The result list contains all items that appear in either LIST1 or LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) cl-list1) - (t - (or (>= (length cl-list1) (length cl-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 'adjoin (car cl-list2) cl-list1 cl-keys)) - (or (memq (car cl-list2) cl-list1) - (cl-push (car cl-list2) cl-list1))) - (cl-pop cl-list2)) - cl-list1))) - -(defun nunion (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-union operation. -The result list contains all items that appear in either LIST1 or LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - (t (apply 'union cl-list1 cl-list2 cl-keys)))) - -(defun intersection (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-intersection operation. -The result list contains all items that appear in both LIST1 and LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key" - (and cl-list1 cl-list2 - (if (equal cl-list1 cl-list2) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) - (let ((cl-res nil)) - (or (>= (length cl-list1) (length cl-list2)) - (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) - (while cl-list2 - (if (if (or cl-keys (numberp (car cl-list2))) - (apply 'member* (cl-check-key (car cl-list2)) - cl-list1 cl-keys) - (memq (car cl-list2) cl-list1)) - (cl-push (car cl-list2) cl-res)) - (cl-pop cl-list2)) - cl-res))))) - -(defun nintersection (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-intersection operation. -The result list contains all items that appear in both LIST1 and LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key" - (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) - -(defun set-difference (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-difference operation. -The result list contains all items that appear in LIST1 but not LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key" - (if (or (null cl-list1) (null cl-list2)) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) - (let ((cl-res nil)) - (while cl-list1 - (or (if (or cl-keys (numberp (car cl-list1))) - (apply 'member* (cl-check-key (car cl-list1)) - cl-list2 cl-keys) - (memq (car cl-list1) cl-list2)) - (cl-push (car cl-list1) cl-res)) - (cl-pop cl-list1)) - cl-res)))) - -(defun nset-difference (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-difference operation. -The result list contains all items that appear in LIST1 but not LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key" - (if (or (null cl-list1) (null cl-list2)) cl-list1 - (apply 'set-difference cl-list1 cl-list2 cl-keys))) - -(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-exclusive-or operation. -The result list contains all items that appear in exactly one of LIST1, LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) nil) - (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys) - (apply 'set-difference cl-list2 cl-list1 cl-keys))))) - -(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-exclusive-or operation. -The result list contains all items that appear in exactly one of LIST1, LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) nil) - (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys) - (apply 'nset-difference cl-list2 cl-list1 cl-keys))))) - -(defun subsetp (cl-list1 cl-list2 &rest cl-keys) - "True if LIST1 is a subset of LIST2. -I.e., if every element of LIST1 also appears in LIST2. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) t) ((null cl-list2) nil) - ((equal cl-list1 cl-list2) t) - (t (cl-parsing-keywords (:key) (:test :test-not) - (while (and cl-list1 - (apply 'member* (cl-check-key (car cl-list1)) - cl-list2 cl-keys)) - (cl-pop cl-list1)) - (null cl-list1))))) - -(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). -Return a copy of TREE with all matching elements replaced by NEW. -Keywords supported: :key" - (apply 'sublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) - -(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). -Return a copy of TREE with all non-matching elements replaced by NEW. -Keywords supported: :key" - (apply 'sublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) - -(defun nsubst (cl-new cl-old cl-tree &rest cl-keys) - "Substitute NEW for OLD everywhere in TREE (destructively). -Any element of TREE which is `eql' to OLD is changed to NEW (via a call -to `setcar'). -Keywords supported: :test :test-not :key" - (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) - -(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elements matching PREDICATE in TREE (destructively). -Any element of TREE which matches is changed to NEW (via a call to `setcar'). -Keywords supported: :key" - (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) - -(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elements not matching PREDICATE in TREE (destructively). -Any element of TREE which matches is changed to NEW (via a call to `setcar'). -Keywords supported: :key" - (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) - -(defun sublis (cl-alist cl-tree &rest cl-keys) - "Perform substitutions indicated by ALIST in TREE (non-destructively). -Return a copy of TREE with all matching elements replaced. -Keywords supported: :test :test-not :key" - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (cl-sublis-rec cl-tree))) - -(defvar cl-alist) -(defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if* - (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist)) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p (cdr (car cl-p)) - (if (consp cl-tree) - (let ((cl-a (cl-sublis-rec (car cl-tree))) - (cl-d (cl-sublis-rec (cdr cl-tree)))) - (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) - cl-tree - (cons cl-a cl-d))) - cl-tree)))) - -(defun nsublis (cl-alist cl-tree &rest cl-keys) - "Perform substitutions indicated by ALIST in TREE (destructively). -Any matching element of TREE is changed via a call to `setcar'. -Keywords supported: :test :test-not :key" - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (let ((cl-hold (list cl-tree))) - (cl-nsublis-rec cl-hold) - (car cl-hold)))) - -(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* - (while (consp cl-tree) - (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist)) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p (setcar cl-tree (cdr (car cl-p))) - (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree)))) - (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p - (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) - (setq cl-tree (cdr cl-tree)))))) - -(defun tree-equal (cl-x cl-y &rest cl-keys) - "T if trees X and Y have `eql' leaves. -Atoms are compared by `eql'; cons cells are compared recursively. -Keywords supported: :test :test-not :key" - (cl-parsing-keywords (:test :test-not :key) () - (cl-tree-equal-rec cl-x cl-y))) - -(defun cl-tree-equal-rec (cl-x cl-y) - (while (and (consp cl-x) (consp cl-y) - (cl-tree-equal-rec (car cl-x) (car cl-y))) - (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) - (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) - - -(run-hooks 'cl-seq-load-hook) - -;;; cl-seq.el ends here diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el deleted file mode 100644 index 38497b26765..00000000000 --- a/lisp/emacs-lisp/cl-specs.el +++ /dev/null @@ -1,472 +0,0 @@ -;;; cl-specs.el --- Edebug specs for cl.el - -;; Copyright (C) 1993 Free Software Foundation, Inc. -;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> -;; Keywords: lisp, tools, maint - -;; LCD Archive Entry: -;; cl-specs.el|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |Edebug specs for cl.el -;; |$Date: 1996/01/05 21:56:25 $|1.1| - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;;; Commentary: - -;; These specs are to be used with edebug.el version 3.3 or later and -;; cl.el version 2.03 or later, by Dave Gillespie <daveg@synaptics.com>. - -;; This file need not be byte-compiled, but it shouldn't hurt. - -(provide 'cl-specs) -;; Do the above provide before the following require. -;; Otherwise if you load this before edebug if cl is already loaded -;; an infinite loading loop would occur. -(require 'edebug) - -;; Blocks - -(def-edebug-spec block (symbolp body)) -(def-edebug-spec return (&optional form)) -(def-edebug-spec return-from (symbolp &optional form)) - -;; Loops - -(def-edebug-spec when t) -(def-edebug-spec unless t) -(def-edebug-spec case (form &rest (sexp body))) -(def-edebug-spec ecase case) -(def-edebug-spec do - ((&rest &or symbolp (symbolp &optional form form)) - (form body) - cl-declarations body)) -(def-edebug-spec do* do) -(def-edebug-spec dolist - ((symbolp form &optional form) cl-declarations body)) -(def-edebug-spec dotimes dolist) -(def-edebug-spec do-symbols - ((symbolp &optional form form) cl-declarations body)) -(def-edebug-spec do-all-symbols - ((symbolp &optional form) cl-declarations body)) - -;; Multiple values - -(def-edebug-spec multiple-value-list (form)) -(def-edebug-spec multiple-value-call (function-form body)) -(def-edebug-spec multiple-value-bind - ((&rest symbolp) form cl-declarations body)) -(def-edebug-spec multiple-value-setq ((&rest symbolp) form)) -(def-edebug-spec multiple-value-prog1 (form body)) - -;; Bindings - -(def-edebug-spec lexical-let let) -(def-edebug-spec lexical-let* let) - -(def-edebug-spec psetq setq) -(def-edebug-spec progv (form form body)) - -(def-edebug-spec flet ((&rest (defun*)) cl-declarations body)) -(def-edebug-spec labels flet) - -(def-edebug-spec macrolet - ((&rest (&define name (&rest arg) cl-declarations-or-string def-body)) - cl-declarations body)) - -(def-edebug-spec symbol-macrolet - ((&rest (symbol sexp)) cl-declarations body)) - -(def-edebug-spec destructuring-bind - (&define cl-macro-list form cl-declarations def-body)) - -;; Setf - -(def-edebug-spec setf (&rest [place form])) ;; sexp is not specific enough -(def-edebug-spec psetf setf) - -(def-edebug-spec letf ;; *not* available in Common Lisp - ((&rest (gate place &optional form)) - body)) -(def-edebug-spec letf* letf) - - -(def-edebug-spec defsetf - (&define name - [&or [symbolp &optional stringp] - [cl-lambda-list (symbolp)]] - cl-declarations-or-string def-body)) - -(def-edebug-spec define-setf-method - (&define name cl-lambda-list cl-declarations-or-string def-body)) - -(def-edebug-spec define-modify-macro - (&define name cl-lambda-list ;; should exclude &key - symbolp &optional stringp)) - -(def-edebug-spec callf (function* place &rest form)) -(def-edebug-spec callf2 (function* form place &rest form)) - -;; Other operations on places - -(def-edebug-spec remf (place form)) - -(def-edebug-spec incf (place &optional form)) -(def-edebug-spec decf incf) -(def-edebug-spec push (form place)) -(def-edebug-spec pushnew - (form place &rest - &or [[&or ":test" ":test-not" ":key"] function-form] - [edebug-keywordp form])) -(def-edebug-spec pop (place)) - -(def-edebug-spec shiftf (&rest place)) ;; really [&rest place] form -(def-edebug-spec rotatef (&rest place)) - - -;; Functions with function args. These are only useful if the -;; function arg is quoted with ' instead of function. - -(def-edebug-spec some (function-form form &rest form)) -(def-edebug-spec every some) -(def-edebug-spec notany some) -(def-edebug-spec notevery some) - -;; Mapping - -(def-edebug-spec map (form function-form form &rest form)) -(def-edebug-spec maplist (function-form form &rest form)) -(def-edebug-spec mapc maplist) -(def-edebug-spec mapl maplist) -(def-edebug-spec mapcan maplist) -(def-edebug-spec mapcon maplist) - -;; Sequences - -(def-edebug-spec reduce (function-form form &rest form)) - -;; Types and assertions - -(def-edebug-spec cl-type-spec (sexp)) ;; not worth the trouble to specify, yet. - -(def-edebug-spec deftype defmacro*) -(def-edebug-spec check-type (place cl-type-spec &optional stringp)) -;; (def-edebug-spec assert (form &optional form stringp &rest form)) -(def-edebug-spec assert (form &rest form)) -(def-edebug-spec typecase (form &rest ([&or cl-type-spec "otherwise"] body))) -(def-edebug-spec etypecase typecase) - -(def-edebug-spec ignore-errors t) - -;; Time of Evaluation - -(def-edebug-spec eval-when - ((&rest &or "compile" "load" "eval") body)) -(def-edebug-spec load-time-value (form &optional &or "t" "nil")) - -;; Declarations - -(def-edebug-spec cl-decl-spec - ((symbolp &rest sexp))) - -(def-edebug-spec cl-declarations - (&rest ("declare" &rest cl-decl-spec))) - -(def-edebug-spec cl-declarations-or-string - (&or stringp cl-declarations)) - -(def-edebug-spec declaim (&rest cl-decl-spec)) -(def-edebug-spec declare (&rest cl-decl-spec)) ;; probably not needed. -(def-edebug-spec locally (cl-declarations &rest form)) -(def-edebug-spec the (cl-type-spec form)) - -;;====================================================== -;; Lambda things - -(def-edebug-spec cl-lambda-list - (([&rest arg] - [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] - [&optional ["&rest" arg]] - [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] - &optional "&allow-other-keywords"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - ))) - -(def-edebug-spec cl-&optional-arg - (&or (arg &optional def-form arg) arg)) - -(def-edebug-spec cl-&key-arg - (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) - -;; The lambda list for macros is different from that of normal lambdas. -;; Note that &environment is only allowed as first or last items in the -;; top level list. - -(def-edebug-spec cl-macro-list - (([&optional "&environment" arg] - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keywords"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - [&optional "&environment" arg] - ))) - -(def-edebug-spec cl-macro-arg - (&or arg cl-macro-list1)) - -(def-edebug-spec cl-macro-list1 - (([&optional "&whole" arg] ;; only allowed at lower levels - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keywords"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - . [&or arg nil]))) - - -(def-edebug-spec defun* - ;; Same as defun but use cl-lambda-list. - (&define [&or name - ("setf" :name setf name)] - cl-lambda-list - cl-declarations-or-string - [&optional ("interactive" interactive)] - def-body)) -(def-edebug-spec defsubst* defun*) - -(def-edebug-spec defmacro* - (&define name cl-macro-list cl-declarations-or-string def-body)) -(def-edebug-spec define-compiler-macro defmacro*) - - -(def-edebug-spec function* - (&or symbolp cl-lambda-expr)) - -(def-edebug-spec cl-lambda-expr - (&define ("lambda" cl-lambda-list - ;;cl-declarations-or-string - ;;[&optional ("interactive" interactive)] - def-body))) - -;; Redefine function-form to also match function* -(def-edebug-spec function-form - ;; form at the end could also handle "function", - ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) - ("function*" cl-lambda-expr) - form)) - -;;====================================================== -;; Structures -;; (def-edebug-spec defstruct (&rest sexp)) would be sufficient, but... - -;; defstruct may contain forms that are evaluated when a structure is created. -(def-edebug-spec defstruct - (&define ; makes top-level form not be wrapped - [&or symbolp - (gate - symbolp &rest - (&or [":conc-name" &or stringp "nil"] - [":constructor" symbolp &optional cl-lambda-list] - [":copier" symbolp] - [":predicate" symbolp] - [":include" symbolp &rest sexp];; not finished - ;; The following are not supported. - ;; [":print-function" ...] - ;; [":type" ...] - ;; [":initial-offset" ...] - ))] - [&optional stringp] - ;; All the above is for the following def-form. - &rest &or symbolp (symbolp def-form &optional ":read-only" sexp))) - -;;====================================================== -;; Loop - -;; The loop macro is very complex, and a full spec is found below. -;; The following spec only minimally specifies that -;; parenthesized forms are executable, but single variables used as -;; expressions will be missed. You may want to use this if the full -;; spec causes problems for you. - -(def-edebug-spec loop - (&rest &or symbolp form)) - -;; Below is a complete spec for loop, in several parts that correspond -;; to the syntax given in CLtL2. The specs do more than specify where -;; the forms are; it also specifies, as much as Edebug allows, all the -;; syntactically legal loop clauses. The disadvantage of this -;; completeness is rigidity, but the "for ... being" clause allows -;; arbitrary extensions of the form: [symbolp &rest &or symbolp form]. - -(def-edebug-spec loop - ([&optional ["named" symbolp]] - [&rest - &or - ["repeat" form] - loop-for-as - loop-with - loop-initial-final] - [&rest loop-clause] - )) - -(def-edebug-spec loop-with - ("with" loop-var - loop-type-spec - [&optional ["=" form]] - &rest ["and" loop-var - loop-type-spec - [&optional ["=" form]]])) - -(def-edebug-spec loop-for-as - ([&or "for" "as"] loop-for-as-subclause - &rest ["and" loop-for-as-subclause])) - -(def-edebug-spec loop-for-as-subclause - (loop-var - loop-type-spec - &or - [[&or "in" "on" "in-ref" "across-ref"] - form &optional ["by" function-form]] - - ["=" form &optional ["then" form]] - ["across" form] - ["being" - [&or "the" "each"] - &or - [[&or "element" "elements"] - [&or "of" "in" "of-ref"] form - &optional "using" ["index" symbolp]];; is this right? - [[&or "hash-key" "hash-keys" - "hash-value" "hash-values"] - [&or "of" "in"] - hash-table-p &optional ["using" ([&or "hash-value" "hash-values" - "hash-key" "hash-keys"] sexp)]] - - [[&or "symbol" "present-symbol" "external-symbol" - "symbols" "present-symbols" "external-symbols"] - [&or "in" "of"] package-p] - - ;; Extensions for Emacs Lisp, including Lucid Emacs. - [[&or "frame" "frames" - "screen" "screens" - "buffer" "buffers"]] - - [[&or "window" "windows"] - [&or "of" "in"] form] - - [[&or "overlay" "overlays" - "extent" "extents"] - [&or "of" "in"] form - &optional [[&or "from" "to"] form]] - - [[&or "interval" "intervals"] - [&or "in" "of"] form - &optional [[&or "from" "to"] form] - ["property" form]] - - [[&or "key-code" "key-codes" - "key-seq" "key-seqs" - "key-binding" "key-bindings"] - [&or "in" "of"] form - &optional ["using" ([&or "key-code" "key-codes" - "key-seq" "key-seqs" - "key-binding" "key-bindings"] - sexp)]] - ;; For arbitrary extensions, recognize anything else. - [symbolp &rest &or symbolp form] - ] - - ;; arithmetic - must be last since all parts are optional. - [[&optional [[&or "from" "downfrom" "upfrom"] form]] - [&optional [[&or "to" "downto" "upto" "below" "above"] form]] - [&optional ["by" form]] - ])) - -(def-edebug-spec loop-initial-final - (&or ["initially" - ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. - &rest loop-non-atomic-expr] - ["finally" &or - [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] - ["return" form]])) - -(def-edebug-spec loop-and-clause - (loop-clause &rest ["and" loop-clause])) - -(def-edebug-spec loop-clause - (&or - [[&or "while" "until" "always" "never" "thereis"] form] - - [[&or "collect" "collecting" - "append" "appending" - "nconc" "nconcing" - "concat" "vconcat"] form - [&optional ["into" loop-var]]] - - [[&or "count" "counting" - "sum" "summing" - "maximize" "maximizing" - "minimize" "minimizing"] form - [&optional ["into" loop-var]] - loop-type-spec] - - [[&or "if" "when" "unless"] - form loop-and-clause - [&optional ["else" loop-and-clause]] - [&optional "end"]] - - [[&or "do" "doing"] &rest loop-non-atomic-expr] - - ["return" form] - loop-initial-final - )) - -(def-edebug-spec loop-non-atomic-expr - ([¬ atom] form)) - -(def-edebug-spec loop-var - ;; The symbolp must be last alternative to recognize e.g. (a b . c) - ;; loop-var => - ;; (loop-var . [&or nil loop-var]) - ;; (symbolp . [&or nil loop-var]) - ;; (symbolp . loop-var) - ;; (symbolp . (symbolp . [&or nil loop-var])) - ;; (symbolp . (symbolp . loop-var)) - ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp) - (&or (loop-var . [&or nil loop-var]) [gate symbolp])) - -(def-edebug-spec loop-type-spec - (&optional ["of-type" loop-d-type-spec])) - -(def-edebug-spec loop-d-type-spec - (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) - diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el deleted file mode 100644 index 29ec602f231..00000000000 --- a/lisp/emacs-lisp/cl.el +++ /dev/null @@ -1,765 +0,0 @@ -;;; cl.el --- Common Lisp extensions for Emacs -*-byte-compile-dynamic: t;-*- - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains the portions of the Common Lisp extensions -;; package which should always be present. - - -;;; Future notes: - -;; Once Emacs 19 becomes standard, many things in this package which are -;; messy for reasons of compatibility can be greatly simplified. For now, -;; I prefer to maintain one unified version. - - -;;; Change Log: - -;; Version 2.02 (30 Jul 93): -;; * Added "cl-compat.el" file, extra compatibility with old package. -;; * Added `lexical-let' and `lexical-let*'. -;; * Added `define-modify-macro', `callf', and `callf2'. -;; * Added `ignore-errors'. -;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero. -;; * Merged `*gentemp-counter*' into `*gensym-counter*'. -;; * Extended `subseq' to allow negative START and END like `substring'. -;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses. -;; * Added `concat', `vconcat' loop clauses. -;; * Cleaned up a number of compiler warnings. - -;; Version 2.01 (7 Jul 93): -;; * Added support for FSF version of Emacs 19. -;; * Added `add-hook' for Emacs 18 users. -;; * Added `defsubst*' and `symbol-macrolet'. -;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'. -;; * Added `map', `concatenate', `reduce', `merge'. -;; * Added `revappend', `nreconc', `tailp', `tree-equal'. -;; * Added `assert', `check-type', `typecase', `typep', and `deftype'. -;; * Added destructuring and `&environment' support to `defmacro*'. -;; * Added destructuring to `loop', and added the following clauses: -;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'. -;; * Renamed `delete' to `delete*' and `remove' to `remove*'. -;; * Completed support for all keywords in `remove*', `substitute', etc. -;; * Added `most-positive-float' and company. -;; * Fixed hash tables to work with latest Lucid Emacs. -;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'. -;; * Syntax for `warn' declarations has changed. -;; * Improved implementation of `random*'. -;; * Moved most sequence functions to a new file, cl-seq.el. -;; * Moved `eval-when' into cl-macs.el. -;; * Moved `pushnew' and `adjoin' to cl.el for most common cases. -;; * Moved `provide' forms down to ends of files. -;; * Changed expansion of `pop' to something that compiles to better code. -;; * Changed so that no patch is required for Emacs 19 byte compiler. -;; * Made more things dependent on `optimize' declarations. -;; * Added a partial implementation of struct print functions. -;; * Miscellaneous minor changes. - -;; Version 2.00: -;; * First public release of this package. - - -;;; Code: - -(defvar cl-emacs-type (cond ((or (and (fboundp 'epoch::version) - (symbol-value 'epoch::version)) - (string-lessp emacs-version "19")) 18) - ((string-match "Lucid" emacs-version) 'lucid) - (t 19))) - -(or (fboundp 'defalias) (fset 'defalias 'fset)) - -(defvar cl-optimize-speed 1) -(defvar cl-optimize-safety 1) - - -;;; Keywords used in this package. - -(defconst :test ':test) -(defconst :test-not ':test-not) -(defconst :key ':key) -(defconst :start ':start) -(defconst :start1 ':start1) -(defconst :start2 ':start2) -(defconst :end ':end) -(defconst :end1 ':end1) -(defconst :end2 ':end2) -(defconst :count ':count) -(defconst :initial-value ':initial-value) -(defconst :size ':size) -(defconst :from-end ':from-end) -(defconst :rehash-size ':rehash-size) -(defconst :rehash-threshold ':rehash-threshold) -(defconst :allow-other-keys ':allow-other-keys) - - -(defvar custom-print-functions nil - "This is a list of functions that format user objects for printing. -Each function is called in turn with three arguments: the object, the -stream, and the print level (currently ignored). If it is able to -print the object it returns true; otherwise it returns nil and the -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.") - - -;;; Predicates. - -(defun eql (a b) ; See compiler macro in cl-macs.el - "T if the two args are the same Lisp object. -Floating-point numbers of equal value are `eql', but they may not be `eq'." - (if (numberp a) - (equal a b) - (eq a b))) - - -;;; Generalized variables. These macros are defined here so that they -;;; can safely be used in .emacs files. - -(defmacro incf (place &optional x) - "(incf PLACE [X]): increment PLACE by X (1 by default). -PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the incremented value of PLACE." - (if (symbolp place) - (list 'setq place (if x (list '+ place x) (list '1+ place))) - (list 'callf '+ place (or x 1)))) - -(defmacro decf (place &optional x) - "(decf PLACE [X]): decrement PLACE by X (1 by default). -PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the decremented value of PLACE." - (if (symbolp place) - (list 'setq place (if x (list '- place x) (list '1- place))) - (list 'callf '- place (or x 1)))) - -(defmacro pop (place) - "(pop PLACE): remove and return the head of the list stored in PLACE. -Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more -careful about evaluating each argument only once and in the right order. -PLACE may be a symbol, or any generalized variable allowed by `setf'." - (if (symbolp place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) - (cl-do-pop place))) - -(defmacro push (x place) - "(push X PLACE): insert X at the head of the list stored in PLACE. -Analogous to (setf PLACE (cons X PLACE)), though more careful about -evaluating each argument only once and in the right order. PLACE may -be a symbol, or any generalized variable allowed by `setf'." - (if (symbolp place) (list 'setq place (list 'cons x place)) - (list 'callf2 'cons x place))) - -(defmacro pushnew (x place &rest keys) - "(pushnew X PLACE): insert X at the head of the list if not already there. -Like (push X PLACE), except that the list is unmodified if X is `eql' to -an element already on the list. -Keywords supported: :test :test-not :key" - (if (symbolp place) (list 'setq place (list* 'adjoin x place keys)) - (list* 'callf2 'adjoin x place keys))) - -(defun cl-set-elt (seq n val) - (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) - -(defun cl-set-nthcdr (n list x) - (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) - -(defun cl-set-buffer-substring (start end val) - (save-excursion (delete-region start end) - (goto-char start) - (insert val) - val)) - -(defun cl-set-substring (str start end val) - (if end (if (< end 0) (incf end (length str))) - (setq end (length str))) - (if (< start 0) (incf start str)) - (concat (and (> start 0) (substring str 0 start)) - val - (and (< end (length str)) (substring str end)))) - - -;;; Control structures. - -;;; These macros are so simple and so often-used that it's better to have -;;; them all the time than to load them from cl-macs.el. - -(defmacro when (cond &rest body) - "(when COND BODY...): if COND yields non-nil, do BODY, else return nil." - (list 'if cond (cons 'progn body))) - -(defmacro unless (cond &rest body) - "(unless COND BODY...): if COND yields nil, do BODY, else return nil." - (cons 'if (cons cond (cons nil body)))) - -(defun cl-map-extents (&rest cl-args) - (if (fboundp 'next-overlay-at) (apply 'cl-map-overlays cl-args) - (if (fboundp 'map-extents) (apply 'map-extents cl-args)))) - - -;;; Blocks and exits. - -(defalias 'cl-block-wrapper 'identity) -(defalias 'cl-block-throw 'throw) - - -;;; Multiple values. True multiple values are not supported, or even -;;; simulated. Instead, multiple-value-bind and friends simply expect -;;; the target form to return the values as a list. - -(defalias 'values 'list) -(defalias 'values-list 'identity) -(defalias 'multiple-value-list 'identity) -(defalias 'multiple-value-call 'apply) ; only works for one arg -(defalias 'nth-value 'nth) - - -;;; Macros. - -(defvar cl-macro-environment nil) -(defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand) - (defalias 'macroexpand 'cl-macroexpand))) - -(defun cl-macroexpand (cl-macro &optional cl-env) - "Return result of expanding macros at top level of FORM. -If FORM is not a macro call, it is returned unchanged. -Otherwise, the macro is expanded and the expansion is considered -in place of FORM. When a non-macro-call results, it is returned. - -The second optional arg ENVIRONMENT species an environment of macro -definitions to shadow the loaded ones for use in file byte-compilation." - (let ((cl-macro-environment cl-env)) - (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) - (and (symbolp cl-macro) - (cdr (assq (symbol-name cl-macro) cl-env)))) - (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) - cl-macro)) - - -;;; Declarations. - -(defvar cl-compiling-file nil) -(defun cl-compiling-file () - (or cl-compiling-file - (and (boundp 'outbuffer) (bufferp (symbol-value 'outbuffer)) - (equal (buffer-name (symbol-value 'outbuffer)) - " *Compiler Output*")))) - -(defvar cl-proclaims-deferred nil) - -(defun proclaim (spec) - (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) - (push spec cl-proclaims-deferred)) - nil) - -(defmacro declaim (&rest specs) - (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x)))) - specs))) - (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body) - (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when - - -;;; Symbols. - -(defun cl-random-time () - (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) - (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i)))) - v)) - -(defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) - - -;;; Numbers. - -(defun floatp-safe (x) - "T if OBJECT is a floating point number. -On Emacs versions that lack floating-point support, this function -always returns nil." - (and (numberp x) (not (integerp x)))) - -(defun plusp (x) - "T if NUMBER is positive." - (> x 0)) - -(defun minusp (x) - "T if NUMBER is negative." - (< x 0)) - -(defun oddp (x) - "T if INTEGER is odd." - (eq (logand x 1) 1)) - -(defun evenp (x) - "T if INTEGER is even." - (eq (logand x 1) 0)) - -(defun cl-abs (x) - "Return the absolute value of ARG." - (if (>= x 0) x (- x))) -(or (fboundp 'abs) (defalias 'abs 'cl-abs)) ; This is built-in to Emacs 19 - -(defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) - -;;; We use `eval' in case VALBITS differs from compile-time to load-time. -(defconst most-positive-fixnum (eval '(lsh -1 -1))) -(defconst most-negative-fixnum (eval '(- -1 (lsh -1 -1)))) - -;;; The following are actually set by cl-float-limits. -(defconst most-positive-float nil) -(defconst most-negative-float nil) -(defconst least-positive-float nil) -(defconst least-negative-float nil) -(defconst least-positive-normalized-float nil) -(defconst least-negative-normalized-float nil) -(defconst float-epsilon nil) -(defconst float-negative-epsilon nil) - - -;;; Sequence functions. - -(defalias 'copy-seq 'copy-sequence) - -(defun mapcar* (cl-func cl-x &rest cl-rest) - "Apply FUNCTION to each element of SEQ, and make a list of the results. -If there are several SEQs, FUNCTION is called with that many arguments, -and mapping stops as soon as the shortest list runs out. With just one -SEQ, this is like `mapcar'. With several, it is like the Common Lisp -`mapcar' function extended to arbitrary sequence types." - (if cl-rest - (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) - (cl-mapcar-many cl-func (cons cl-x cl-rest)) - (let ((cl-res nil) (cl-y (car cl-rest))) - (while (and cl-x cl-y) - (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) - (nreverse cl-res))) - (mapcar cl-func cl-x))) - - -;;; List functions. - -(defalias 'first 'car) -(defalias 'rest 'cdr) -(defalias 'endp 'null) - -(defun second (x) - "Return the second element of the list LIST." - (car (cdr x))) - -(defun third (x) - "Return the third element of the list LIST." - (car (cdr (cdr x)))) - -(defun fourth (x) - "Return the fourth element of the list LIST." - (nth 3 x)) - -(defun fifth (x) - "Return the fifth element of the list LIST." - (nth 4 x)) - -(defun sixth (x) - "Return the sixth element of the list LIST." - (nth 5 x)) - -(defun seventh (x) - "Return the seventh element of the list LIST." - (nth 6 x)) - -(defun eighth (x) - "Return the eighth element of the list LIST." - (nth 7 x)) - -(defun ninth (x) - "Return the ninth element of the list LIST." - (nth 8 x)) - -(defun tenth (x) - "Return the tenth element of the list LIST." - (nth 9 x)) - -(defun caar (x) - "Return the `car' of the `car' of X." - (car (car x))) - -(defun cadr (x) - "Return the `car' of the `cdr' of X." - (car (cdr x))) - -(defun cdar (x) - "Return the `cdr' of the `car' of X." - (cdr (car x))) - -(defun cddr (x) - "Return the `cdr' of the `cdr' of X." - (cdr (cdr x))) - -(defun caaar (x) - "Return the `car' of the `car' of the `car' of X." - (car (car (car x)))) - -(defun caadr (x) - "Return the `car' of the `car' of the `cdr' of X." - (car (car (cdr x)))) - -(defun cadar (x) - "Return the `car' of the `cdr' of the `car' of X." - (car (cdr (car x)))) - -(defun caddr (x) - "Return the `car' of the `cdr' of the `cdr' of X." - (car (cdr (cdr x)))) - -(defun cdaar (x) - "Return the `cdr' of the `car' of the `car' of X." - (cdr (car (car x)))) - -(defun cdadr (x) - "Return the `cdr' of the `car' of the `cdr' of X." - (cdr (car (cdr x)))) - -(defun cddar (x) - "Return the `cdr' of the `cdr' of the `car' of X." - (cdr (cdr (car x)))) - -(defun cdddr (x) - "Return the `cdr' of the `cdr' of the `cdr' of X." - (cdr (cdr (cdr x)))) - -(defun caaaar (x) - "Return the `car' of the `car' of the `car' of the `car' of X." - (car (car (car (car x))))) - -(defun caaadr (x) - "Return the `car' of the `car' of the `car' of the `cdr' of X." - (car (car (car (cdr x))))) - -(defun caadar (x) - "Return the `car' of the `car' of the `cdr' of the `car' of X." - (car (car (cdr (car x))))) - -(defun caaddr (x) - "Return the `car' of the `car' of the `cdr' of the `cdr' of X." - (car (car (cdr (cdr x))))) - -(defun cadaar (x) - "Return the `car' of the `cdr' of the `car' of the `car' of X." - (car (cdr (car (car x))))) - -(defun cadadr (x) - "Return the `car' of the `cdr' of the `car' of the `cdr' of X." - (car (cdr (car (cdr x))))) - -(defun caddar (x) - "Return the `car' of the `cdr' of the `cdr' of the `car' of X." - (car (cdr (cdr (car x))))) - -(defun cadddr (x) - "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." - (car (cdr (cdr (cdr x))))) - -(defun cdaaar (x) - "Return the `cdr' of the `car' of the `car' of the `car' of X." - (cdr (car (car (car x))))) - -(defun cdaadr (x) - "Return the `cdr' of the `car' of the `car' of the `cdr' of X." - (cdr (car (car (cdr x))))) - -(defun cdadar (x) - "Return the `cdr' of the `car' of the `cdr' of the `car' of X." - (cdr (car (cdr (car x))))) - -(defun cdaddr (x) - "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." - (cdr (car (cdr (cdr x))))) - -(defun cddaar (x) - "Return the `cdr' of the `cdr' of the `car' of the `car' of X." - (cdr (cdr (car (car x))))) - -(defun cddadr (x) - "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." - (cdr (cdr (car (cdr x))))) - -(defun cdddar (x) - "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." - (cdr (cdr (cdr (car x))))) - -(defun cddddr (x) - "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." - (cdr (cdr (cdr (cdr x))))) - -(defun last (x &optional n) - "Returns the last link in the list LIST. -With optional argument N, returns Nth-to-last link (default 1)." - (if n - (let ((m 0) (p x)) - (while (consp p) (incf m) (pop p)) - (if (<= n 0) p - (if (< n m) (nthcdr (- m n) x) x))) - (while (consp (cdr x)) (pop x)) - x)) - -(defun butlast (x &optional n) - "Returns a copy of LIST with the last N elements removed." - (if (and n (<= n 0)) x - (nbutlast (copy-sequence x) n))) - -(defun nbutlast (x &optional n) - "Modifies LIST to remove the last N elements." - (let ((m (length x))) - (or n (setq n 1)) - (and (< n m) - (progn - (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) - x)))) - -(defun list* (arg &rest rest) ; See compiler macro in cl-macs.el - "Return a new list with specified args as elements, cons'd to last arg. -Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to -`(cons A (cons B (cons C D)))'." - (cond ((not rest) arg) - ((not (cdr rest)) (cons arg (car rest))) - (t (let* ((n (length rest)) - (copy (copy-sequence rest)) - (last (nthcdr (- n 2) copy))) - (setcdr last (car (cdr last))) - (cons arg copy))))) - -(defun ldiff (list sublist) - "Return a copy of LIST with the tail SUBLIST removed." - (let ((res nil)) - (while (and (consp list) (not (eq list sublist))) - (push (pop list) res)) - (nreverse res))) - -(defun copy-list (list) - "Return a copy of a list, which may be a dotted list. -The elements of the list are not copied, just the list structure itself." - (if (consp list) - (let ((res nil)) - (while (consp list) (push (pop list) res)) - (prog1 (nreverse res) (setcdr res list))) - (car list))) - -(defun cl-maclisp-member (item list) - (while (and list (not (equal item (car list)))) (setq list (cdr list))) - list) - -;;; Define an Emacs 19-compatible `member' for the benefit of Emacs 18 users. -(or (and (fboundp 'member) (subrp (symbol-function 'member))) - (defalias 'member 'cl-maclisp-member)) - -(defalias 'cl-member 'memq) ; for compatibility with old CL package -(defalias 'cl-floor 'floor*) -(defalias 'cl-ceiling 'ceiling*) -(defalias 'cl-truncate 'truncate*) -(defalias 'cl-round 'round*) -(defalias 'cl-mod 'mod*) - -(defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs - "Return ITEM consed onto the front of LIST only if it's not already there. -Otherwise, return LIST unmodified. -Keywords supported: :test :test-not :key" - (cond ((or (equal cl-keys '(:test eq)) - (and (null cl-keys) (not (numberp cl-item)))) - (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) - ((or (equal cl-keys '(:test equal)) (null cl-keys)) - (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) - (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) - -(defun subst (cl-new cl-old cl-tree &rest cl-keys) - "Substitute NEW for OLD everywhere in TREE (non-destructively). -Return a copy of TREE with all elements `eql' to OLD replaced by NEW. -Keywords supported: :test :test-not :key" - (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) - (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys) - (cl-do-subst cl-new cl-old cl-tree))) - -(defun cl-do-subst (cl-new cl-old cl-tree) - (cond ((eq cl-tree cl-old) cl-new) - ((consp cl-tree) - (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) - (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) - (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) - cl-tree (cons a d)))) - (t cl-tree))) - -(defun acons (a b c) (cons (cons a b) c)) -(defun pairlis (a b &optional c) (nconc (mapcar* 'cons a b) c)) - - -;;; Miscellaneous. - -(put 'cl-assertion-failed 'error-conditions '(error)) -(put 'cl-assertion-failed 'error-message "Assertion failed") - -;;; This is defined in Emacs 19; define it here for Emacs 18 users. -(defun cl-add-hook (hook func &optional append) - "Add to hook variable HOOK the function FUNC. -FUNC is not added if it already appears on the list stored in HOOK." - (let ((old (and (boundp hook) (symbol-value hook)))) - (and (listp old) (not (eq (car old) 'lambda)) - (setq old (list old))) - (and (not (member func old)) - (set hook (if append (nconc old (list func)) (cons func old)))))) -(or (fboundp 'add-hook) (defalias 'add-hook 'cl-add-hook)) - - -;;; Autoload the other portions of the package. -(mapcar (function - (lambda (set) - (mapcar (function - (lambda (func) - (autoload func (car set) nil nil (nth 1 set)))) - (cddr set)))) - '(("cl-extra" nil - coerce equalp cl-map-keymap maplist mapc mapl mapcan mapcon - cl-map-keymap cl-map-keymap-recursively cl-map-intervals - cl-map-overlays cl-set-frame-visible-p cl-float-limits - gcd lcm isqrt expt floor* ceiling* truncate* round* - mod* rem* signum random* make-random-state random-state-p - subseq concatenate cl-mapcar-many map some every notany - notevery revappend nreconc list-length tailp copy-tree get* getf - cl-set-getf cl-do-remf remprop make-hash-table cl-hash-lookup - gethash cl-puthash remhash clrhash maphash hash-table-p - hash-table-count cl-progv-before cl-prettyexpand - cl-macroexpand-all) - ("cl-seq" nil - reduce fill replace remq remove remove* remove-if remove-if-not - delete delete* delete-if delete-if-not remove-duplicates - delete-duplicates substitute substitute-if substitute-if-not - nsubstitute nsubstitute-if nsubstitute-if-not find find-if - find-if-not position position-if position-if-not count count-if - count-if-not mismatch search sort* stable-sort merge member* - member-if member-if-not cl-adjoin assoc* assoc-if assoc-if-not - rassoc* rassoc rassoc-if rassoc-if-not union nunion intersection - nintersection set-difference nset-difference set-exclusive-or - nset-exclusive-or subsetp subst-if subst-if-not nsubst nsubst-if - nsubst-if-not sublis nsublis tree-equal) - ("cl-macs" nil - gensym gentemp typep cl-do-pop get-setf-method - cl-struct-setf-expander compiler-macroexpand cl-compile-time-init) - ("cl-macs" t - defun* defmacro* function* destructuring-bind eval-when - eval-when-compile load-time-value case ecase typecase etypecase - block return return-from loop do do* dolist dotimes do-symbols - do-all-symbols psetq progv flet labels macrolet symbol-macrolet - lexical-let lexical-let* multiple-value-bind multiple-value-setq - locally the declare define-setf-method defsetf define-modify-macro - setf psetf remf shiftf rotatef letf letf* callf callf2 defstruct - check-type assert ignore-errors define-compiler-macro))) - -;;; Define data for indentation and edebug. -(mapcar (function - (lambda (entry) - (mapcar (function - (lambda (func) - (put func 'lisp-indent-function (nth 1 entry)) - (put func 'lisp-indent-hook (nth 1 entry)) - (or (get func 'edebug-form-spec) - (put func 'edebug-form-spec (nth 2 entry))))) - (car entry)))) - '(((defun* defmacro*) 2) - ((function*) nil - (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) - ((eval-when) 1 (sexp &rest form)) - ((when unless) 1 (&rest form)) - ((declare) nil (&rest sexp)) - ((the) 1 (sexp &rest form)) - ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) - ((block return-from) 1 (sexp &rest form)) - ((return) nil (&optional form)) - ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) - (form &rest form) - &rest form)) - ((dolist dotimes) 1 ((symbolp form &rest form) &rest form)) - ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) - ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) - ((psetq setf psetf) nil edebug-setq-form) - ((progv) 2 (&rest form)) - ((flet labels macrolet) 1 - ((&rest (sexp sexp &rest form)) &rest form)) - ((symbol-macrolet lexical-let lexical-let*) 1 - ((&rest &or symbolp (symbolp form)) &rest form)) - ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) - ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) - ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form)) - ((letf letf*) 1 ((&rest (&rest form)) &rest form)) - ((callf destructuring-bind) 2 (sexp form &rest form)) - ((callf2) 3 (sexp form form &rest form)) - ((loop) nil (&rest &or symbolp form)) - ((ignore-errors) 0 (&rest form)))) - - -;;; This goes here so that cl-macs can find it if it loads right now. -(provide 'cl-19) ; usage: (require 'cl-19 "cl") - - -;;; Things to do after byte-compiler is loaded. -;;; As a side effect, we cause cl-macs to be loaded when compiling, so -;;; that the compiler-macros defined there will be present. - -(defvar cl-hacked-flag nil) -(defun cl-hack-byte-compiler () - (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form)) - (progn - (cl-compile-time-init) ; in cl-macs.el - (setq cl-hacked-flag t)))) - -;;; Try it now in case the compiler has already been loaded. -(cl-hack-byte-compiler) - -;;; Also make a hook in case compiler is loaded after this file. -;;; The compiler doesn't call any hooks when it loads or runs, but -;;; we can take advantage of the fact that emacs-lisp-mode will be -;;; called when the compiler reads in the file to be compiled. -;;; BUG: If the first compilation is `byte-compile' rather than -;;; `byte-compile-file', we lose. Oh, well. -(add-hook 'emacs-lisp-mode-hook 'cl-hack-byte-compiler) - - -;;; The following ensures that packages which expect the old-style cl.el -;;; will be happy with this one. - -(provide 'cl) - -(provide 'mini-cl) ; for Epoch - -(run-hooks 'cl-load-hook) - -;;; cl.el ends here diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el deleted file mode 100644 index f8ba8c04404..00000000000 --- a/lisp/emacs-lisp/copyright.el +++ /dev/null @@ -1,143 +0,0 @@ -;;; copyright.el --- update the copyright notice in current buffer - -;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389 -;; Keywords: maint, tools - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Allows updating the copyright year and above mentioned GPL version manually -;; or when saving a file. Do (add-hook 'write-file-hooks 'copyright-update). - -;;; Code: - -(defvar copyright-limit 2000 - "*Don't try to update copyright beyond this position unless interactive. -`nil' means to search whole buffer.") - - -(defvar copyright-regexp - "\\(\251\\|[Cc]opyright\\s *:?\\s *(C)\\)\\s *\\([1-9][-0-9, ']*[0-9]+\\) " - "*What your copyright notice looks like. -The second \\( \\) construct must match the years.") - - -(defvar copyright-query 'function - "*If non-`nil', ask user before changing copyright. -When this is `function', only ask when called non-interactively.") - - -(defconst copyright-current-year (substring (current-time-string) -4) - "String representing the current year.") - - -;; when modifying this, also modify the comment generated by autoinsert.el -(defconst copyright-current-gpl-version "2" - "String representing the current version of the GPL or `nil'.") - -(defvar copyright-update t) - -;;;###autoload -(defun copyright-update (&optional arg) - "Update the copyright notice at the beginning of the buffer to indicate -the current year. If optional prefix ARG is given replace the years in the -notice rather than adding the current year after them. If necessary and -`copyright-current-gpl-version' is set, the copying permissions following the -copyright, if any, are updated as well." - (interactive "*P") - (if copyright-update - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (if (re-search-forward copyright-regexp copyright-limit t) - (if (string= (buffer-substring (- (match-end 2) 2) (match-end 2)) - (substring copyright-current-year -2)) - () - (backward-char 1) - (if (or (not copyright-query) - (and (eq copyright-query 'function) - (eq this-command 'copyright-update)) - (y-or-n-p (if arg - (concat "Replace copyright year(s) by " - copyright-current-year "? ") - (concat "Add " copyright-current-year - " to copyright? ")))) - (if arg - (progn - (delete-region (match-beginning 1) (match-end 1)) - (insert copyright-current-year)) - (setq arg (save-excursion (skip-chars-backward "0-9"))) - (if (and (eq (% (- (string-to-number - copyright-current-year) - (string-to-number (buffer-substring - (+ (point) arg) - (point)))) - 100) - 1) - (or (eq (char-after (+ (point) arg -1)) ?-) - (eq (char-after (+ (point) arg -2)) ?-))) - (delete-char arg) - (insert ", ") - (if (eq (char-after (+ (point) arg -3)) ?') - (insert ?'))) - (insert (substring copyright-current-year arg)))))) - (goto-char (point-min)) - (and copyright-current-gpl-version - ;; match the GPL version comment in .el files, including the - ;; bilingual Esperanto one in two-column, and in texinfo.tex - (re-search-forward "\\(the Free Software Foundation; either \\|; a\\^u eldono \\([0-9]+\\)a, ? a\\^u (la\\^u via \\)version \\([0-9]+\\), or (at" - copyright-limit t) - (not (string= (buffer-substring (match-beginning 3) (match-end 3)) - copyright-current-gpl-version)) - (or (not copyright-query) - (and (eq copyright-query 'function) - (eq this-command 'copyright-update)) - (y-or-n-p (concat "Replace GPL version by " - copyright-current-gpl-version "? "))) - (progn - (if (match-end 2) - ;; Esperanto bilingual comment in two-column.el - (progn - (delete-region (match-beginning 2) (match-end 2)) - (goto-char (match-beginning 2)) - (insert copyright-current-gpl-version))) - (delete-region (match-beginning 3) (match-end 3)) - (goto-char (match-beginning 3)) - (insert copyright-current-gpl-version)))) - (set (make-local-variable 'copyright-update) nil))) - ;; If a write-file-hook returns non-nil, the file is presumed to be written. - nil) - - -;;;###autoload -(define-skeleton copyright - "Insert a copyright by $ORGANIZATION notice at cursor." - "Company: " - comment-start - "Copyright (C) " copyright-current-year " by " - (or (getenv "ORGANIZATION") - str) - '(if (> (point) copyright-limit) - (message "Copyright extends beyond `copyright-limit' and won't be updated automatically.")) - comment-end) - -;; copyright.el ends here diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el deleted file mode 100644 index 0c80b6c8bdb..00000000000 --- a/lisp/emacs-lisp/cust-print.el +++ /dev/null @@ -1,725 +0,0 @@ -;;; cust-print.el --- handles print-level and print-circle. - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> -;; Adapted-By: ESR -;; Keywords: extensions - -;; LCD Archive Entry: -;; cust-print|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |Handle print-level, print-circle and more. -;; |$Date: 1994/04/05 21:05:09 $|$Revision: 1.14 $| - -;; 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 2, 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; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; =============================== -;;; $Header: $ -;;; $Log: cust-print.el,v $ -;;; Revision 1.14 1994/04/05 21:05:09 liberte -;;; Change install- and uninstall- to -install and -uninstall. -;;; -;;; Revision 1.13 1994/03/24 20:26:05 liberte -;;; Change "internal" to "original" throughout. -;;; (add-custom-printer, delete-custom-printer) replace customizers. -;;; (with-custom-print) new -;;; (custom-prin1-to-string) Made it more robust. -;;; -;;; Revision 1.4 1994/03/23 20:34:29 liberte -;;; * Change "emacs" to "original" - I just can't decide. -;;; -;;; Revision 1.3 1994/02/21 21:25:36 liberte -;;; * Make custom-prin1-to-string more robust when errors occur. -;;; * Change "internal" to "emacs". -;;; -;;; Revision 1.2 1993/11/22 22:36:36 liberte -;;; * Simplified and generalized printer customization. -;;; custom-printers is an alist of (PREDICATE . PRINTER) pairs -;;; for any data types. The PRINTER function should print to -;;; `standard-output' add-custom-printer and delete-custom-printer -;;; change custom-printers. -;;; -;;; * Installation function now called install-custom-print. The -;;; old name is still around for now. -;;; -;;; * New macro with-custom-print (added earlier) - executes like -;;; progn but with custom-print activated temporarily. -;;; -;;; * Cleaned up comments for replacements of standardard printers. -;;; -;;; * Changed custom-prin1-to-string to use a temporary buffer. -;;; -;;; * Option custom-print-vectors (added earlier) - controls whether -;;; vectors should be printed according to print-length and -;;; print-length. Emacs doesnt do this, but cust-print would -;;; otherwise do it only if custom printing is required. -;;; -;;; * Uninterned symbols are treated as non-read-equivalent. -;;; - - -;;; Commentary: - -;; This package provides a general print handler for prin1 and princ -;; that supports print-level and print-circle, and by the way, -;; print-length since the standard routines are being replaced. Also, -;; to print custom types constructed from lists and vectors, use -;; custom-print-list and custom-print-vector. See the documentation -;; strings of these variables for more details. - -;; If the results of your expressions contain circular references to -;; other parts of the same structure, the standard Emacs print -;; subroutines may fail to print with an untrappable error, -;; "Apparently circular structure being printed". If you only use cdr -;; circular lists (where cdrs of lists point back; what is the right -;; term here?), you can limit the length of printing with -;; print-length. But car circular lists and circular vectors generate -;; the above mentioned error in Emacs version 18. Version -;; 19 supports print-level, but it is often useful to get a better -;; print representation of circular and shared structures; the print-circle -;; option may be used to print more concise representations. - -;; There are three main ways to use this package. First, you may -;; replace prin1, princ, and some subroutines that use them by calling -;; install-custom-print so that any use of these functions in -;; Lisp code will be affected; you can later reset with -;; uninstall-custom-print. Second, you may temporarily install -;; these functions with the macro with-custom-print. Third, you -;; could call the custom routines directly, thus only affecting the -;; printing that requires them. - -;; Note that subroutines which call print subroutines directly will -;; not use the custom print functions. In particular, the evaluation -;; functions like eval-region call the print subroutines directly. -;; Therefore, if you evaluate (aref circ-list 0), where circ-list is a -;; circular list rather than an array, aref calls error directly which -;; will jump to the top level instead of printing the circular list. - -;; Uninterned symbols are recognized when print-circle is non-nil, -;; but they are not printed specially here. Use the cl-packages package -;; to print according to print-gensym. - -;; Obviously the right way to implement this custom-print facility is -;; in C or with hooks into the standard printer. Please volunteer -;; since I don't have the time or need. More CL-like printing -;; capabilities could be added in the future. - -;; Implementation design: we want to use the same list and vector -;; processing algorithm for all versions of prin1 and princ, since how -;; the processing is done depends on print-length, print-level, and -;; print-circle. For circle printing, a preprocessing step is -;; required before the final printing. Thanks to Jamie Zawinski -;; for motivation and algorithms. - - -;;; Code: -;;========================================================= - -;; If using cl-packages: - -'(defpackage "cust-print" - (:nicknames "CP" "custom-print") - (:use "el") - (:export - print-level - print-circle - - custom-print-install - custom-print-uninstall - custom-print-installed-p - with-custom-print - - custom-prin1 - custom-princ - custom-prin1-to-string - custom-print - custom-format - custom-message - custom-error - - custom-printers - add-custom-printer - )) - -'(in-package cust-print) - -(require 'backquote) - -;; Emacs 18 doesnt have defalias. -;; Provide def for byte compiler. -(eval-and-compile - (or (fboundp 'defalias) (fset 'defalias 'fset))) - - -;; Variables: -;;========================================================= - -;;(defvar print-length nil -;; "*Controls how many elements of a list, at each level, are printed. -;;This is defined by emacs.") - -(defvar print-level nil - "*Controls how many levels deep a nested data object will print. - -If nil, printing proceeds recursively and may lead to -max-lisp-eval-depth being exceeded or an error may occur: -`Apparently circular structure being printed.' -Also see `print-length' and `print-circle'. - -If non-nil, components at levels equal to or greater than `print-level' -are printed simply as `#'. The object to be printed is at level 0, -and if the object is a list or vector, its top-level components are at -level 1.") - - -(defvar print-circle nil - "*Controls the printing of recursive structures. - -If nil, printing proceeds recursively and may lead to -`max-lisp-eval-depth' being exceeded or an error may occur: -\"Apparently circular structure being printed.\" Also see -`print-length' and `print-level'. - -If non-nil, shared substructures anywhere in the structure are printed -with `#N=' before the first occurrence (in the order of the print -representation) and `#N#' in place of each subsequent occurrence, -where N is a positive decimal integer. - -There is no way to read this representation in standard Emacs, -but if you need to do so, try the cl-read.el package.") - - -(defvar custom-print-vectors nil - "*Non-nil if printing of vectors should obey print-level and print-length. - -For Emacs 18, setting print-level, or adding custom print list or -vector handling will make this happen anyway. Emacs 19 obeys -print-level, but not for vectors.") - - -;; Custom printers -;;========================================================== - -(defconst custom-printers nil - ;; e.g. '((symbolp . pkg::print-symbol)) - "An alist for custom printing of any type. -Pairs are of the form (PREDICATE . PRINTER). If PREDICATE is true -for an object, then PRINTER is called with the object. -PRINTER should print to `standard-output' using cust-print-original-princ -if the standard printer is sufficient, or cust-print-prin for complex things. -The PRINTER should return the object being printed. - -Don't modify this variable directly. Use `add-custom-printer' and -`delete-custom-printer'") -;; Should cust-print-original-princ and cust-print-prin be exported symbols? -;; Or should the standard printers functions be replaced by -;; CP ones in elisp so that CP internal functions need not be called? - -(defun add-custom-printer (pred printer) - "Add a pair of PREDICATE and PRINTER to `custom-printers'. -Any pair that has the same PREDICATE is first removed." - (setq custom-printers (cons (cons pred printer) - (delq (assq pred custom-printers) - custom-printers))) - ;; Rather than updating here, we could wait until cust-print-top-level is called. - (cust-print-update-custom-printers)) - -(defun delete-custom-printer (pred) - "Delete the custom printer associated with PREDICATE." - (setq custom-printers (delq (assq pred custom-printers) - custom-printers)) - (cust-print-update-custom-printers)) - - -(defun cust-print-use-custom-printer (object) - ;; Default function returns nil. - nil) - -(defun cust-print-update-custom-printers () - ;; Modify the definition of cust-print-use-custom-printer - (defalias 'cust-print-use-custom-printer - ;; We dont really want to require the byte-compiler. - ;; (byte-compile - (` (lambda (object) - (cond - (,@ (mapcar (function - (lambda (pair) - (` (((, (car pair)) object) - ((, (cdr pair)) object))))) - custom-printers)) - ;; Otherwise return nil. - (t nil) - ))) - ;; ) - )) - - -;; Saving and restoring emacs printing routines. -;;==================================================== - -(defun cust-print-set-function-cell (symbol-pair) - (defalias (car symbol-pair) - (symbol-function (car (cdr symbol-pair))))) - -(defun cust-print-original-princ (object &optional stream)) ; dummy def - -;; Save emacs routines. -(if (not (fboundp 'cust-print-original-prin1)) - (mapcar 'cust-print-set-function-cell - '((cust-print-original-prin1 prin1) - (cust-print-original-princ princ) - (cust-print-original-print print) - (cust-print-original-prin1-to-string prin1-to-string) - (cust-print-original-format format) - (cust-print-original-message message) - (cust-print-original-error error)))) - - -(defun custom-print-install () - "Replace print functions with general, customizable, Lisp versions. -The emacs subroutines are saved away, and you can reinstall them -by running `custom-print-uninstall'." - (interactive) - (mapcar 'cust-print-set-function-cell - '((prin1 custom-prin1) - (princ custom-princ) - (print custom-print) - (prin1-to-string custom-prin1-to-string) - (format custom-format) - (message custom-message) - (error custom-error) - )) - t) - -(defun custom-print-uninstall () - "Reset print functions to their emacs subroutines." - (interactive) - (mapcar 'cust-print-set-function-cell - '((prin1 cust-print-original-prin1) - (princ cust-print-original-princ) - (print cust-print-original-print) - (prin1-to-string cust-print-original-prin1-to-string) - (format cust-print-original-format) - (message cust-print-original-message) - (error cust-print-original-error) - )) - t) - -(defalias 'custom-print-funcs-installed-p 'custom-print-installed-p) -(defun custom-print-installed-p () - "Return t if custom-print is currently installed, nil otherwise." - (eq (symbol-function 'custom-prin1) (symbol-function 'prin1))) - -(put 'with-custom-print-funcs 'edebug-form-spec '(body)) -(put 'with-custom-print 'edebug-form-spec '(body)) - -(defalias 'with-custom-print-funcs 'with-custom-print) -(defmacro with-custom-print (&rest body) - "Temporarily install the custom print package while executing BODY." - (` (unwind-protect - (progn - (custom-print-install) - (,@ body)) - (custom-print-uninstall)))) - - -;; Lisp replacements for prin1 and princ, and for some subrs that use them -;;=============================================================== -;; - so far only the printing and formatting subrs. - -(defun custom-prin1 (object &optional stream) - "Output the printed representation of OBJECT, any Lisp object. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `prin1'. It -uses the appropriate printer depending on the values of `print-level' -and `print-circle' (which see)." - (cust-print-top-level object stream 'cust-print-original-prin1)) - - -(defun custom-princ (object &optional stream) - "Output the printed representation of OBJECT, any Lisp object. -No quoting characters are used; no delimiters are printed around -the contents of strings. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `princ'." - (cust-print-top-level object stream 'cust-print-original-princ)) - - -(defun custom-prin1-to-string (object) - "Return a string containing the printed representation of OBJECT, -any Lisp object. Quoting characters are used when needed to make output -that `read' can handle, whenever this is possible. - -This is the custom-print replacement for the standard `prin1-to-string'." - (let ((buf (get-buffer-create " *custom-print-temp*"))) - ;; We must erase the buffer before printing in case an error - ;; occured during the last prin1-to-string and we are in debugger. - (save-excursion - (set-buffer buf) - (erase-buffer)) - ;; We must be in the current-buffer when the print occurs. - (custom-prin1 object buf) - (save-excursion - (set-buffer buf) - (buffer-string) - ;; We could erase the buffer again, but why bother? - ))) - - -(defun custom-print (object &optional stream) - "Output the printed representation of OBJECT, with newlines around it. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `print'." - (cust-print-original-princ "\n" stream) - (custom-prin1 object stream) - (cust-print-original-princ "\n" stream)) - - -(defun custom-format (fmt &rest args) - "Format a string out of a control-string and arguments. -The first argument is a control string. It, and subsequent arguments -substituted into it, become the value, which is a string. -It may contain %s or %d or %c to substitute successive following arguments. -%s means print an argument as a string, %d means print as number in decimal, -%c means print a number as a single character. -The argument used by %s must be a string or a symbol; -the argument used by %d, %b, %o, %x or %c must be a number. - -This is the custom-print replacement for the standard `format'. It -calls the emacs `format' after first making strings for list, -vector, or symbol args. The format specification for such args should -be `%s' in any case, so a string argument will also work. The string -is generated with `custom-prin1-to-string', which quotes quotable -characters." - (apply 'cust-print-original-format fmt - (mapcar (function (lambda (arg) - (if (or (listp arg) (vectorp arg) (symbolp arg)) - (custom-prin1-to-string arg) - arg))) - args))) - - -(defun custom-message (fmt &rest args) - "Print a one-line message at the bottom of the screen. -The first argument is a control string. -It may contain %s or %d or %c to print successive following arguments. -%s means print an argument as a string, %d means print as number in decimal, -%c means print a number as a single character. -The argument used by %s must be a string or a symbol; -the argument used by %d or %c must be a number. - -This is the custom-print replacement for the standard `message'. -See `custom-format' for the details." - ;; It doesn't work to princ the result of custom-format as in: - ;; (cust-print-original-princ (apply 'custom-format fmt args)) - ;; because the echo area requires special handling - ;; to avoid duplicating the output. - ;; cust-print-original-message does it right. - (apply 'cust-print-original-message fmt - (mapcar (function (lambda (arg) - (if (or (listp arg) (vectorp arg) (symbolp arg)) - (custom-prin1-to-string arg) - arg))) - args))) - - -(defun custom-error (fmt &rest args) - "Signal an error, making error message by passing all args to `format'. - -This is the custom-print replacement for the standard `error'. -See `custom-format' for the details." - (signal 'error (list (apply 'custom-format fmt args)))) - - - -;; Support for custom prin1 and princ -;;========================================= - -;; Defs to quiet byte-compiler. -(defvar circle-table) -(defvar cust-print-current-level) - -(defun cust-print-original-printer (object)) ; One of the standard printers. -(defun cust-print-low-level-prin (object)) ; Used internally. -(defun cust-print-prin (object)) ; Call this to print recursively. - -(defun cust-print-top-level (object stream emacs-printer) - ;; Set up for printing. - (let ((standard-output (or stream standard-output)) - ;; circle-table will be non-nil if anything is circular. - (circle-table (and print-circle - (cust-print-preprocess-circle-tree object))) - (cust-print-current-level (or print-level -1))) - - (defalias 'cust-print-original-printer emacs-printer) - (defalias 'cust-print-low-level-prin - (cond - ((or custom-printers - circle-table - print-level ; comment out for version 19 - ;; Emacs doesn't use print-level or print-length - ;; for vectors, but custom-print can. - (if custom-print-vectors - (or print-level print-length))) - 'cust-print-print-object) - (t 'cust-print-original-printer))) - (defalias 'cust-print-prin - (if circle-table 'cust-print-print-circular 'cust-print-low-level-prin)) - - (cust-print-prin object) - object)) - - -(defun cust-print-print-object (object) - ;; Test object type and print accordingly. - ;; Could be called as either cust-print-low-level-prin or cust-print-prin. - (cond - ((null object) (cust-print-original-printer object)) - ((cust-print-use-custom-printer object) object) - ((consp object) (cust-print-list object)) - ((vectorp object) (cust-print-vector object)) - ;; All other types, just print. - (t (cust-print-original-printer object)))) - - -(defun cust-print-print-circular (object) - ;; Printer for `prin1' and `princ' that handles circular structures. - ;; If OBJECT appears multiply, and has not yet been printed, - ;; prefix with label; if it has been printed, use `#N#' instead. - ;; Otherwise, print normally. - (let ((tag (assq object circle-table))) - (if tag - (let ((id (cdr tag))) - (if (> id 0) - (progn - ;; Already printed, so just print id. - (cust-print-original-princ "#") - (cust-print-original-princ id) - (cust-print-original-princ "#")) - ;; Not printed yet, so label with id and print object. - (setcdr tag (- id)) ; mark it as printed - (cust-print-original-princ "#") - (cust-print-original-princ (- id)) - (cust-print-original-princ "=") - (cust-print-low-level-prin object) - )) - ;; Not repeated in structure. - (cust-print-low-level-prin object)))) - - -;;================================================ -;; List and vector processing for print functions. - -(defun cust-print-list (list) - ;; Print a list using print-length, print-level, and print-circle. - (if (= cust-print-current-level 0) - (cust-print-original-princ "#") - (let ((cust-print-current-level (1- cust-print-current-level))) - (cust-print-original-princ "(") - (let ((length (or print-length 0))) - - ;; Print the first element always (even if length = 0). - (cust-print-prin (car list)) - (setq list (cdr list)) - (if list (cust-print-original-princ " ")) - (setq length (1- length)) - - ;; Print the rest of the elements. - (while (and list (/= 0 length)) - (if (and (listp list) - (not (assq list circle-table))) - (progn - (cust-print-prin (car list)) - (setq list (cdr list))) - - ;; cdr is not a list, or it is in circle-table. - (cust-print-original-princ ". ") - (cust-print-prin list) - (setq list nil)) - - (setq length (1- length)) - (if list (cust-print-original-princ " "))) - - (if (and list (= length 0)) (cust-print-original-princ "...")) - (cust-print-original-princ ")")))) - list) - - -(defun cust-print-vector (vector) - ;; Print a vector according to print-length, print-level, and print-circle. - (if (= cust-print-current-level 0) - (cust-print-original-princ "#") - (let ((cust-print-current-level (1- cust-print-current-level)) - (i 0) - (len (length vector))) - (cust-print-original-princ "[") - - (if print-length - (setq len (min print-length len))) - ;; Print the elements - (while (< i len) - (cust-print-prin (aref vector i)) - (setq i (1+ i)) - (if (< i (length vector)) (cust-print-original-princ " "))) - - (if (< i (length vector)) (cust-print-original-princ "...")) - (cust-print-original-princ "]") - )) - vector) - - - -;; Circular structure preprocessing -;;================================== - -(defun cust-print-preprocess-circle-tree (object) - ;; Fill up the table. - (let (;; Table of tags for each object in an object to be printed. - ;; A tag is of the form: - ;; ( <object> <nil-t-or-id-number> ) - ;; The id-number is generated after the entire table has been computed. - ;; During walk through, the real circle-table lives in the cdr so we - ;; can use setcdr to add new elements instead of having to setq the - ;; variable sometimes (poor man's locf). - (circle-table (list nil))) - (cust-print-walk-circle-tree object) - - ;; Reverse table so it is in the order that the objects will be printed. - ;; This pass could be avoided if we always added to the end of the - ;; table with setcdr in walk-circle-tree. - (setcdr circle-table (nreverse (cdr circle-table))) - - ;; Walk through the table, assigning id-numbers to those - ;; objects which will be printed using #N= syntax. Delete those - ;; objects which will be printed only once (to speed up assq later). - (let ((rest circle-table) - (id -1)) - (while (cdr rest) - (let ((tag (car (cdr rest)))) - (cond ((cdr tag) - (setcdr tag id) - (setq id (1- id)) - (setq rest (cdr rest))) - ;; Else delete this object. - (t (setcdr rest (cdr (cdr rest)))))) - )) - ;; Drop the car. - (cdr circle-table) - )) - - - -(defun cust-print-walk-circle-tree (object) - (let (read-equivalent-p tag) - (while object - (setq read-equivalent-p - (or (numberp object) - (and (symbolp object) - ;; Check if it is uninterned. - (eq object (intern-soft (symbol-name object))))) - tag (and (not read-equivalent-p) - (assq object (cdr circle-table)))) - (cond (tag - ;; Seen this object already, so note that. - (setcdr tag t)) - - ((not read-equivalent-p) - ;; Add a tag for this object. - (setcdr circle-table - (cons (list object) - (cdr circle-table))))) - (setq object - (cond - (tag ;; No need to descend since we have already. - nil) - - ((consp object) - ;; Walk the car of the list recursively. - (cust-print-walk-circle-tree (car object)) - ;; But walk the cdr with the above while loop - ;; to avoid problems with max-lisp-eval-depth. - ;; And it should be faster than recursion. - (cdr object)) - - ((vectorp object) - ;; Walk the vector. - (let ((i (length object)) - (j 0)) - (while (< j i) - (cust-print-walk-circle-tree (aref object j)) - (setq j (1+ j)))))))))) - - -;; Example. -;;======================================= - -'(progn - (progn - ;; Create some circular structures. - (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x))) - (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f)) - (setcar (nthcdr 3 circ-list) circ-list) - (aset (nth 2 circ-list) 2 circ-list) - (setq dotted-circ-list (list 'a 'b 'c)) - (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list) - (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7)) - (aset circ-vector 5 (make-symbol "-gensym-")) - (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5)) - nil) - - (install-custom-print) - ;; (setq print-circle t) - - (let ((print-circle t)) - (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)") - (error "circular object with array printing"))) - - (let ((print-circle t)) - (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)") - (error "circular object with array printing"))) - - (let* ((print-circle t) - (x (list 'p 'q)) - (y (list (list 'a 'b) x 'foo x))) - (setcdr (cdr (cdr (cdr y))) (cdr y)) - (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))" - ) - (error "circular list example from CL manual"))) - - (let ((print-circle nil)) - ;; cl-packages.el is required to print uninterned symbols like #:FOO. - ;; (require 'cl-packages) - (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)") - (error "uninterned symbols in list"))) - (let ((print-circle t)) - (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)") - (error "circular uninterned symbols in list"))) - - (uninstall-custom-print) - ) - -(provide 'cust-print) - -;;; cust-print.el ends here - diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el deleted file mode 100644 index fb2a1324331..00000000000 --- a/lisp/emacs-lisp/debug.el +++ /dev/null @@ -1,491 +0,0 @@ -;;; debug.el --- debuggers and related commands for Emacs - -;; Copyright (C) 1985, 1986, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: lisp, tools, maint - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This is a major mode documented in the Emacs manual. - -;;; Code: - -(defvar debug-function-list nil - "List of functions currently set for debug on entry.") - -(defvar debugger-step-after-exit nil - "Non-nil means \"single-step\" after the debugger exits.") - -(defvar debugger-value nil - "This is the value for the debugger to return, when it returns.") - -(defvar debugger-old-buffer nil - "This is the buffer that was current when the debugger was entered.") - -(defvar debugger-outer-match-data) -(defvar debugger-outer-load-read-function) -(defvar debugger-outer-overriding-local-map) -(defvar debugger-outer-track-mouse) -(defvar debugger-outer-last-command) -(defvar debugger-outer-this-command) -(defvar debugger-outer-unread-command-char) -(defvar debugger-outer-unread-command-events) -(defvar debugger-outer-last-input-event) -(defvar debugger-outer-last-command-event) -(defvar debugger-outer-last-nonmenu-event) -(defvar debugger-outer-last-event-frame) -(defvar debugger-outer-standard-input) -(defvar debugger-outer-standard-output) -(defvar debugger-outer-cursor-in-echo-area) - -;;;###autoload -(setq debugger 'debug) -;;;###autoload -(defun debug (&rest debugger-args) - "Enter debugger. To return, type \\<debugger-mode-map>`\\[debugger-continue]'. -Arguments are mainly for use when this is called from the internals -of the evaluator. - -You may call with no args, or you may pass nil as the first arg and -any other args you like. In that case, the list of args after the -first will be printed into the backtrace buffer." - (interactive) - (message "Entering debugger...") - (let (debugger-value - (debug-on-error nil) - (debug-on-quit nil) - (debugger-buffer (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create "*Backtrace*"))) - (debugger-old-buffer (current-buffer)) - (debugger-step-after-exit nil) - ;; Don't keep reading from an executing kbd macro! - (executing-kbd-macro nil) - ;; Save the outer values of these vars for the `e' command - ;; before we replace the values. - (debugger-outer-match-data (match-data)) - (debugger-outer-load-read-function load-read-function) - (debugger-outer-overriding-local-map overriding-local-map) - (debugger-outer-track-mouse track-mouse) - (debugger-outer-last-command last-command) - (debugger-outer-this-command this-command) - (debugger-outer-unread-command-char unread-command-char) - (debugger-outer-unread-command-events unread-command-events) - (debugger-outer-last-input-event last-input-event) - (debugger-outer-last-command-event last-command-event) - (debugger-outer-last-nonmenu-event last-nonmenu-event) - (debugger-outer-last-event-frame last-event-frame) - (debugger-outer-standard-input standard-input) - (debugger-outer-standard-output standard-output) - (debugger-outer-cursor-in-echo-area cursor-in-echo-area)) - ;; Don't let these magic variables affect the debugger itself. - (let ((last-command nil) this-command track-mouse - (unread-command-char -1) unread-command-events - last-input-event last-command-event last-nonmenu-event - last-event-frame - overriding-local-map - load-read-function - (standard-input t) (standard-output t) - (cursor-in-echo-area nil)) - (unwind-protect - (save-excursion - (save-window-excursion - (pop-to-buffer debugger-buffer) - (erase-buffer) - (let ((standard-output (current-buffer)) - (print-escape-newlines t) - (print-length 50)) - (backtrace)) - (goto-char (point-min)) - (debugger-mode) - (delete-region (point) - (progn - (search-forward "\n debug(") - (forward-line 1) - (point))) - (debugger-reenable) - ;; lambda is for debug-on-call when a function call is next. - ;; debug is for debug-on-entry function called. - (cond ((memq (car debugger-args) '(lambda debug)) - (insert "Entering:\n") - (if (eq (car debugger-args) 'debug) - (progn - ;; Skip the frames for backtrace-debug, byte-code, - ;; and debug. - (backtrace-debug 3 t) - (delete-char 1) - (insert ?*) - (beginning-of-line)))) - ;; Exiting a function. - ((eq (car debugger-args) 'exit) - (insert "Return value: ") - (setq debugger-value (nth 1 debugger-args)) - (prin1 debugger-value (current-buffer)) - (insert ?\n) - (delete-char 1) - (insert ? ) - (beginning-of-line)) - ;; Debugger entered for an error. - ((eq (car debugger-args) 'error) - (insert "Signaling: ") - (prin1 (nth 1 debugger-args) (current-buffer)) - (insert ?\n)) - ;; debug-on-call, when the next thing is an eval. - ((eq (car debugger-args) t) - (insert "Beginning evaluation of function call form:\n")) - ;; User calls debug directly. - (t - (prin1 (if (eq (car debugger-args) 'nil) - (cdr debugger-args) debugger-args) - (current-buffer)) - (insert ?\n))) - (message "") - (let ((inhibit-trace t) - (standard-output nil) - (buffer-read-only t)) - (message "") - (recursive-edit)))) - ;; Kill or at least neuter the backtrace buffer, so that users - ;; don't try to execute debugger commands in an invalid context. - (if (get-buffer-window debugger-buffer 'visible) - ;; Still visible despite the save-window-excursion? Maybe it - ;; it's in a pop-up frame. It would be annoying to delete and - ;; recreate it every time the debugger stops, so instead we'll - ;; erase it but leave it visible. - (save-excursion - (set-buffer debugger-buffer) - (erase-buffer) - (fundamental-mode)) - (kill-buffer debugger-buffer)) - (store-match-data debugger-outer-match-data))) - ;; Put into effect the modified values of these variables - ;; in case the user set them with the `e' command. - (setq load-read-function debugger-outer-load-read-function) - (setq overriding-local-map debugger-outer-overriding-local-map) - (setq track-mouse debugger-outer-track-mouse) - (setq last-command debugger-outer-last-command) - (setq this-command debugger-outer-this-command) - (setq unread-command-char debugger-outer-unread-command-char) - (setq unread-command-events debugger-outer-unread-command-events) - (setq last-input-event debugger-outer-last-input-event) - (setq last-command-event debugger-outer-last-command-event) - (setq last-nonmenu-event debugger-outer-last-nonmenu-event) - (setq last-event-frame debugger-outer-last-event-frame) - (setq standard-input debugger-outer-standard-input) - (setq standard-output debugger-outer-standard-output) - (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area) - (setq debug-on-next-call debugger-step-after-exit) - debugger-value)) - -(defun debugger-step-through () - "Proceed, stepping through subexpressions of this expression. -Enter another debugger on next entry to eval, apply or funcall." - (interactive) - (setq debugger-step-after-exit t) - (message "Proceeding, will debug on next eval or call.") - (exit-recursive-edit)) - -(defun debugger-continue () - "Continue, evaluating this expression without stopping." - (interactive) - (message "Continuing.") - (exit-recursive-edit)) - -(defun debugger-return-value (val) - "Continue, specifying value to return. -This is only useful when the value returned from the debugger -will be used, such as in a debug on exit from a frame." - (interactive "XReturn value (evaluated): ") - (setq debugger-value val) - (princ "Returning " t) - (prin1 debugger-value) - (exit-recursive-edit)) - -(defun debugger-jump () - "Continue to exit from this frame, with all debug-on-entry suspended." - (interactive) - ;; Compensate for the two extra stack frames for debugger-jump. - (let ((debugger-frame-offset (+ debugger-frame-offset 2))) - (debugger-frame)) - ;; Turn off all debug-on-entry functions - ;; but leave them in the list. - (let ((list debug-function-list)) - (while list - (fset (car list) - (debug-on-entry-1 (car list) (symbol-function (car list)) nil)) - (setq list (cdr list)))) - (message "Continuing through this frame") - (exit-recursive-edit)) - -(defun debugger-reenable () - "Turn all debug-on-entry functions back on." - (let ((list debug-function-list)) - (while list - (or (consp (symbol-function (car list))) - (debug-convert-byte-code (car list))) - (fset (car list) - (debug-on-entry-1 (car list) (symbol-function (car list)) t)) - (setq list (cdr list))))) - -(defun debugger-frame-number () - "Return number of frames in backtrace before the one point points at." - (save-excursion - (beginning-of-line) - (let ((opoint (point)) - (count 0)) - (goto-char (point-min)) - (if (or (equal (buffer-substring (point) (+ (point) 6)) - "Signal") - (equal (buffer-substring (point) (+ (point) 6)) - "Return")) - (progn - (search-forward ":") - (forward-sexp 1))) - (forward-line 1) - (while (progn - (forward-char 2) - (if (= (following-char) ?\() - (forward-sexp 1) - (forward-sexp 2)) - (forward-line 1) - (<= (point) opoint)) - (setq count (1+ count))) - count))) - -;; Chosen empirically to account for all the frames -;; that will exist when debugger-frame is called -;; within the first one that appears in the backtrace buffer. -;; Assumes debugger-frame is called from a key; -;; will be wrong if it is called with Meta-x. -(defconst debugger-frame-offset 8 "") - -(defun debugger-frame () - "Request entry to debugger when this frame exits. -Applies to the frame whose line point is on in the backtrace." - (interactive) - (beginning-of-line) - (let ((level (debugger-frame-number))) - (backtrace-debug (+ level debugger-frame-offset) t)) - (if (= (following-char) ? ) - (let ((buffer-read-only nil)) - (delete-char 1) - (insert ?*))) - (beginning-of-line)) - -(defun debugger-frame-clear () - "Do not enter to debugger when this frame exits. -Applies to the frame whose line point is on in the backtrace." - (interactive) - (beginning-of-line) - (let ((level (debugger-frame-number))) - (backtrace-debug (+ level debugger-frame-offset) nil)) - (if (= (following-char) ?*) - (let ((buffer-read-only nil)) - (delete-char 1) - (insert ? ))) - (beginning-of-line)) - -(defun debugger-eval-expression (exp) - "Eval an expression, in an environment like that outside the debugger." - (interactive - (list (read-from-minibuffer "Eval: " - nil read-expression-map t - 'read-expression-history))) - (save-excursion - (if (null (buffer-name debugger-old-buffer)) - ;; old buffer deleted - (setq debugger-old-buffer (current-buffer))) - (set-buffer debugger-old-buffer) - (let ((track-mouse debugger-outer-track-mouse) - (last-command debugger-outer-last-command) - (this-command debugger-outer-this-command) - (unread-command-char debugger-outer-unread-command-char) - (unread-command-events debugger-outer-unread-command-events) - (last-input-event debugger-outer-last-input-event) - (last-command-event debugger-outer-last-command-event) - (last-nonmenu-event debugger-outer-last-nonmenu-event) - (last-event-frame debugger-outer-last-event-frame) - (standard-input debugger-outer-standard-input) - (standard-output debugger-outer-standard-output) - (cursor-in-echo-area debugger-outer-cursor-in-echo-area) - (overriding-local-map debugger-outer-overriding-local-map) - (load-read-function debugger-outer-load-read-function)) - (store-match-data debugger-outer-match-data) - (prog1 (eval-expression exp) - (setq debugger-outer-match-data (match-data)) - (setq debugger-outer-load-read-function load-read-function) - (setq debugger-outer-overriding-local-map overriding-local-map) - (setq debugger-outer-track-mouse track-mouse) - (setq debugger-outer-last-command last-command) - (setq debugger-outer-this-command this-command) - (setq debugger-outer-unread-command-char unread-command-char) - (setq debugger-outer-unread-command-events unread-command-events) - (setq debugger-outer-last-input-event last-input-event) - (setq debugger-outer-last-command-event last-command-event) - (setq debugger-outer-last-nonmenu-event last-nonmenu-event) - (setq debugger-outer-last-event-frame last-event-frame) - (setq debugger-outer-standard-input standard-input) - (setq debugger-outer-standard-output standard-output) - (setq debugger-outer-cursor-in-echo-area cursor-in-echo-area))))) - -(defvar debugger-mode-map nil) -(if debugger-mode-map - nil - (let ((loop ? )) - (setq debugger-mode-map (make-keymap)) - (suppress-keymap debugger-mode-map) - (define-key debugger-mode-map "-" 'negative-argument) - (define-key debugger-mode-map "b" 'debugger-frame) - (define-key debugger-mode-map "c" 'debugger-continue) - (define-key debugger-mode-map "j" 'debugger-jump) - (define-key debugger-mode-map "r" 'debugger-return-value) - (define-key debugger-mode-map "u" 'debugger-frame-clear) - (define-key debugger-mode-map "d" 'debugger-step-through) - (define-key debugger-mode-map "l" 'debugger-list-functions) - (define-key debugger-mode-map "h" 'describe-mode) - (define-key debugger-mode-map "q" 'top-level) - (define-key debugger-mode-map "e" 'debugger-eval-expression) - (define-key debugger-mode-map " " 'next-line))) - -(put 'debugger-mode 'mode-class 'special) - -(defun debugger-mode () - "Mode for backtrace buffers, selected in debugger. -\\<debugger-mode-map> -A line starts with `*' if exiting that frame will call the debugger. -Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'. - -When in debugger due to frame being exited, -use the \\[debugger-return-value] command to override the value -being returned from that frame. - -Use \\[debug-on-entry] and \\[cancel-debug-on-entry] to control -which functions will enter the debugger when called. - -Complete list of commands: -\\{debugger-mode-map}" - (kill-all-local-variables) - (setq major-mode 'debugger-mode) - (setq mode-name "Debugger") - (setq truncate-lines t) - (set-syntax-table emacs-lisp-mode-syntax-table) - (use-local-map debugger-mode-map)) - -;;;###autoload -(defun debug-on-entry (function) - "Request FUNCTION to invoke debugger each time it is called. -If you tell the debugger to continue, FUNCTION's execution proceeds. -This works by modifying the definition of FUNCTION, -which must be written in Lisp, not predefined. -Use \\[cancel-debug-on-entry] to cancel the effect of this command. -Redefining FUNCTION also cancels it." - (interactive "aDebug on entry (to function): ") - (debugger-reenable) - (if (subrp (symbol-function function)) - (error "Function %s is a primitive" function)) - (or (consp (symbol-function function)) - (debug-convert-byte-code function)) - (or (consp (symbol-function function)) - (error "Definition of %s is not a list" function)) - (fset function (debug-on-entry-1 function (symbol-function function) t)) - (or (memq function debug-function-list) - (setq debug-function-list (cons function debug-function-list))) - function) - -;;;###autoload -(defun cancel-debug-on-entry (&optional function) - "Undo effect of \\[debug-on-entry] on FUNCTION. -If argument is nil or an empty string, cancel for all functions." - (interactive - (list (let ((name - (completing-read "Cancel debug on entry (to function): " - ;; Make an "alist" of the functions - ;; that now have debug on entry. - (mapcar 'list - (mapcar 'symbol-name - debug-function-list)) - nil t nil))) - (if name (intern name))))) - (debugger-reenable) - (if (and function (not (string= function ""))) - (progn - (fset function - (debug-on-entry-1 function (symbol-function function) nil)) - (setq debug-function-list (delq function debug-function-list)) - function) - (message "Cancelling debug-on-entry for all functions") - (mapcar 'cancel-debug-on-entry debug-function-list))) - -(defun debug-convert-byte-code (function) - (let ((defn (symbol-function function))) - (if (not (consp defn)) - ;; Assume a compiled code object. - (let* ((contents (append defn nil)) - (body - (list (list 'byte-code (nth 1 contents) - (nth 2 contents) (nth 3 contents))))) - (if (nthcdr 5 contents) - (setq body (cons (list 'interactive (nth 5 contents)) body))) - (if (nth 4 contents) - ;; 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))) - (fset function (cons 'lambda (cons (car contents) body))))))) - -(defun debug-on-entry-1 (function defn flag) - (if (subrp defn) - (error "%s is a built-in function" function) - (if (eq (car defn) 'macro) - (debug-on-entry-1 function (cdr defn) flag) - (or (eq (car defn) 'lambda) - (error "%s not user-defined Lisp function" function)) - (let (tail prec) - (if (stringp (car (nthcdr 2 defn))) - (setq tail (nthcdr 3 defn) - prec (list (car defn) (car (cdr defn)) - (car (cdr (cdr defn))))) - (setq tail (nthcdr 2 defn) - prec (list (car defn) (car (cdr defn))))) - (if (eq flag (equal (car tail) '(debug 'debug))) - defn - (if flag - (nconc prec (cons '(debug 'debug) tail)) - (nconc prec (cdr tail)))))))) - -(defun debugger-list-functions () - "Display a list of all the functions now set to debug on entry." - (interactive) - (with-output-to-temp-buffer "*Help*" - (if (null debug-function-list) - (princ "No debug-on-entry functions now\n") - (princ "Functions set to debug on entry:\n\n") - (let ((list debug-function-list)) - (while list - (prin1 (car list)) - (terpri) - (setq list (cdr list)))) - (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.")) - (save-excursion - (set-buffer standard-output) - (help-mode)))) - -;;; debug.el ends here diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el deleted file mode 100644 index 4199728888e..00000000000 --- a/lisp/emacs-lisp/disass.el +++ /dev/null @@ -1,266 +0,0 @@ -;;; disass.el --- disassembler for compiled Emacs Lisp code - -;; Copyright (C) 1986, 1991 Free Software Foundation, Inc. - -;; Author: Doug Cutting <doug@csli.stanford.edu> -;; Jamie Zawinski <jwz@lucid.com> -;; Maintainer: Jamie Zawinski <jwz@lucid.com> -;; Keywords: internal - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The single entry point, `disassemble', disassembles a code object generated -;; by the Emacs Lisp byte-compiler. This doesn't invert the compilation -;; operation, not by a long shot, but it's useful for debugging. - -;; -;; Original version by Doug Cutting (doug@csli.stanford.edu) -;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for -;; the new lapcode-based byte compiler. - -;;; Code: - -;;; The variable byte-code-vector is defined by the new bytecomp.el. -;;; The function byte-decompile-lapcode is defined in byte-opt.el. -;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. -(require 'byte-compile "bytecomp") - -(defvar disassemble-column-1-indent 8 "*") -(defvar disassemble-column-2-indent 10 "*") - -(defvar disassemble-recursive-indent 3 "*") - -;;;###autoload -(defun disassemble (object &optional buffer indent interactive-p) - "Print disassembled code for OBJECT in (optional) BUFFER. -OBJECT can be a symbol defined as a function, or a function itself -\(a lambda expression or a compiled-function object). -If OBJECT is not already compiled, we compile it, but do not -redefine OBJECT if it is a symbol." - (interactive (list (intern (completing-read "Disassemble function: " - obarray 'fboundp t)) - nil 0 t)) - (if (eq (car-safe object) 'byte-code) - (setq object (list 'lambda () object))) - (or indent (setq indent 0)) ;Default indent to zero - (save-excursion - (if (or interactive-p (null buffer)) - (with-output-to-temp-buffer "*Disassemble*" - (set-buffer "*Disassemble*") - (disassemble-internal object indent (not interactive-p))) - (set-buffer buffer) - (disassemble-internal object indent nil))) - nil) - - -(defun disassemble-internal (obj indent interactive-p) - (let ((macro 'nil) - (name 'nil) - (doc 'nil) - args) - (while (symbolp obj) - (setq name obj - obj (symbol-function obj))) - (if (subrp obj) - (error "Can't disassemble #<subr %s>" name)) - (if (and (listp obj) (eq (car obj) 'autoload)) - (progn - (load (nth 1 obj)) - (setq obj (symbol-function name)))) - (if (eq (car-safe obj) 'macro) ;handle macros - (setq macro t - obj (cdr obj))) - (if (and (listp obj) (eq (car obj) 'byte-code)) - (setq obj (list 'lambda nil obj))) - (if (and (listp obj) (not (eq (car obj) 'lambda))) - (error "not a function")) - (if (consp obj) - (if (assq 'byte-code obj) - nil - (if interactive-p (message (if name - "Compiling %s's definition..." - "Compiling definition...") - name)) - (setq obj (byte-compile obj)) - (if interactive-p (message "Done compiling. Disassembling...")))) - (cond ((consp obj) - (setq obj (cdr obj)) ;throw lambda away - (setq args (car obj)) ;save arg list - (setq obj (cdr obj))) - ((byte-code-function-p obj) - (setq args (aref obj 0))) - (t (error "Compilation failed"))) - (if (zerop indent) ; not a nested function - (progn - (indent-to indent) - (insert (format "byte code%s%s%s:\n" - (if (or macro name) " for" "") - (if macro " macro" "") - (if name (format " %s" name) ""))))) - (let ((doc (if (consp obj) - (and (stringp (car obj)) (car obj)) - ;; Use documentation to get lazy-loaded doc string - (documentation obj t)))) - (if (and doc (stringp doc)) - (progn (and (consp obj) (setq obj (cdr obj))) - (indent-to indent) - (princ " doc: " (current-buffer)) - (if (string-match "\n" doc) - (setq doc (concat (substring doc 0 (match-beginning 0)) - " ..."))) - (insert doc "\n")))) - (indent-to indent) - (insert " args: ") - (prin1 args (current-buffer)) - (insert "\n") - (let ((interactive (cond ((consp obj) - (assq 'interactive obj)) - ((> (length obj) 5) - (list 'interactive (aref obj 5)))))) - (if interactive - (progn - (setq interactive (nth 1 interactive)) - (if (eq (car-safe (car-safe obj)) 'interactive) - (setq obj (cdr obj))) - (indent-to indent) - (insert " interactive: ") - (if (eq (car-safe interactive) 'byte-code) - (progn - (insert "\n") - (disassemble-1 interactive - (+ indent disassemble-recursive-indent))) - (let ((print-escape-newlines t)) - (prin1 interactive (current-buffer)))) - (insert "\n")))) - (cond ((and (consp obj) (assq 'byte-code obj)) - (disassemble-1 (assq 'byte-code obj) indent)) - ((byte-code-function-p obj) - (disassemble-1 obj indent)) - (t - (insert "Uncompiled body: ") - (let ((print-escape-newlines t)) - (prin1 (if (cdr obj) (cons 'progn obj) (car obj)) - (current-buffer)))))) - (if interactive-p - (message ""))) - - -(defun disassemble-1 (obj indent) - "Prints the byte-code call OBJ in the current buffer. -OBJ should be a call to BYTE-CODE generated by the byte compiler." - (let (bytes constvec) - (if (consp obj) - (setq bytes (car (cdr obj)) ;the byte code - constvec (car (cdr (cdr obj)))) ;constant vector - ;; If it is lazy-loaded, load it now - (fetch-bytecode obj) - (setq bytes (aref obj 1) - constvec (aref obj 2))) - (let ((lap (byte-decompile-bytecode bytes constvec)) - op arg opname pc-value) - (let ((tagno 0) - tmp - (lap lap)) - (while (setq tmp (assq 'TAG lap)) - (setcar (cdr tmp) (setq tagno (1+ tagno))) - (setq lap (cdr (memq tmp lap))))) - (while lap - ;; Take off the pc value of the next thing - ;; and put it in pc-value. - (setq pc-value nil) - (if (numberp (car lap)) - (setq pc-value (car lap) - lap (cdr lap))) - ;; Fetch the next op and its arg. - (setq op (car (car lap)) - arg (cdr (car lap))) - (setq lap (cdr lap)) - (indent-to indent) - (if (eq 'TAG op) - (progn - ;; We have a label. Display it, but first its pc value. - (if pc-value - (insert (format "%d:" pc-value))) - (insert (int-to-string (car arg)))) - ;; We have an instruction. Display its pc value first. - (if pc-value - (insert (format "%d" pc-value))) - (indent-to (+ indent disassemble-column-1-indent)) - (if (and op - (string-match "^byte-" (setq opname (symbol-name op)))) - (setq opname (substring opname 5)) - (setq opname "<not-an-opcode>")) - (if (eq op 'byte-constant2) - (insert " #### shouldn't have seen constant2 here!\n ")) - (insert opname) - (indent-to (+ indent disassemble-column-1-indent - disassemble-column-2-indent - -1)) - (insert " ") - (cond ((memq op byte-goto-ops) - (insert (int-to-string (nth 1 arg)))) - ((memq op '(byte-call byte-unbind - byte-listN byte-concatN byte-insertN)) - (insert (int-to-string arg))) - ((memq op '(byte-varref byte-varset byte-varbind)) - (prin1 (car arg) (current-buffer))) - ((memq op '(byte-constant byte-constant2)) - ;; it's a constant - (setq arg (car arg)) - ;; but if the value of the constant is compiled code, then - ;; recursively disassemble it. - (cond ((or (byte-code-function-p arg) - (and (eq (car-safe arg) 'lambda) - (assq 'byte-code arg)) - (and (eq (car-safe arg) 'macro) - (or (byte-code-function-p (cdr arg)) - (and (eq (car-safe (cdr arg)) 'lambda) - (assq 'byte-code (cdr arg)))))) - (cond ((byte-code-function-p arg) - (insert "<compiled-function>\n")) - ((eq (car-safe arg) 'lambda) - (insert "<compiled lambda>")) - (t (insert "<compiled macro>\n"))) - (disassemble-internal - arg - (+ indent disassemble-recursive-indent 1) - nil)) - ((eq (car-safe arg) 'byte-code) - (insert "<byte code>\n") - (disassemble-1 ;recurse on byte-code object - arg - (+ indent disassemble-recursive-indent))) - ((eq (car-safe (car-safe arg)) 'byte-code) - (insert "(<byte code>...)\n") - (mapcar ;recurse on list of byte-code objects - '(lambda (obj) - (disassemble-1 - obj - (+ indent disassemble-recursive-indent))) - arg)) - (t - ;; really just a constant - (let ((print-escape-newlines t)) - (prin1 arg (current-buffer)))))) - ) - (insert "\n"))))) - nil) - -;;; disass.el ends here diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el deleted file mode 100644 index b172e131763..00000000000 --- a/lisp/emacs-lisp/easymenu.el +++ /dev/null @@ -1,244 +0,0 @@ -;;; easymenu.el --- support the easymenu interface for defining a menu. - -;; Copyright (C) 1994, 1996 Free Software Foundation, Inc. - -;; Keywords: emulations -;; Author: rms - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This is compatible with easymenu.el by Per Abrahamsen -;; but it is much simpler as it doesn't try to support other Emacs versions. -;; The code was mostly derived from lmenu.el. - -;;; Code: - -;;;###autoload -(defmacro easy-menu-define (symbol maps doc menu) - "Define a menu bar submenu in maps MAPS, according to MENU. -The menu keymap is stored in symbol SYMBOL, both as its value -and as its function definition. DOC is used as the doc string for SYMBOL. - -The first element of MENU must be a string. It is the menu bar item name. -The rest of the elements are menu items. - -A menu item is usually a vector of three elements: [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. - -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. - -Alternatively, a menu item may have the form: - - [ NAME CALLBACK [ KEYWORD ARG ] ... ] - -Where KEYWORD is one of the symbol 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. - - :active ENABLE - -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. - - :suffix NAME - -NAME is a string; the name of an argument to CALLBACK. - - :style STYLE - -STYLE is a symbol describing the type of menu item. The following are -defined: - -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. -nil: An ordinary menu item. - - :selected SELECTED - -SELECTED is an expression; the checkbox or radio button is selected -whenever this expression's value is non-nil. - -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. - -A menu item can be a list. It is treated as a submenu. -The first element should be the submenu name. That's used as the -menu item in the top-level menu. The cdr of the submenu list -is a list of menu items, as above." - (` (progn - (defvar (, symbol) nil (, doc)) - (easy-menu-do-define (quote (, symbol)) (, maps) (, doc) (, menu))))) - -;;;###autoload -(defun easy-menu-do-define (symbol maps doc menu) - ;; We can't do anything that might differ between Emacs dialects in - ;; `easy-menu-define' in order to make byte compiled files - ;; compatible. Therefore everything interesting is done in this - ;; function. - (set symbol (easy-menu-create-keymaps (car menu) (cdr menu))) - (fset symbol (` (lambda (event) (, doc) (interactive "@e") - (x-popup-menu event (, symbol))))) - (mapcar (function (lambda (map) - (define-key map (vector 'menu-bar (intern (car menu))) - (cons (car menu) (symbol-value symbol))))) - (if (keymapp maps) (list maps) maps))) - -(defvar easy-menu-item-count 0) - -;; Return a menu keymap corresponding to a Lucid-style menu list -;; MENU-ITEMS, and with name MENU-NAME. -;;;###autoload -(defun easy-menu-create-keymaps (menu-name menu-items) - (let ((menu (make-sparse-keymap menu-name)) old-items have-buttons) - ;; Process items in reverse order, - ;; since the define-key loop reverses them again. - (setq menu-items (reverse menu-items)) - (while menu-items - (let* ((item (car menu-items)) - (callback (if (vectorp item) (aref item 1))) - (not-button t) - command enabler item-string name) - (cond ((stringp item) - (setq command nil) - (setq item-string (if (string-match "^-+$" item) "" item))) - ((consp item) - (setq command (easy-menu-create-keymaps (car item) (cdr item))) - (setq name (setq item-string (car item)))) - ((vectorp item) - (setq command (make-symbol (format "menu-function-%d" - easy-menu-item-count))) - (setq easy-menu-item-count (1+ easy-menu-item-count)) - (setq name (setq item-string (aref item 0))) - (let ((keyword (aref item 2))) - (if (and (symbolp keyword) - (= ?: (aref (symbol-name keyword) 0))) - (let ((count 2) - style selected active keys - arg) - (while (> (length item) count) - (setq keyword (aref item count)) - (setq arg (aref item (1+ count))) - (setq count (+ 2 count)) - (cond ((eq keyword ':keys) - (setq keys arg)) - ((eq keyword ':active) - (setq active arg)) - ((eq keyword ':suffix) - (setq item-string - (concat item-string " " arg))) - ((eq keyword ':style) - (setq style arg)) - ((eq keyword ':selected) - (setq selected arg)))) - (if keys - (setq item-string - (concat item-string " (" keys ")"))) - (if (and selected - (or (eq style 'radio) (eq style 'toggle))) - ;; Simulate checkboxes and radio buttons. - (progn - (setq item-string - (concat - (if (eval selected) - (if (eq style 'radio) "(*) " "[X] ") - (if (eq style 'radio) "( ) " "[ ] ")) - item-string)) - (put command 'menu-enable - (list 'easy-menu-update-button - item-string - (if (eq style 'radio) ?* ?X) - selected - (or active t))) - (setq not-button nil - active nil - have-buttons t) - (while old-items ; Fix items aleady defined. - (setcar (car old-items) - (concat " " (car (car old-items)))) - (setq old-items (cdr old-items))))) - (if active (put command 'menu-enable active))) - (put command 'menu-enable keyword))) - (if (symbolp callback) - (fset command callback) - (fset command (list 'lambda () '(interactive) callback))) - (put command 'menu-alias t))) - (if (null command) - ;; Handle inactive strings specially--allow any number - ;; of identical ones. - (setcdr menu (cons (list nil item-string) (cdr menu))) - (if (and not-button have-buttons) - (setq item-string (concat " " item-string))) - (setq command (cons item-string command)) - (if (not have-buttons) ; Save all items so that we can fix - (setq old-items (cons command old-items))) ; if we have buttons. - (if name (define-key menu (vector (intern name)) command)))) - (setq menu-items (cdr menu-items))) - menu)) - -(defun easy-menu-update-button (item ch selected active) - "Used as menu-enable property to update buttons. -A call to this function is used as the menu-enable property for buttons. -ITEM is the item-string into wich CH or ` ' is inserted depending on if -SELECTED is true or not. The menu entry in enabled iff ACTIVE is true." - (let ((new (if selected ch ? )) - (old (aref item 1))) - (if (eq new old) - ;; No change, just use the active value. - active - ;; It has changed. Update the entry. - (aset item 1 new) - ;; If the entry is active, make sure the menu gets updated by - ;; returning a different value than last time to cheat the cache. - (and active - (random))))) - -(defun easy-menu-change (path name items) - "Change menu found at PATH as item NAME to contain ITEMS. -PATH is a list of strings for locating the menu containing NAME in the -menu bar. ITEMS is a list of menu items, as in `easy-menu-define'. -These items entirely replace the previous items in that map. - -Call this from `menu-bar-update-hook' to implement dynamic menus." - (let ((map (key-binding (apply 'vector - 'menu-bar - (mapcar 'intern (append path (list name))))))) - (if (keymapp map) - (setcdr map (cdr (easy-menu-create-keymaps name items))) - (error "Malformed menu in `easy-menu-change'")))) - -(defun easy-menu-remove (menu)) - -(defun easy-menu-add (menu &optional map)) - -(provide 'easymenu) - -;;; easymenu.el ends here diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el deleted file mode 100644 index f6831f6f29d..00000000000 --- a/lisp/emacs-lisp/edebug.el +++ /dev/null @@ -1,4515 +0,0 @@ -;;; edebug.el --- a source-level debugger for Emacs Lisp - -;; Copyright (C) 1988,'89,'90,'91,'92,'93,'94,'95 Free Software Foundation, Inc - -;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> -;; Keywords: lisp, tools, maint - -;; LCD Archive Entry: -;; edebug|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |A source level debugger for Emacs Lisp. -;; |$Date: 1996/11/09 21:48:07 $|$Revision: 3.12 $|~/modes/edebug.el| - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This minor mode allows programmers to step through Emacs Lisp -;; source code while executing functions. You can also set -;; breakpoints, trace (stopping at each expression), evaluate -;; expressions as if outside Edebug, reevaluate and display a list of -;; expressions, trap errors normally caught by debug, and display a -;; debug style backtrace. - -;;; Installation -;; ============= - -;; Put edebug.el in some directory in your load-path and -;; byte-compile it. Also read the beginning of edebug-epoch.el, -;; cl-specs.el, and edebug-cl-read.el if they apply to you. - -;; Unless you are using Emacs 19 which is already set up to use Edebug, -;; put the following forms in your .emacs file. -;; (define-key emacs-lisp-mode-map "\C-xx" 'edebug-eval-top-level-form) -;; (autoload 'edebug-eval-top-level-form "edebug") - -;; If you wish to change the default edebug global command prefix, change: -;; (setq edebug-global-prefix "\C-xX") - -;; Other options, are described in the manual. - -;; In previous versions of Edebug, users were directed to set -;; `debugger' to `edebug-debug'. This is no longer necessary -;; since Edebug automatically sets it whenever Edebug is active. - -;;; Minimal Instructions -;; ===================== - -;; First evaluate a defun with C-xx, then run the function. Step -;; through the code with SPC, mark breakpoints with b, go until a -;; breakpoint is reached with g, and quit execution with q. Use the -;; "?" command in edebug to describe other commands. See edebug.tex -;; or the Emacs 19 Lisp Reference Manual for more instructions. - -;; Send me your enhancements, ideas, bugs, or fixes. -;; For bugs, you can call edebug-submit-bug-report if you have reporter.el. -;; There is an edebug mailing list if you want to keep up -;; with the latest developments. Requests to: edebug-request@cs.uiuc.edu - -;; Daniel LaLiberte 217-398-4114 -;; University of Illinois, Urbana-Champaign -;; Department of Computer Science -;; 1304 W Springfield -;; Urbana, IL 61801 - -;; uiucdcs!liberte -;; liberte@cs.uiuc.edu - -;; For the early revision history, see edebug-history. - -;;; Code: - -(defconst edebug-version - (let ((raw-version "$Revision: 3.12 $")) - (substring raw-version (string-match "[0-9.]*" raw-version) - (match-end 0)))) - -(require 'backquote) - -;; Emacs 18 doesn't have defalias. -(eval-and-compile - (or (fboundp 'defalias) (fset 'defalias 'fset))) - - -;;; Bug reporting - -(defconst edebug-maintainer-address "liberte@cs.uiuc.edu") - -(defun edebug-submit-bug-report () - "Submit, via mail, a bug report on edebug." - (interactive) - (require 'reporter) - (and (y-or-n-p "Do you really want to submit a report on edebug? ") - (reporter-submit-bug-report - edebug-maintainer-address - (concat "edebug.el " edebug-version) - (list 'edebug-setup-hook - 'edebug-all-defs - 'edebug-all-forms - 'edebug-eval-macro-args - 'edebug-stop-before-symbols - 'edebug-save-windows - 'edebug-save-displayed-buffer-points - 'edebug-initial-mode - 'edebug-trace - 'edebug-test-coverage - 'edebug-continue-kbd-macro - 'edebug-print-length - 'edebug-print-level - 'edebug-print-circle - )))) - -;;; Options - -(defvar edebug-setup-hook nil - "*Functions to call before edebug is used. -Each time it is set to a new value, Edebug will call those functions -once and then `edebug-setup-hook' is reset to nil. You could use this -to load up Edebug specifications associated with a package you are -using but only when you also use Edebug.") - -(defvar edebug-all-defs nil - "*If non-nil, evaluation of any defining forms will instrument for Edebug. -This applies to `eval-defun', `eval-region', `eval-buffer', and -`eval-current-buffer'. `eval-region' is also called by -`eval-last-sexp', and `eval-print-last-sexp'. - -You can use the command `edebug-all-defs' to toggle the value of this -variable. You may wish to make it local to each buffer with -\(make-local-variable 'edebug-all-defs) in your -`emacs-lisp-mode-hook'.") - -(defvar edebug-all-forms nil - "*Non-nil evaluation of all forms will instrument for Edebug. -This doesn't apply to loading or evaluations in the minibuffer. -Use the command `edebug-all-forms' to toggle the value of this option.") - -(defvar edebug-eval-macro-args nil - "*Non-nil means all macro call arguments may be evaluated. -If this variable is nil, the default, Edebug will *not* wrap -macro call arguments as if they will be evaluated. -For each macro, a `edebug-form-spec' overrides this option. -So to specify exceptions for macros that have some arguments evaluated -and some not, you should specify an `edebug-form-spec'. - -This option is going away soon.") - -(defvar edebug-stop-before-symbols nil - "*Non-nil causes Edebug to stop before symbols as well as after. -In any case, a breakpoint or interrupt may stop before a symbol. - -This option is going away soon.") - -(defvar edebug-save-windows t - "*If non-nil, Edebug saves and restores the window configuration. -That takes some time, so if your program does not care what happens to -the window configurations, it is better to set this variable to nil. - -If the value is a list, only the listed windows are saved and -restored. - -`edebug-toggle-save-windows' may be used to change this variable.") - -(defvar edebug-save-displayed-buffer-points nil - "*If non-nil, save and restore point in all displayed buffers. - -Saving and restoring point in other buffers is necessary if you are -debugging code that changes the point of a buffer which is displayed -in a non-selected window. If Edebug or the user then selects the -window, the buffer's point will be changed to the window's point. - -Saving and restoring point in all buffers is expensive, since it -requires selecting each window twice, so enable this only if you need -it.") - -(defvar edebug-initial-mode 'step - "*Initial execution mode for Edebug, if non-nil. If this variable -is non-@code{nil}, it specifies the initial execution mode for Edebug -when it is first activated. Possible values are step, next, go, -Go-nonstop, trace, Trace-fast, continue, and Continue-fast.") - -(defvar edebug-trace nil - "*Non-nil means display a trace of function entry and exit. -Tracing output is displayed in a buffer named `*edebug-trace*', one -function entry or exit per line, indented by the recursion level. - -You can customize by replacing functions `edebug-print-trace-before' -and `edebug-print-trace-after'.") - -(defvar edebug-test-coverage nil - "*If non-nil, Edebug tests coverage of all expressions debugged. -This is done by comparing the result of each expression -with the previous result. Coverage is considered OK if two different -results are found. - -Use `edebug-display-freq-count' to display the frequency count and -coverage information for a definition.") - -(defvar edebug-continue-kbd-macro nil - "*If non-nil, continue defining or executing any keyboard macro. -Use this with caution since it is not debugged.") - - -(defvar edebug-print-length 50 - "*Default value of `print-length' to use while printing results in Edebug.") -(defvar edebug-print-level 50 - "*Default value of `print-level' to use while printing results in Edebug.") -(defvar edebug-print-circle t - "*Default value of `print-circle' to use while printing results in Edebug.") - -(defvar edebug-unwrap-results nil - "*Non-nil if Edebug should unwrap results of expressions. -This is useful when debugging macros where the results of expressions -are instrumented expressions. But don't do this when results might be -circular or an infinite loop will result.") - -(defvar edebug-on-error t - "*Value bound to `debug-on-error' while Edebug is active. - -If `debug-on-error' is non-nil, that value is still used. - -If the value is a list of signal names, Edebug will stop when any of -these errors are signaled from Lisp code whether or not the signal is -handled by a `condition-case'. This option is useful for debugging -signals that *are* handled since they would otherwise be missed. -After execution is resumed, the error is signaled again.") - -(defvar edebug-on-quit t - "*Value bound to `debug-on-quit' while Edebug is active.") - -(defvar edebug-global-break-condition nil - "*If non-nil, an expression to test for at every stop point. -If the result is non-nil, then break. Errors are ignored.") - -;;; Form spec utilities. - -;;;###autoload -(defmacro def-edebug-spec (symbol spec) - "Set the edebug-form-spec property of SYMBOL according to SPEC. -Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol -\(naming a function), or a list." - (` (put (quote (, symbol)) 'edebug-form-spec (quote (, spec))))) - -(defmacro def-edebug-form-spec (symbol spec-form) - "For compatibility with old version. Use `def-edebug-spec' instead." - (message "Obsolete: use def-edebug-spec instead.") - (def-edebug-spec symbol (eval spec-form))) - -(defun get-edebug-spec (symbol) - ;; Get the spec of symbol resolving all indirection. - (let ((edebug-form-spec (get symbol 'edebug-form-spec)) - indirect) - (while (and (symbolp edebug-form-spec) - (setq indirect (get edebug-form-spec 'edebug-form-spec))) - ;; (edebug-trace "indirection: %s" edebug-form-spec) - (setq edebug-form-spec indirect)) - edebug-form-spec - )) - -;;; Utilities - -;; Define edebug-gensym - from old cl.el -(defvar edebug-gensym-index 0 - "Integer used by `edebug-gensym' to produce new names.") - -(defun edebug-gensym (&optional prefix) - "Generate a fresh uninterned symbol. -There is an optional argument, PREFIX. PREFIX is the -string that begins the new name. Most people take just the default, -except when debugging needs suggest otherwise." - (if (null prefix) - (setq prefix "G")) - (let ((newsymbol nil) - (newname "")) - (while (not newsymbol) - (setq newname (concat prefix (int-to-string edebug-gensym-index))) - (setq edebug-gensym-index (+ edebug-gensym-index 1)) - (if (not (intern-soft newname)) - (setq newsymbol (make-symbol newname)))) - newsymbol)) - -;; Only used by CL-like code. -(defun edebug-keywordp (object) - "Return t if OBJECT is a keyword. -A keyword is a symbol that starts with `:'." - (and (symbolp object) - (= ?: (aref (symbol-name object) 0)))) - -(defun edebug-lambda-list-keywordp (object) - "Return t if OBJECT is a lambda list keyword. -A lambda list keyword is a symbol that starts with `&'." - (and (symbolp object) - (= ?& (aref (symbol-name object) 0)))) - - -(defun edebug-last-sexp () - ;; Return the last sexp before point in current buffer. - ;; Assumes Emacs Lisp syntax is active. - (car - (read-from-string - (buffer-substring - (save-excursion - (forward-sexp -1) - (point)) - (point))))) - -(defun edebug-window-list () - "Return a list of windows, in order of `next-window'." - ;; This doesn't work for epoch. - (let* ((first-window (selected-window)) - (window-list (list first-window)) - (next (next-window first-window))) - (while (not (eq next first-window)) - (setq window-list (cons next window-list)) - (setq next (next-window next))) - (nreverse window-list))) - -(defun edebug-window-live-p (window) - "Return non-nil if WINDOW is visible." - (let* ((first-window (selected-window)) - (next (next-window first-window t))) - (while (not (or (eq next window) - (eq next first-window))) - (setq next (next-window next t))) - (eq next window))) - -;; Not used. -'(defun edebug-two-window-p () - "Return t if there are two windows." - (and (not (one-window-p)) - (eq (selected-window) - (next-window (next-window (selected-window)))))) - -(defsubst edebug-lookup-function (object) - (while (and (symbolp object) (fboundp object)) - (setq object (symbol-function object))) - object) - -(defun edebug-macrop (object) - "Return the macro named by OBJECT, or nil if it is not a macro." - (setq object (edebug-lookup-function object)) - (if (and (listp object) - (eq 'macro (car object)) - (edebug-functionp (cdr object))) - object)) - -(defun edebug-functionp (object) - "Returns the function named by OBJECT, or nil if it is not a function." - (setq object (edebug-lookup-function object)) - (if (or (subrp object) - (byte-code-function-p object) - (and (listp object) - (eq (car object) 'lambda) - (listp (car (cdr object))))) - object)) - -(defun edebug-sort-alist (alist function) - ;; Return the ALIST sorted with comparison function FUNCTION. - ;; This uses 'sort so the sorting is destructive. - (sort alist (function - (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. -'(defmacro edebug-save-restriction (&rest body) - "Evaluate BODY while saving the current buffers restriction. -BODY may change buffer outside of current restriction, unlike -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." - (` (let ((edebug:s-r-beg (point-min-marker)) - (edebug:s-r-end (point-max-marker))) - (unwind-protect - (progn (,@ body)) - (save-excursion - (set-buffer (marker-buffer edebug:s-r-beg)) - (narrow-to-region edebug:s-r-beg edebug:s-r-end)))))) - -;;; Display - -(defconst edebug-trace-buffer "*edebug-trace*" - "Name of the buffer to put trace info in.") - -(defun edebug-pop-to-buffer (buffer &optional window) - ;; Like pop-to-buffer, but select window where BUFFER was last shown. - ;; Select WINDOW if it provided and it still exists. Otherwise, - ;; if buffer is currently shown in several windows, choose one. - ;; Otherwise, find a new window, possibly splitting one. - (setq window (if (and (windowp window) (edebug-window-live-p window) - (eq (window-buffer window) buffer)) - window - (if (eq (window-buffer (selected-window)) buffer) - (selected-window) - (edebug-get-buffer-window buffer)))) - (if window - (select-window window) - (if (one-window-p) - (split-window)) - ;; (message "next window: %s" (next-window)) (sit-for 1) - (if (eq (get-buffer-window edebug-trace-buffer) (next-window)) - ;; Don't select trace window - nil - (select-window (next-window)))) - (set-window-buffer (selected-window) buffer) - (set-window-hscroll (selected-window) 0);; should this be?? - ;; Selecting the window does not set the buffer until command loop. - ;;(set-buffer buffer) - ) - - -(defun edebug-get-displayed-buffer-points () - ;; Return a list of buffer point pairs, for all displayed buffers. - (save-excursion - (let* ((first-window (selected-window)) - (next (next-window first-window)) - (buffer-point-list nil) - buffer) - (while (not (eq next first-window)) - (set-buffer (setq buffer (window-buffer next))) - (setq buffer-point-list - (cons (cons buffer (point)) buffer-point-list)) - (setq next (next-window next))) - buffer-point-list))) - - -(defun edebug-set-buffer-points (buffer-points) - ;; Restore the buffer-points created by edebug-get-displayed-buffer-points. - (let ((current-buffer (current-buffer))) - (mapcar (function (lambda (buf-point) - (if (buffer-name (car buf-point)) ; still exists - (progn - (set-buffer (car buf-point)) - (goto-char (cdr buf-point)))))) - buffer-points) - (set-buffer current-buffer))) - -(defun edebug-current-windows (which-windows) - ;; Get either a full window configuration or some window information. - (if (listp which-windows) - (mapcar (function (lambda (window) - (if (edebug-window-live-p window) - (list window - (window-buffer window) - (window-point window) - (window-start window) - (window-hscroll window))))) - which-windows) - (current-window-configuration))) - -(defun edebug-set-windows (window-info) - ;; Set either a full window configuration or some window information. - (if (listp window-info) - (mapcar (function - (lambda (one-window-info) - (if one-window-info - (apply (function - (lambda (window buffer point start hscroll) - (if (edebug-window-live-p window) - (progn - (set-window-buffer window buffer) - (set-window-point window point) - (set-window-start window start) - (set-window-hscroll window hscroll))))) - one-window-info)))) - 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. - -;; Use the Lisp version of eval-region. -(require 'eval-reg "eval-reg") - -;; Save the original read function -(or (fboundp 'edebug-original-read) - (defalias 'edebug-original-read (symbol-function 'read))) - -(defun edebug-read (&optional stream) - "Read one Lisp expression as text from STREAM, return as Lisp object. -If STREAM is nil, use the value of `standard-input' (which see). -STREAM or the value of `standard-input' may be: - a buffer (read from point and advance it) - a marker (read from where it points and advance it) - a function (call it with no arguments for each character, - call it with a char as argument to push a char back) - a string (takes text from string, starting at the beginning) - t (read text line using minibuffer and use it). - -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'." - (or stream (setq stream standard-input)) - (if (eq stream (current-buffer)) - (edebug-read-and-maybe-wrap-form) - (edebug-original-read stream))) - -(or (fboundp 'edebug-original-eval-defun) - (defalias 'edebug-original-eval-defun (symbol-function 'eval-defun))) - -;; We should somehow arrange to be able to do this -;; without actually replacing the eval-defun command. -(defun edebug-eval-defun (edebug-it) - "Evaluate the top-level form containing point, or after point. - -This version, from Edebug, has the following differences: With a -prefix argument instrument the code for Edebug. If `edebug-all-defs' is -non-nil, then the code is instrumented *unless* there is a prefix -argument. If instrumenting, it prints: `Edebug: FUNCTIONNAME'. -Otherwise, it prints in the minibuffer." - (interactive "P") - (let* ((edebugging (not (eq (not edebug-it) (not edebug-all-defs)))) - (edebug-result) - (form - (let ((edebug-all-forms edebugging) - (edebug-all-defs (eq edebug-all-defs (not edebug-it)))) - (edebug-read-top-level-form)))) - (if (and (eq (car form) 'defvar) - (cdr-safe (cdr-safe form))) - (setq form (cons 'defconst (cdr form)))) - (setq edebug-result (eval form)) - (if (not edebugging) - (princ edebug-result) - edebug-result))) - - -;;;###autoload -(defalias 'edebug-defun 'edebug-eval-top-level-form) - -;;;###autoload -(defun edebug-eval-top-level-form () - "Evaluate a top level form, such as a defun or defmacro. -This is like `eval-defun', but the code is always instrumented for Edebug. -Print its name in the minibuffer and leave point where it is, -or if an error occurs, leave point after it with mark at the original point." - (interactive) - (eval - ;; Bind edebug-all-forms only while reading, not while evalling - ;; but this causes problems while edebugging edebug. - (let ((edebug-all-forms t) - (edebug-all-defs t)) - (edebug-read-top-level-form)))) - - -(defun edebug-read-top-level-form () - (let ((starting-point (point))) - (end-of-defun) - (beginning-of-defun) - (prog1 - (edebug-read-and-maybe-wrap-form) - ;; Recover point, but only if no error occurred. - (goto-char starting-point)))) - - -;; Compatibility with old versions. -(defalias 'edebug-all-defuns 'edebug-all-defs) - -(defun edebug-all-defs () - "Toggle edebugging of all definitions." - (interactive) - (setq edebug-all-defs (not edebug-all-defs)) - (message "Edebugging all definitions is %s." - (if edebug-all-defs "on" "off"))) - - -(defun edebug-all-forms () - "Toggle edebugging of all forms." - (interactive) - (setq edebug-all-forms (not edebug-all-forms)) - (message "Edebugging all forms is %s." - (if edebug-all-forms "on" "off"))) - - -(defun edebug-install-read-eval-functions () - (interactive) - ;; Don't install if already installed. - (if (eq (symbol-function 'read) 'edebug-read) nil - (elisp-eval-region-install) - (defalias 'read 'edebug-read) - (defalias 'eval-defun 'edebug-eval-defun))) - -(defun edebug-uninstall-read-eval-functions () - (interactive) - (elisp-eval-region-uninstall) - (defalias 'read (symbol-function 'edebug-original-read)) - (defalias 'eval-defun (symbol-function 'edebug-original-eval-defun))) - - -;;; Edebug internal data - -;; 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) - -(defconst 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)) - -(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)) - -(defun edebug-get-form-data-entry (pnt &optional end-point) - ;; Find the edebug form data entry which is closest to PNT. - ;; If END-POINT is supplied, match must be exact. - ;; Return `nil' if none found. - (let ((rest edebug-form-data) - closest-entry - (closest-dist 999999)) ;; need maxint here - (while (and rest (< 0 closest-dist)) - (let* ((entry (car rest)) - (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))) - (setq closest-dist dist - closest-entry entry)))) - closest-entry)) - -;; Also need to find all contained entries, -;; 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))) - (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))) - -(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 entry - (progn - ;; Instead of this, we could just find all contained forms. - ;; (put (car entry) 'edebug nil) ; - ;; (mapcar 'edebug-clear-form-data-entry ; dangerous - ;; (get (car entry) 'edebug-dependents)) - ;; (set-marker (nth 1 entry) nil) - ;; (set-marker (nth 2 entry) nil) - (setq edebug-form-data (delq entry edebug-form-data))))) - -;;; Parser utilities - -(defun edebug-syntax-error (&rest args) - ;; Signal an invalid-read-syntax with ARGS. - (signal 'invalid-read-syntax args)) - - -(defconst edebug-read-syntax-table - ;; Lookup table for significant characters indicating the class of the - ;; token that follows. This is not a \"real\" syntax table. - (let ((table (make-vector 256 'symbol)) - (i 0)) - (while (< i ?!) - (aset table i 'space) - (setq i (1+ i))) - (aset table ?\( 'lparen) - (aset table ?\) 'rparen) - (aset table ?\' 'quote) - (aset table ?\` 'backquote) - (aset table ?\, 'comma) - (aset table ?\" 'string) - (aset table ?\? 'char) - (aset table ?\[ 'lbracket) - (aset table ?\] 'rbracket) - (aset table ?\. 'dot) - (aset table ?\# 'hash) - ;; We treat numbers as symbols, because of confusion with -, -1, and 1-. - ;; We don't care about any other chars since they won't be seen. - table)) - -(defun edebug-next-token-class () - ;; Move to the next token and return its class. We only care about - ;; lparen, rparen, dot, quote, backquote, comma, string, char, vector, - ;; or symbol. - (edebug-skip-whitespace) - (aref edebug-read-syntax-table (following-char))) - - -(defun edebug-skip-whitespace () - ;; Leave point before the next token, skipping white space and comments. - (skip-chars-forward " \t\r\n\f") - (while (= (following-char) ?\;) - ;; \r is counted as a comment terminator to support selective display. - (skip-chars-forward "^\n\r") ; skip the comment - (skip-chars-forward " \t\r\n\f"))) - - -;; Mostly obsolete reader; still used in one case. - -(defun edebug-read-sexp () - ;; Read one sexp from the current buffer starting at point. - ;; Leave point immediately after it. A sexp can be a list or atom. - ;; An atom is a symbol (or number), character, string, or vector. - ;; This works for reading anything legitimate, but it - ;; is gummed up by parser inconsistencies (bugs?) - (let ((class (edebug-next-token-class))) - (cond - ;; read goes one too far if a (possibly quoted) string or symbol - ;; is immediately followed by non-whitespace. - ((eq class 'symbol) (edebug-original-read (current-buffer))) - ((eq class 'string) (edebug-original-read (current-buffer))) - ((eq class 'quote) (forward-char 1) - (list 'quote (edebug-read-sexp))) - ((eq class 'backquote) - (list '\` (edebug-read-sexp))) - ((eq class 'comma) - (list '\, (edebug-read-sexp))) - (t ; anything else, just read it. - (edebug-original-read (current-buffer)))))) - -;;; Offsets for reader - -;; Define a structure to represent offset positions of expressions. -;; Each offset structure looks like: (before . after) for constituents, -;; or for structures that have elements: (before <subexpressions> . after) -;; where the <subexpressions> are the offset structures for subexpressions -;; including the head of a list. -(defconst edebug-offsets nil) - -;; Stack of offset structures in reverse order of the nesting. -;; This is used to get back to previous levels. -(defconst edebug-offsets-stack nil) -(defconst edebug-current-offset nil) ; Top of the stack, for convenience. - -;; We must store whether we just read a list with a dotted form that -;; is itself a list. This structure will be condensed, so the offsets -;; must also be condensed. -(defconst edebug-read-dotted-list nil) - -(defsubst edebug-initialize-offsets () - ;; Reinitialize offset recording. - (setq edebug-current-offset nil)) - -(defun edebug-store-before-offset (point) - ;; Add a new offset pair with POINT as the before offset. - (let ((new-offset (list point))) - (if edebug-current-offset - (setcdr edebug-current-offset - (cons new-offset (cdr edebug-current-offset))) - ;; Otherwise, we are at the top level, so initialize. - (setq edebug-offsets new-offset - edebug-offsets-stack nil - edebug-read-dotted-list nil)) - ;; Cons the new offset to the front of the stack. - (setq edebug-offsets-stack (cons new-offset edebug-offsets-stack) - edebug-current-offset new-offset) - )) - -(defun edebug-store-after-offset (point) - ;; Finalize the current offset struct by reversing it and - ;; store POINT as the after offset. - (if (not edebug-read-dotted-list) - ;; Just reverse the offsets of all subexpressions. - (setcdr edebug-current-offset (nreverse (cdr edebug-current-offset))) - - ;; We just read a list after a dot, which will be abbreviated out. - (setq edebug-read-dotted-list nil) - ;; Drop the corresponding offset pair. - ;; That is, nconc the reverse of the rest of the offsets - ;; with the cdr of last offset. - (setcdr edebug-current-offset - (nconc (nreverse (cdr (cdr edebug-current-offset))) - (cdr (car (cdr edebug-current-offset)))))) - - ;; Now append the point using nconc. - (setq edebug-current-offset (nconc edebug-current-offset point)) - ;; Pop the stack. - (setq edebug-offsets-stack (cdr edebug-offsets-stack) - edebug-current-offset (car edebug-offsets-stack))) - -(defun edebug-ignore-offset () - ;; Ignore the last created offset pair. - (setcdr edebug-current-offset (cdr (cdr edebug-current-offset)))) - -(def-edebug-spec edebug-storing-offsets (form body)) -(put 'edebug-storing-offsets 'lisp-indent-hook 1) - -(defmacro edebug-storing-offsets (point &rest body) - (` (unwind-protect - (progn - (edebug-store-before-offset (, point)) - (,@ body)) - (edebug-store-after-offset (point))))) - - -;;; Reader for Emacs Lisp. - -;; Uses edebug-next-token-class (and edebug-skip-whitespace) above. - -(defconst edebug-read-alist - '((symbol . edebug-read-symbol) - (lparen . edebug-read-list) - (string . edebug-read-string) - (quote . edebug-read-quote) - (backquote . edebug-read-backquote) - (comma . edebug-read-comma) - (lbracket . edebug-read-vector) - (hash . edebug-read-function) - )) - -(defun edebug-read-storing-offsets (stream) - (let ((class (edebug-next-token-class)) - func - edebug-read-dotted-list) ; see edebug-store-after-offset - (edebug-storing-offsets (point) - (if (setq func (assq class edebug-read-alist)) - (funcall (cdr func) stream) - ;; anything else, just read it. - (edebug-original-read stream)) - ))) - -(defun edebug-read-symbol (stream) - (edebug-original-read stream)) - -(defun edebug-read-string (stream) - (edebug-original-read stream)) - -(defun edebug-read-quote (stream) - ;; Turn 'thing into (quote thing) - (forward-char 1) - (list - (edebug-storing-offsets (point) 'quote) - (edebug-read-storing-offsets stream))) - -(defun edebug-read-backquote (stream) - ;; Turn `thing into (\` thing) - (let ((opoint (point))) - (forward-char 1) - ;; Generate the same structure of offsets we would have - ;; if the resulting list appeared verbatim in the input text. - (edebug-storing-offsets opoint - (list - (edebug-storing-offsets opoint '\`) - (edebug-read-storing-offsets stream))))) - -(defvar edebug-read-backquote-new nil - "Non-nil if reading the inside of a new-style backquote with no parens around it. -Value of nil means reading the inside of an old-style backquote construct -which is surrounded by an extra set of parentheses. -This controls how we read comma constructs.") - -(defun edebug-read-comma (stream) - ;; Turn ,thing into (\, thing). Handle ,@ and ,. also. - (let ((opoint (point))) - (forward-char 1) - (let ((symbol '\,)) - (cond ((eq (following-char) ?\.) - (setq symbol '\,\.) - (forward-char 1)) - ((eq (following-char) ?\@) - (setq symbol '\,@) - (forward-char 1))) - ;; Generate the same structure of offsets we would have - ;; if the resulting list appeared verbatim in the input text. - (if edebug-read-backquote-new - (list - (edebug-storing-offsets opoint symbol) - (edebug-read-storing-offsets stream)) - (edebug-storing-offsets opoint symbol))))) - -(defun edebug-read-function (stream) - ;; Turn #'thing into (function thing) - (forward-char 1) - (if (/= ?\' (following-char)) (edebug-syntax-error "Bad char")) - (forward-char 1) - (list - (edebug-storing-offsets (point) - (if (featurep 'cl) 'function* 'function)) - (edebug-read-storing-offsets stream))) - -(defun edebug-read-list (stream) - (forward-char 1) ; skip \( - (prog1 - (let ((elements)) - (while (not (memq (edebug-next-token-class) '(rparen dot))) - (if (eq (edebug-next-token-class) 'backquote) - (let ((edebug-read-backquote-new (not (null elements))) - (opoint (point))) - (if edebug-read-backquote-new - (setq elements (cons (edebug-read-backquote stream) elements)) - (forward-char 1) ; Skip backquote. - ;; Call edebug-storing-offsets here so that we - ;; produce the same offsets we would have had - ;; if the backquote were an ordinary symbol. - (setq elements (cons (edebug-storing-offsets opoint '\`) - elements)))) - (setq elements (cons (edebug-read-storing-offsets stream) elements)))) - (setq elements (nreverse elements)) - (if (eq 'dot (edebug-next-token-class)) - (let (dotted-form) - (forward-char 1) ; skip \. - (setq dotted-form (edebug-read-storing-offsets stream)) - elements (nconc elements dotted-form) - (if (not (eq (edebug-next-token-class) 'rparen)) - (edebug-syntax-error "Expected `)'")) - (setq edebug-read-dotted-list (listp dotted-form)) - )) - elements) - (forward-char 1) ; skip \) - )) - -(defun edebug-read-vector (stream) - (forward-char 1) ; skip \[ - (prog1 - (let ((elements)) - (while (not (eq 'rbracket (edebug-next-token-class))) - (setq elements (cons (edebug-read-storing-offsets stream) elements))) - (apply 'vector (nreverse elements))) - (forward-char 1) ; skip \] - )) - -;;; Cursors for traversal of list and vector elements with offsets. - -(defvar edebug-dotted-spec nil) - -(defun edebug-new-cursor (expressions offsets) - ;; Return a new cursor for EXPRESSIONS with OFFSETS. - (if (vectorp expressions) - (setq expressions (append expressions nil))) - (cons expressions offsets)) - -(defsubst edebug-set-cursor (cursor expressions offsets) - ;; Set the CURSOR's EXPRESSIONS and OFFSETS to the given. - ;; Return the cursor. - (setcar cursor expressions) - (setcdr cursor offsets) - cursor) - -'(defun edebug-copy-cursor (cursor) - ;; Copy the cursor using the same object and offsets. - (cons (car cursor) (cdr cursor))) - -(defsubst edebug-cursor-expressions (cursor) - (car cursor)) -(defsubst edebug-cursor-offsets (cursor) - (cdr cursor)) - -(defsubst edebug-empty-cursor (cursor) - ;; Return non-nil if CURSOR is empty - meaning no more elements. - (null (car cursor))) - -(defsubst edebug-top-element (cursor) - ;; Return the top element at the cursor. - ;; Assumes not empty. - (car (car cursor))) - -(defun edebug-top-element-required (cursor &rest error) - ;; Check if a dotted form is required. - (if edebug-dotted-spec (edebug-no-match cursor "Dot expected.")) - ;; Check if there is at least one more argument. - (if (edebug-empty-cursor cursor) (apply 'edebug-no-match cursor error)) - ;; Return that top element. - (edebug-top-element cursor)) - -(defsubst edebug-top-offset (cursor) - ;; Return the top offset pair corresponding to the top element. - (car (cdr cursor))) - -(defun edebug-move-cursor (cursor) - ;; Advance and return the cursor to the next element and offset. - ;; throw no-match if empty before moving. - ;; This is a violation of the cursor encapsulation, but - ;; there is plenty of that going on while matching. - ;; The following test should always fail. - (if (edebug-empty-cursor cursor) - (edebug-no-match cursor "Not enough arguments.")) - (setcar cursor (cdr (car cursor))) - (setcdr cursor (cdr (cdr cursor))) - cursor) - - -(defun edebug-before-offset (cursor) - ;; Return the before offset of the cursor. - ;; If there is nothing left in the offsets, - ;; return one less than the offset itself, - ;; which is the after offset for a list. - (let ((offset (edebug-cursor-offsets cursor))) - (if (consp offset) - (car (car offset)) - (1- offset)))) - -(defun edebug-after-offset (cursor) - ;; Return the after offset of the cursor object. - (let ((offset (edebug-top-offset cursor))) - (while (consp offset) - (setq offset (cdr offset))) - offset)) - -;;; The Parser - -;; The top level function for parsing forms is -;; edebug-read-and-maybe-wrap-form; it calls all the rest. It checks the -;; syntax a bit and leaves point at any error it finds, but otherwise -;; should appear to work like eval-defun. - -;; The basic plan is to surround each expression with a call to -;; the edebug debugger together with indexes into a table of positions of -;; all expressions. Thus an expression "exp" becomes: - -;; (edebug-after (edebug-before 1) 2 exp) - -;; When this is evaluated, first point is moved to the beginning of -;; exp at offset 1 of the current function. The expression is -;; evaluated, which may cause more edebug calls, and then point is -;; moved to offset 2 after the end of exp. - -;; The highest level expressions of the function are wrapped in a call to -;; edebug-enter, which supplies the function name and the actual -;; arguments to the function. See functions edebug-enter, edebug-before, -;; and edebug-after for more details. - -;; Dynamically bound vars, left unbound, but globally declared. -;; This is to quiet the byte compiler. - -;; Window data of the highest definition being wrapped. -;; This data is shared by all embedded definitions. -(defvar edebug-top-window-data) - -(defvar edebug-&optional) -(defvar edebug-&rest) -(defvar edebug-gate nil) ;; whether no-match forces an error. - -(defconst edebug-def-name nil) ; name of definition, used by interactive-form -(defconst edebug-old-def-name nil) ; previous name of containing definition. - -(defconst edebug-error-point nil) -(defconst edebug-best-error nil) - - -(defun edebug-read-and-maybe-wrap-form () - ;; Read a form and wrap it with edebug calls, if the conditions are right. - ;; Here we just catch any no-match not caught below and signal an error. - - ;; Run the setup hook. - (run-hooks 'edebug-setup-hook) - (setq edebug-setup-hook nil) - - (let (result - edebug-top-window-data - edebug-def-name;; make sure it is locally nil - ;; I don't like these here!! - edebug-&optional - edebug-&rest - edebug-gate - edebug-best-error - edebug-error-point - no-match - ;; Do this once here instead of several times. - (max-lisp-eval-depth (+ 800 max-lisp-eval-depth)) - (max-specpdl-size (+ 2000 max-specpdl-size))) - (setq no-match - (catch 'no-match - (setq result (edebug-read-and-maybe-wrap-form1)) - nil)) - (if no-match - (apply 'edebug-syntax-error no-match)) - result)) - - -(defun edebug-read-and-maybe-wrap-form1 () - (let (spec - def-kind - defining-form-p - def-name - ;; These offset things don't belong here, but to support recursive - ;; calls to edebug-read, they need to be here. - edebug-offsets - edebug-offsets-stack - edebug-current-offset ; reset to nil - ) - (save-excursion - (if (and (eq 'lparen (edebug-next-token-class)) - (eq 'symbol (progn (forward-char 1) (edebug-next-token-class)))) - ;; Find out if this is a defining form from first symbol - (setq def-kind (edebug-original-read (current-buffer)) - spec (and (symbolp def-kind) (get-edebug-spec def-kind)) - defining-form-p (and (listp spec) - (eq '&define (car spec))) - ;; This is incorrect in general!! But OK most of the time. - def-name (if (and defining-form-p - (eq 'name (car (cdr spec))) - (eq 'symbol (edebug-next-token-class))) - (edebug-original-read (current-buffer)))))) -;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) - (cond - (defining-form-p - (if (or edebug-all-defs edebug-all-forms) - ;; If it is a defining form and we are edebugging defs, - ;; then let edebug-list-form start it. - (let ((cursor (edebug-new-cursor - (list (edebug-read-storing-offsets (current-buffer))) - (list edebug-offsets)))) - (car - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - (1- (edebug-after-offset cursor)) - (list (cons (symbol-name def-kind) (cdr spec)))))) - - ;; Not edebugging this form, so reset the symbol's edebug - ;; property to be just a marker at the definition's source code. - ;; This only works for defs with simple names. - (put def-name 'edebug (point-marker)) - ;; Also nil out dependent defs. - '(mapcar (function - (lambda (def) - (put def-name 'edebug nil))) - (get def-name 'edebug-dependents)) - (edebug-read-sexp))) - - ;; If all forms are being edebugged, explicitly wrap it. - (edebug-all-forms - (let ((cursor (edebug-new-cursor - (list (edebug-read-storing-offsets (current-buffer))) - (list edebug-offsets)))) - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - (edebug-after-offset cursor) - nil))) - - ;; Not a defining form, and not edebugging. - (t (edebug-read-sexp))) - )) - - -(defvar edebug-def-args) ; args of defining form. -(defvar edebug-def-interactive) ; is it an emacs interactive function? -(defvar edebug-inside-func) ;; whether code is inside function context. -;; Currently def-form sets this to nil; def-body sets it to t. - -(defun edebug-interactive-p-name () - ;; Return a unique symbol for the variable used to store the - ;; status of interactive-p for this function. - (intern (format "edebug-%s-interactive-p" edebug-def-name))) - - -(defun edebug-wrap-def-body (forms) - "Wrap the FORMS of a definition body." - (if edebug-def-interactive - (` (let (((, (edebug-interactive-p-name)) - (interactive-p))) - (, (edebug-make-enter-wrapper forms)))) - (edebug-make-enter-wrapper forms))) - - -(defun edebug-make-enter-wrapper (forms) - ;; Generate the enter wrapper for some forms of a definition. - ;; This is not to be used for the body of other forms, e.g. `while', - ;; since it wraps the list of forms with a call to `edebug-enter'. - ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args. - ;; Do this after parsing since that may find a name. - (setq edebug-def-name - (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon"))) - (` (edebug-enter - (quote (, edebug-def-name)) - (, (if edebug-inside-func - (` (list (,@ - ;; Doesn't work with more than one def-body!! - ;; But the list will just be reversed. - (nreverse edebug-def-args)))) - 'nil)) - (function (lambda () (,@ forms))) - ))) - - -(defvar edebug-form-begin-marker) ; the mark for def being instrumented - -(defvar edebug-offset-index) ; the next available offset index. -(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 - (prog1 - edebug-offset-index - (setq edebug-offset-list (cons (- offset edebug-form-begin-marker) - edebug-offset-list) - edebug-offset-index (1+ edebug-offset-index)))) - - -(defun edebug-make-before-and-after-form (before-index form after-index) - ;; Return the edebug form for the current function at offset BEFORE-INDEX - ;; given FORM. Looks like: - ;; (edebug-after (edebug-before BEFORE-INDEX) AFTER-INDEX FORM) - ;; Also increment the offset index for subsequent use. - ;; if (not edebug-stop-before-symbols) and form is a symbol, - ;; then don't call edebug-before. - (list 'edebug-after - (list '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)) - - -(defun edebug-unwrap (sexp) - "Return the unwrapped SEXP or return it as is if it is not wrapped. -The SEXP might be the result of wrapping a body, which is a list of -expressions; a `progn' form will be returned enclosing these forms." - (if (consp sexp) - (cond - ((eq 'edebug-after (car sexp)) - (nth 3 sexp)) - ((eq 'edebug-enter (car sexp)) - (let ((forms (nthcdr 2 (nth 1 (nth 3 sexp))))) - (if (> (length forms) 1) - (cons 'progn forms) ;; could return (values forms) instead. - (car forms)))) - (t sexp);; otherwise it is not wrapped, so just return it. - ) - sexp)) - -(defun edebug-unwrap* (sexp) - "Return the sexp recursively unwrapped." - (let ((new-sexp (edebug-unwrap sexp))) - (while (not (eq sexp new-sexp)) - (setq sexp new-sexp - new-sexp (edebug-unwrap sexp))) - (if (consp new-sexp) - (mapcar 'edebug-unwrap* new-sexp) - new-sexp))) - - -(defun edebug-defining-form (cursor form-begin form-end speclist) - ;; Process the defining form, starting outside the form. - ;; The speclist is a generated list spec that looks like: - ;; (("def-symbol" defining-form-spec-sans-&define)) - ;; Skip the first offset. - (edebug-set-cursor cursor (edebug-cursor-expressions cursor) - (cdr (edebug-cursor-offsets cursor))) - (edebug-make-form-wrapper - cursor - form-begin (1- form-end) - speclist)) - -(defun edebug-make-form-wrapper (cursor form-begin form-end - &optional speclist) - ;; Wrap a form, usually a defining form, but any evaluated one. - ;; If speclist is non-nil, this is being called by edebug-defining-form. - ;; Otherwise it is being called from edebug-read-and-maybe-wrap-form1. - ;; This is a hack, but I havent figured out a simpler way yet. - (let* ((form-data-entry (edebug-get-form-data-entry form-begin form-end)) - ;; Set this marker before parsing. - (edebug-form-begin-marker - (if 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)))) - - (let (edebug-offset-list - (edebug-offset-index 0) - result - ;; 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-def-name - edebug-def-args - edebug-def-interactive - edebug-inside-func;; whether wrapped code executes inside a function. - ) - - (setq result - (if speclist - (edebug-match cursor speclist) - - ;; else wrap as an enter-form. - (edebug-make-enter-wrapper (list (edebug-form cursor))))) - - ;; Set the name here if it was not set by edebug-make-enter-wrapper. - (setq edebug-def-name - (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon"))) - - ;; Add this def as a dependent of containing def. Buggy. - '(if (and edebug-containing-def-name - (not (get edebug-containing-def-name 'edebug-dependents))) - (put edebug-containing-def-name 'edebug-dependents - (cons edebug-def-name - (get edebug-containing-def-name - 'edebug-dependents)))) - - ;; Create a form-data-entry or modify existing entry's markers. - ;; 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-def-name - edebug-form-begin-marker - ;; Buffer must be current-buffer. - (set-marker (make-marker) form-end) - )) - (edebug-set-form-data-entry - form-data-entry edebug-def-name ;; in case name is changed - form-begin form-end)) - - ;; (message "defining: %s" edebug-def-name) (sit-for 2) - (edebug-make-top-form-data-entry form-data-entry) - (message "Edebug: %s" edebug-def-name) - ;;(debug edebug-def-name) - - ;; Destructively reverse edebug-offset-list and make vector from it. - (setq edebug-offset-list (vconcat (nreverse edebug-offset-list))) - - ;; Side effects on the property list of edebug-def-name. - (edebug-clear-frequency-count edebug-def-name) - (edebug-clear-coverage edebug-def-name) - - ;; Set up the initial window data. - (if (not edebug-top-window-data) ;; if not already set, do it now. - (let ((window ;; Find the best window for this buffer. - (or (get-buffer-window (current-buffer)) - (selected-window)))) - (setq edebug-top-window-data - (cons window (window-start window))))) - - ;; Store the edebug data in symbol's property list. - (put edebug-def-name 'edebug - ;; A struct or vector would be better here!! - (list edebug-form-begin-marker - nil ; clear breakpoints - edebug-offset-list - edebug-top-window-data - )) - result - ))) - - -(defun edebug-clear-frequency-count (name) - ;; Create initial frequency count vector. - ;; For each stop point, the counter is incremented each time it is visited. - (put name 'edebug-freq-count - (make-vector (length edebug-offset-list) 0))) - - -(defun edebug-clear-coverage (name) - ;; Create initial coverage vector. - ;; Only need one per expression, but it is simpler to use stop points. - (put name 'edebug-coverage - (make-vector (length edebug-offset-list) 'unknown))) - - -(defun edebug-form (cursor) - ;; Return the instrumented form for the following form. - ;; Add the point offsets to the edebug-offset-list for the form. - (let* ((form (edebug-top-element-required cursor "Expected form")) - (offset (edebug-top-offset cursor))) - (prog1 - (cond - ((consp form) - ;; The first offset for a list form is for the list form itself. - (if (eq 'quote (car form)) - form - (let* ((head (car form)) - (spec (and (symbolp head) (get-edebug-spec head))) - (new-cursor (edebug-new-cursor form offset))) - ;; Find out if this is a defining form from first symbol. - ;; An indirect spec would not work here, yet. - (if (and (consp spec) (eq '&define (car spec))) - (edebug-defining-form - new-cursor - (car offset);; before the form - (edebug-after-offset cursor) - (cons (symbol-name head) (cdr spec))) - ;; Wrap a regular form. - (edebug-make-before-and-after-form - (edebug-inc-offset (car offset)) - (edebug-list-form new-cursor) - ;; After processing the list form, the new-cursor is left - ;; with the offset after the form. - (edebug-inc-offset (edebug-cursor-offsets new-cursor)))) - ))) - - ((symbolp form) - (cond - ;; Check for constant symbols that don't get wrapped. - ((or (memq form '(t nil)) - (and (fboundp 'edebug-keywordp) (edebug-keywordp form))) - form) - - ;; This option may go away. - (edebug-stop-before-symbols - (edebug-make-before-and-after-form - (edebug-inc-offset (car offset)) - form - (edebug-inc-offset (cdr offset)) - )) - - (t ;; just a variable - (edebug-make-after-form form (edebug-inc-offset (cdr offset)))))) - - ;; Anything else is self-evaluating. - (t form)) - (edebug-move-cursor cursor)))) - - -(defsubst edebug-forms (cursor) (edebug-match cursor '(&rest form))) -(defsubst edebug-sexps (cursor) (edebug-match cursor '(&rest sexp))) - -(defsubst edebug-list-form-args (head cursor) - ;; Process the arguments of a list form given that head of form is a symbol. - ;; Helper for edebug-list-form - (let ((spec (get-edebug-spec head))) - (cond - (spec - (cond - ((consp spec) - ;; It is a speclist. - (let (edebug-best-error - edebug-error-point);; This may not be needed. - (edebug-match-sublist cursor spec))) - ((eq t spec) (edebug-forms cursor)) - ((eq 0 spec) (edebug-sexps cursor)) - ((symbolp spec) (funcall spec cursor));; Not used by edebug, - ; but leave it in for compatibility. - )) - ;; No edebug-form-spec provided. - ((edebug-macrop head) - (if edebug-eval-macro-args - (edebug-forms cursor) - (edebug-sexps cursor))) - (t ;; Otherwise it is a function call. - (edebug-forms cursor))))) - - -(defun edebug-list-form (cursor) - ;; Return an instrumented form built from the list form. - ;; The after offset will be left in the cursor after processing the form. - (let ((head (edebug-top-element-required cursor "Expected elements")) - ;; Prevent backtracking whenever instrumenting. - (edebug-gate t) - ;; A list form is never optional because it matches anything. - (edebug-&optional nil) - (edebug-&rest nil)) - ;; Skip the first offset. - (edebug-set-cursor cursor (edebug-cursor-expressions cursor) - (cdr (edebug-cursor-offsets cursor))) - (cond - ((null head) nil) ; () is legal. - - ((symbolp head) - (cond - ((null head) - (edebug-syntax-error "nil head")) - ((eq head 'interactive-p) - ;; Special case: replace (interactive-p) with variable - (setq edebug-def-interactive 'check-it) - (edebug-move-cursor cursor) - (edebug-interactive-p-name)) - (t - (cons head (edebug-list-form-args - head (edebug-move-cursor cursor)))))) - - ((consp head) - (if (and (listp head) (eq (car head) ',)) - (edebug-match cursor '(("," def-form) body)) - ;; Process anonymous function and args. - ;; This assumes no anonymous macros. - (edebug-match-specs cursor '(lambda-expr body) 'edebug-match-specs))) - - (t (edebug-syntax-error - "Head of list form must be a symbol or lambda expression."))) - )) - -;;; Matching of specs. - -(defvar edebug-after-dotted-spec nil) - -(defvar edebug-matching-depth 0) ;; initial value -(defconst edebug-max-depth 150) ;; maximum number of matching recursions. - - -;;; Failure to match - -;; This throws to no-match, if there are higher alternatives. -;; 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) - ;; 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)) - (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))) - - -(defun edebug-match (cursor specs) - ;; Top level spec matching function. - ;; Used also at each lower level of specs. - (let (edebug-&optional - edebug-&rest - edebug-best-error - edebug-error-point - (edebug-gate edebug-gate) ;; locally bound to limit effect - ) - (edebug-match-specs cursor specs 'edebug-match-specs))) - - -(defun edebug-match-one-spec (cursor spec) - ;; Match one spec, which is not a keyword &-spec. - (cond - ((symbolp spec) (edebug-match-symbol cursor spec)) - ((vectorp spec) (edebug-match cursor (append spec nil))) - ((stringp spec) (edebug-match-string cursor spec)) - ((listp spec) (edebug-match-list cursor spec)) - )) - - -(defun edebug-match-specs (cursor specs remainder-handler) - ;; Append results of matching the list of specs. - ;; The first spec is handled and the remainder-handler handles the rest. - (let ((edebug-matching-depth - (if (> edebug-matching-depth edebug-max-depth) - (error "too deep - perhaps infinite loop in spec?") - (1+ edebug-matching-depth)))) - (cond - ((null specs) nil) - - ;; Is the spec dotted? - ((atom specs) - (let ((edebug-dotted-spec t));; Containing spec list was dotted. - (edebug-match-specs cursor (list specs) remainder-handler))) - - ;; Is the form dotted? - ((not (listp (edebug-cursor-expressions cursor)));; allow nil - (if (not edebug-dotted-spec) - (edebug-no-match cursor "Dotted spec required.")) - ;; Cancel dotted spec and dotted form. - (let ((edebug-dotted-spec) - (this-form (edebug-cursor-expressions cursor)) - (this-offset (edebug-cursor-offsets cursor))) - ;; Wrap the form in a list, (by changing the cursor??)... - (edebug-set-cursor cursor (list this-form) this-offset) - ;; and process normally, then unwrap the result. - (car (edebug-match-specs cursor specs remainder-handler)))) - - (t;; Process normally. - (let* ((spec (car specs)) - (rest) - (first-char (and (symbolp spec) (aref (symbol-name spec) 0)))) - ;;(message "spec = %s first char = %s" spec first-char) (sit-for 1) - (nconc - (cond - ((eq ?& first-char);; "&" symbols take all following specs. - (funcall (get-edebug-spec spec) cursor (cdr specs))) - ((eq ?: first-char);; ":" symbols take one following spec. - (setq rest (cdr (cdr specs))) - (funcall (get-edebug-spec spec) cursor (car (cdr specs)))) - (t;; Any other normal spec. - (setq rest (cdr specs)) - (edebug-match-one-spec cursor spec))) - (funcall remainder-handler cursor rest remainder-handler))))))) - - -;; Define specs for all the symbol specs with functions used to process them. -;; Perhaps we shouldn't be doing this with edebug-form-specs since the -;; user may want to define macros or functions with the same names. -;; We could use an internal obarray for these primitive specs. - -(mapcar - (function (lambda (pair) - (put (car pair) 'edebug-form-spec (cdr pair)))) - '((&optional . edebug-match-&optional) - (&rest . edebug-match-&rest) - (&or . edebug-match-&or) - (form . edebug-match-form) - (sexp . edebug-match-sexp) - (body . edebug-match-body) - (&define . edebug-match-&define) - (name . edebug-match-name) - (:name . edebug-match-colon-name) - (arg . edebug-match-arg) - (def-body . edebug-match-def-body) - (def-form . edebug-match-def-form) - ;; Less frequently used: - ;; (function . edebug-match-function) - (lambda-expr . edebug-match-lambda-expr) - (¬ . edebug-match-¬) - (&key . edebug-match-&key) - (place . edebug-match-place) - (gate . edebug-match-gate) - ;; (nil . edebug-match-nil) not this one - special case it. - )) - -(defun edebug-match-symbol (cursor symbol) - ;; Match a symbol spec. - (let* ((spec (get-edebug-spec symbol))) - (cond - (spec - (if (consp spec) - ;; It is an indirect spec. - (edebug-match cursor spec) - ;; Otherwise it should be the symbol name of a function. - ;; There could be a bug here - maybe need to do edebug-match bindings. - (funcall spec cursor))) - - ((null symbol) ;; special case this. - (edebug-match-nil cursor)) - - ((fboundp symbol) ; is it a predicate? - (let ((sexp (edebug-top-element-required cursor "Expected" symbol))) - ;; Special case for edebug-`. - (if (and (listp sexp) (eq (car sexp) ',)) - (edebug-match cursor '(("," def-form))) - (if (not (funcall symbol sexp)) - (edebug-no-match cursor symbol "failed")) - (edebug-move-cursor cursor) - (list sexp)))) - (t (error "%s is not a form-spec or function" symbol)) - ))) - - -(defun edebug-match-sexp (cursor) - (list (prog1 (edebug-top-element-required cursor "Expected sexp") - (edebug-move-cursor cursor)))) - -(defun edebug-match-form (cursor) - (list (edebug-form cursor))) - -(defalias 'edebug-match-place 'edebug-match-form) - ;; Currently identical to edebug-match-form. - ;; This is for common lisp setf-style place arguments. - -(defsubst edebug-match-body (cursor) (edebug-forms cursor)) - -(defun edebug-match-&optional (cursor specs) - ;; Keep matching until one spec fails. - (edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper)) - -(defun edebug-&optional-wrapper (cursor specs remainder-handler) - (let (result - (edebug-&optional specs) - (edebug-gate nil) - (this-form (edebug-cursor-expressions cursor)) - (this-offset (edebug-cursor-offsets cursor))) - (if (null (catch 'no-match - (setq result - (edebug-match-specs cursor specs remainder-handler)) - ;; Returning nil means no no-match was thrown. - nil)) - result - ;; no-match, but don't fail; just reset cursor and return nil. - (edebug-set-cursor cursor this-form this-offset) - nil))) - - -(defun edebug-&rest-wrapper (cursor specs remainder-handler) - (if (null specs) (setq specs edebug-&rest)) - ;; Reuse the &optional handler with this as the remainder handler. - (edebug-&optional-wrapper cursor specs remainder-handler)) - -(defun edebug-match-&rest (cursor specs) - ;; Repeatedly use specs until failure. - (let ((edebug-&rest specs) ;; remember these - edebug-best-error - edebug-error-point) - (edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper))) - - -(defun edebug-match-&or (cursor specs) - ;; Keep matching until one spec succeeds, and return its results. - ;; If none match, fail. - ;; This needs to be optimized since most specs spend time here. - (let ((original-specs specs) - (this-form (edebug-cursor-expressions cursor)) - (this-offset (edebug-cursor-offsets cursor))) - (catch 'matched - (while specs - (catch 'no-match - (throw 'matched - (let (edebug-gate ;; only while matching each spec - edebug-best-error - edebug-error-point) - ;; Doesn't support e.g. &or symbolp &rest form - (edebug-match-one-spec cursor (car specs))))) - ;; Match failed, so reset and try again. - (setq specs (cdr specs)) - ;; Reset the cursor for the next match. - (edebug-set-cursor cursor this-form this-offset)) - ;; All failed. - (apply 'edebug-no-match cursor "Expected one of" original-specs)) - )) - - -(defun edebug-match-¬ (cursor specs) - ;; If any specs match, then fail - (if (null (catch 'no-match - (let ((edebug-gate nil)) - (save-excursion - (edebug-match-&or cursor specs))) - nil)) - ;; This means something matched, so it is a no match. - (edebug-no-match cursor "Unexpected")) - ;; This means nothing matched, so it is OK. - nil) ;; So, return nothing - - -(def-edebug-spec &key edebug-match-&key) - -(defun edebug-match-&key (cursor specs) - ;; Following specs must look like (<name> <spec>) ... - ;; where <name> is the name of a keyword, and spec is its spec. - ;; This really doesn't save much over the expanded form and takes time. - (edebug-match-&rest - cursor - (cons '&or - (mapcar (function (lambda (pair) - (vector (format ":%s" (car pair)) - (car (cdr pair))))) - specs)))) - - -(defun edebug-match-gate (cursor) - ;; Simply set the gate to prevent backtracking at this level. - (setq edebug-gate t) - nil) - - -(defun edebug-match-list (cursor specs) - ;; The spec is a list, but what kind of list, and what context? - (if edebug-dotted-spec - ;; After dotted spec but form did not contain dot, - ;; so match list spec elements as if spliced in. - (prog1 - (let ((edebug-dotted-spec)) - (edebug-match-specs cursor specs 'edebug-match-specs)) - ;; If it matched, really clear the dotted-spec flag. - (setq edebug-dotted-spec nil)) - (let ((spec (car specs)) - (form (edebug-top-element-required cursor "Expected" specs))) - (cond - ((eq 'quote spec) - (let ((spec (car (cdr specs)))) - (cond - ((symbolp spec) - ;; Special case: spec quotes a symbol to match. - ;; Change in future. Use "..." instead. - (if (not (eq spec form)) - (edebug-no-match cursor "Expected" spec)) - (edebug-move-cursor cursor) - (setq edebug-gate t) - form) - (t - (error "Bad spec: %s" specs))))) - - ((listp form) - (prog1 - (list (edebug-match-sublist - ;; First offset is for the list form itself. - ;; Treat nil as empty list. - (edebug-new-cursor form (cdr (edebug-top-offset cursor))) - specs)) - (edebug-move-cursor cursor))) - - ((and (eq 'vector spec) (vectorp form)) - ;; Special case: match a vector with the specs. - (let ((result (edebug-match-sublist - (edebug-new-cursor - form (cdr (edebug-top-offset cursor))) - (cdr specs)))) - (edebug-move-cursor cursor) - (list (apply 'vector result)))) - - (t (edebug-no-match cursor "Expected" specs))) - ))) - - -(defun edebug-match-sublist (cursor specs) - ;; Match a sublist of specs. - (let (edebug-&optional - ;;edebug-best-error - ;;edebug-error-point - ) - (prog1 - ;; match with edebug-match-specs so edebug-best-error is not bound. - (edebug-match-specs cursor specs 'edebug-match-specs) - (if (not (edebug-empty-cursor cursor)) - (if edebug-best-error - (apply 'edebug-no-match cursor edebug-best-error) - ;; A failed &rest or &optional spec may leave some args. - (edebug-no-match cursor "Failed matching" specs) - ))))) - - -(defun edebug-match-string (cursor spec) - (let ((sexp (edebug-top-element-required cursor "Expected" spec))) - (if (not (eq (intern spec) sexp)) - (edebug-no-match cursor "Expected" spec) - ;; Since it matched, failure means immediate error, unless &optional. - (setq edebug-gate t) - (edebug-move-cursor cursor) - (list sexp) - ))) - -(defun edebug-match-nil (cursor) - ;; There must be nothing left to match a nil. - (if (not (edebug-empty-cursor cursor)) - (edebug-no-match cursor "Unmatched argument(s)") - nil)) - - -(defun edebug-match-function (cursor) - (error "Use function-form instead of function in edebug spec")) - -(defun edebug-match-&define (cursor specs) - ;; Match a defining form. - ;; Normally, &define is interpreted specially other places. - ;; This should only be called inside of a spec list to match the remainder - ;; of the current list. e.g. ("lambda" &define args def-body) - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - ;; Find the last offset in the list. - (let ((offsets (edebug-cursor-offsets cursor))) - (while (consp offsets) (setq offsets (cdr offsets))) - offsets) - specs)) - -(defun edebug-match-lambda-expr (cursor) - ;; The expression must be a function. - ;; This will match any list form that begins with a symbol - ;; that has an edebug-form-spec beginning with &define. In - ;; practice, only lambda expressions should be used. - ;; I could add a &lambda specification to avoid confusion. - (let* ((sexp (edebug-top-element-required - cursor "Expected lambda expression")) - (offset (edebug-top-offset cursor)) - (head (and (consp sexp) (car sexp))) - (spec (and (symbolp head) (get-edebug-spec head))) - (edebug-inside-func nil)) - ;; Find out if this is a defining form from first symbol. - (if (and (consp spec) (eq '&define (car spec))) - (prog1 - (list - (edebug-defining-form - (edebug-new-cursor sexp offset) - (car offset);; before the sexp - (edebug-after-offset cursor) - (cons (symbol-name head) (cdr spec)))) - (edebug-move-cursor cursor)) - (edebug-no-match cursor "Expected lambda expression") - ))) - - -(defun edebug-match-name (cursor) - ;; Set the edebug-def-name bound in edebug-defining-form. - (let ((name (edebug-top-element-required cursor "Expected name"))) - ;; Maybe strings and numbers could be used. - (if (not (symbolp name)) - (edebug-no-match cursor "Symbol expected for name of definition")) - (setq edebug-def-name - (if edebug-def-name - ;; Construct a new name by appending to previous name. - (intern (format "%s@%s" edebug-def-name name)) - name)) - (edebug-move-cursor cursor) - (list name))) - -(defun edebug-match-colon-name (cursor spec) - ;; Set the edebug-def-name to the spec. - (setq edebug-def-name - (if edebug-def-name - ;; Construct a new name by appending to previous name. - (intern (format "%s@%s" edebug-def-name spec)) - spec)) - nil) - -(defun edebug-match-arg (cursor) - ;; set the def-args bound in edebug-defining-form - (let ((edebug-arg (edebug-top-element-required cursor "Expected arg"))) - (if (or (not (symbolp edebug-arg)) - (edebug-lambda-list-keywordp edebug-arg)) - (edebug-no-match cursor "Bad argument:" edebug-arg)) - (edebug-move-cursor cursor) - (setq edebug-def-args (cons edebug-arg edebug-def-args)) - (list edebug-arg))) - -(defun edebug-match-def-form (cursor) - ;; Like form but the form is wrapped in edebug-enter form. - ;; The form is assumed to be executing outside of the function context. - ;; This is a hack for now, since a def-form might execute inside as well. - ;; Not to be used otherwise. - (let ((edebug-inside-func nil)) - (list (edebug-make-enter-wrapper (list (edebug-form cursor)))))) - -(defun edebug-match-def-body (cursor) - ;; Like body but body is wrapped in edebug-enter form. - ;; The body is assumed to be executing inside of the function context. - ;; Not to be used otherwise. - (let ((edebug-inside-func t)) - (list (edebug-wrap-def-body (edebug-forms cursor))))) - - -;;;; Edebug Form Specs -;;; ========================================================== -;;; See cl-specs.el for common lisp specs. - -;;;;* Spec for def-edebug-spec -;;; Out of date. - -(defun edebug-spec-p (object) - "Return non-nil if OBJECT is a symbol with an edebug-form-spec property." - (and (symbolp object) - (get object 'edebug-form-spec))) - -(def-edebug-spec def-edebug-spec - ;; Top level is different from lower levels. - (&define :name edebug-spec name - &or "nil" edebug-spec-p "t" "0" (&rest edebug-spec))) - -(def-edebug-spec edebug-spec-list - ;; A list must have something in it, or it is nil, a symbolp - ((edebug-spec . [&or nil edebug-spec]))) - -(def-edebug-spec edebug-spec - (&or - (vector &rest edebug-spec) ; matches a vector - ("vector" &rest edebug-spec) ; matches a vector spec - ("quote" symbolp) - edebug-spec-list - stringp - [edebug-lambda-list-keywordp &rest edebug-spec] - ;; [edebug-keywordp gate edebug-spec] ;; need edebug-keywordp for this. - edebug-spec-p ;; Including all the special ones e.g. form. - symbolp;; a predicate - )) - - -;;;* Emacs special forms and some functions. - -;; quote expects only one argument, although it allows any number. -(def-edebug-spec quote sexp) - -;; The standard defining forms. -(def-edebug-spec defconst defvar) -(def-edebug-spec defvar (symbolp &optional form stringp)) - -(def-edebug-spec defun - (&define name lambda-list - [&optional stringp] - [&optional ("interactive" interactive)] - def-body)) -(def-edebug-spec defmacro - (&define name lambda-list def-body)) - -(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list. - -(def-edebug-spec lambda-list - (([&rest arg] - [&optional ["&optional" arg &rest arg]] - &optional ["&rest" arg] - ))) - -(def-edebug-spec interactive - (&optional &or stringp def-form)) - -;; A function-form is for an argument that may be a function or a form. -;; This specially recognizes anonymous functions quoted with quote. -(def-edebug-spec function-form - ;; form at the end could also handle "function", - ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) form)) - -;; function expects a symbol or a lambda or macro expression -;; A macro is allowed by Emacs. -(def-edebug-spec function (&or symbolp lambda-expr)) - -;; lambda is a macro in emacs 19. -(def-edebug-spec lambda (&define lambda-list - [&optional stringp] - [&optional ("interactive" interactive)] - def-body)) - -;; A macro expression is a lambda expression with "macro" prepended. -(def-edebug-spec macro (&define "lambda" lambda-list def-body)) - -;; (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)) - -(def-edebug-spec let - ((&rest &or (symbolp &optional form) symbolp) - body)) - -(def-edebug-spec let* let) - -(def-edebug-spec setq (&rest symbolp form)) -(def-edebug-spec setq-default setq) - -(def-edebug-spec cond (&rest (&rest form))) - -(def-edebug-spec condition-case - (symbolp - form - &rest (symbolp body))) - - -(def-edebug-spec \` (backquote-form)) - -;; Supports quotes inside backquotes, -;; but only at the top level inside unquotes. -(def-edebug-spec backquote-form - (&or - ([&or "," ",@"] &or ("quote" backquote-form) form) - (backquote-form &rest backquote-form) - ;; If you use dotted forms in backquotes, replace the previous line - ;; with the following. This takes quite a bit more stack space, however. - ;; (backquote-form . [&or nil backquote-form]) - (vector &rest backquote-form) - sexp)) - -;; Special version of backquote that instruments backquoted forms -;; destined to be evaluated, usually as the result of a -;; macroexpansion. Backquoted code can only have unquotes (, and ,@) -;; in places where list forms are allowed, and predicates. If the -;; backquote is used in a macro, unquoted code that come from -;; arguments must be instrumented, if at all, with def-form not def-body. - -;; We could assume that all forms (not nested in other forms) -;; in arguments of macros should be def-forms, whether or not the macros -;; are defined with edebug-` but this would be expensive. - -;; ,@ might have some problems. - -(defalias 'edebug-\` '\`) ;; same macro as regular backquote. -(def-edebug-spec edebug-\` (def-form)) - -;; Assume immediate quote in unquotes mean backquote at next higher level. -(def-edebug-spec , (&or ("quote" edebug-`) def-form)) -(def-edebug-spec ,@ (&define ;; so (,@ form) is never wrapped. - &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 save-match-data t) -(def-edebug-spec with-output-to-string t) -(def-edebug-spec with-current-buffer t) -(def-edebug-spec combine-after-change-calls t) -(def-edebug-spec with-temp-file t) -(def-edebug-spec with-temp-buffer t) - -;; 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)) - -;;; 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. - -(defvar edebug-stack-depth -1) -;; Index of last edebug-stack item. - -(defvar edebug-offset-indices nil) -;; Stack of offset indices of visited edebug sexps. -;; Should be nil at the top level. -;; Each function adds one cons. Top is modified with setcar. - - -(defvar edebug-entered nil - ;; Non-nil if edebug has already been entered at this recursive edit level. - ;; This should stay nil at the top level. - ) - -;; Should these be options? -(defconst edebug-debugger 'edebug - ;; Name of function to use for debugging when error or quit occurs. - ;; Set this to 'debug if you want to debug edebug. - ) - - -;; 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) - -(defvar edebug-execution-mode 'step) ; Current edebug mode set by user. -(defvar edebug-next-execution-mode nil) ; Use once instead of initial mode. - -(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-pre-command-hook) -(defvar edebug-outside-post-command-hook) - -(defvar cl-lexical-debug) ;; Defined in cl.el - -;;; Handling signals - -(defun edebug-signal (edebug-signal-name edebug-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. -A handler for any of those names will get to handle this signal. -The symbol `error' should always be one of them. - -DATA should be a list. Its elements are printed as part of the error message. -If the signal is handled, DATA is made available to the handler. -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." - (if (and (listp debug-on-error) (memq edebug-signal-name debug-on-error)) - (edebug 'error (cons edebug-signal-name edebug-signal-data))) - ;; If we reach here without another non-local exit, then send signal again. - ;; i.e. the signal is not continuable, yet. - (signal edebug-signal-name edebug-signal-data)) - -;;; Entering Edebug - -(defun edebug-enter (edebug-function edebug-args edebug-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. - ;; Return the result of BODY. - - ;; 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) - - ;; Save the outside value of executing macro. (here??) - (edebug-outside-executing-macro executing-kbd-macro) - (edebug-outside-pre-command-hook pre-command-hook) - (edebug-outside-post-command-hook 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)) - - (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 - pre-command-hook edebug-outside-pre-command-hook - post-command-hook edebug-outside-post-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)) - ))) - - -(defun edebug-enter-trace (edebug-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)) - (edebug-print-trace-after - (format "%s result: %s" edebug-function edebug-result))))) - -(def-edebug-spec edebug-tracing (form body)) - -(defmacro edebug-tracing (msg &rest body) - "Print MSG in *edebug-trace* before and after evaluating BODY. -The result of BODY is also printed." - (` (let ((edebug-stack-depth (1+ edebug-stack-depth)) - edebug-result) - (edebug-print-trace-before (, msg)) - (prog1 (setq edebug-result (progn (,@ body))) - (edebug-print-trace-after - (format "%s result: %s" (, msg) edebug-result)))))) - -(defun edebug-print-trace-before (msg) - "Function called to print trace info before expression evaluation. -MSG is printed after `::::{ '." - (edebug-trace-display - edebug-trace-buffer "%s{ %s" (make-string edebug-stack-depth ?\:) msg)) - -(defun edebug-print-trace-after (msg) - "Function called to print trace info after expression evaluation. -MSG is printed after `::::} '." - (edebug-trace-display - edebug-trace-buffer "%s} %s" (make-string edebug-stack-depth ?\:) msg)) - - - -(defun edebug-slow-before (edebug-before-index) - ;; 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) - - ;; Increment frequency count - (aset edebug-freq-count edebug-before-index - (1+ (aref edebug-freq-count edebug-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) - -(defun edebug-fast-before (edebug-before-index) - ;; Do nothing. - ) - -(defun edebug-slow-after (edebug-before-index edebug-after-index edebug-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) - - ;; 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)) - - (if (and (eq edebug-execution-mode 'Go-nonstop) - (not (edebug-input-pending-p))) - ;; Just return result. - edebug-value - (edebug-debugger edebug-after-index 'after edebug-value) - )) - -(defun edebug-fast-after (edebug-before-index edebug-after-index edebug-value) - ;; Do nothing but return the value. - edebug-value) - -(defun edebug-run-slow () - (defalias 'edebug-before 'edebug-slow-before) - (defalias 'edebug-after 'edebug-slow-after)) - -;; This is not used, yet. -(defun edebug-run-fast () - (defalias 'edebug-before 'edebug-fast-before) - (defalias 'edebug-after 'edebug-fast-after)) - -(edebug-run-slow) - - -(defun edebug-update-coverage () - (let ((old-result (aref edebug-coverage edebug-after-index))) - (cond - ((eq 'ok-coverage old-result)) - ((eq 'unknown old-result) - (aset edebug-coverage edebug-after-index edebug-value)) - ;; Test if a different result. - ((not (eq edebug-value old-result)) - (aset edebug-coverage edebug-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. -(defvar edebug-global-break) ; whether a global break occurred. -(defvar edebug-break-condition) ; whether the breakpoint is conditional. - -(defvar edebug-break-result nil) -(defvar edebug-global-break-result nil) - - -(defun edebug-debugger (edebug-offset-index edebug-arg-mode edebug-value) - ;; Check breakpoints and pending input. - ;; If edebug display should be updated, call edebug-display. - ;; Return edebug-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-condition (car (cdr edebug-break-data))) - (edebug-global-break - (if edebug-global-break-condition - (condition-case nil - (setq edebug-global-break-result - (eval edebug-global-break-condition)) - (error nil)))) - (edebug-break)) - -;;; (edebug-trace "exp: %s" edebug-value) - ;; Test whether we should break. - (setq edebug-break - (or edebug-global-break - (and edebug-break-data - (or (not edebug-break-condition) - (setq edebug-break-result - (eval edebug-break-condition)))))) - (if (and edebug-break - (nth 2 edebug-break-data)) ; is it temporary? - ;; Delete the breakpoint. - (setcdr edebug-data - (cons (delq edebug-break-data edebug-breakpoints) - (cdr (cdr edebug-data))))) - - ;; Display if mode is not go, continue, or Continue-fast - ;; 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 - - edebug-value - )) - - -;; window-start now stored with each function. -;;(defvar edebug-window-start nil) -;; Remember where each buffers' window starts between edebug calls. -;; This is to avoid spurious recentering. -;; Does this still need to be buffer-local?? -;;(setq-default edebug-window-start nil) -;;(make-variable-buffer-local 'edebug-window-start) - - -;; Dynamically declared unbound vars -(defvar edebug-point) ; the point in edebug buffer -(defvar edebug-outside-buffer) ; the current-buffer outside of edebug -(defvar edebug-outside-point) ; the point outside of edebug -(defvar edebug-outside-mark) ; the mark outside of edebug -(defvar edebug-window-data) ; window and window-start for current function -(defvar edebug-outside-windows) ; outside window configuration -(defvar edebug-eval-buffer) ; for the evaluation list. -(defvar edebug-outside-o-a-p) ; outside overlay-arrow-position -(defvar edebug-outside-o-a-s) ; outside overlay-arrow-string -(defvar edebug-outside-c-i-e-a) ; outside cursor-in-echo-area - -(defvar edebug-eval-list nil) ;; List of expressions to evaluate. - -(defvar edebug-previous-result nil) ;; Last result returned. - -;; Emacs 19 adds an arg to mark and mark-marker. -(defalias 'edebug-mark 'mark) -(defalias 'edebug-mark-marker 'mark-marker) - - -(defun edebug-display () - ;; 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 - edebug-stop ; should we enter recursive-edit - (edebug-point (+ edebug-def-mark - (aref (nth 2 edebug-data) edebug-offset-index))) - edebug-buffer-outside-point ; current point in edebug-buffer - ;; window displaying edebug-buffer - (edebug-window-data (nth 3 edebug-data)) - (edebug-outside-window (selected-window)) - (edebug-outside-buffer (current-buffer)) - (edebug-outside-point (point)) - (edebug-outside-mark (edebug-mark)) - 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-trace-window - edebug-trace-window-start - - (edebug-outside-o-a-p overlay-arrow-position) - (edebug-outside-o-a-s overlay-arrow-string) - (edebug-outside-c-i-e-a cursor-in-echo-area)) - (unwind-protect - (let ((overlay-arrow-position overlay-arrow-position) - (overlay-arrow-string overlay-arrow-string) - (cursor-in-echo-area nil) - ;; any others?? - ) - (if (not (buffer-name edebug-buffer)) - (let ((debug-on-error nil)) - (error "Buffer defining %s not found" edebug-function))) - - (if (eq 'after edebug-arg-mode) - ;; Compute result string now before windows are modified. - (edebug-compute-previous-result edebug-value)) - - (if edebug-save-windows - ;; Save windows now before we modify them. - (setq edebug-outside-windows - (edebug-current-windows edebug-save-windows))) - - (if edebug-save-displayed-buffer-points - (setq edebug-buffer-points (edebug-get-displayed-buffer-points))) - - ;; First move the edebug buffer point to edebug-point - ;; so that window start doesn't get changed when we display it. - ;; I don't know if this is going to help. - ;;(set-buffer edebug-buffer) - ;;(goto-char edebug-point) - - ;; If edebug-buffer is not currently displayed, - ;; first find a window for it. - (edebug-pop-to-buffer edebug-buffer (car edebug-window-data)) - (setcar edebug-window-data (selected-window)) - - ;; 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) - ;; The evaluation list better not have deleted edebug-window-data. - (select-window (car edebug-window-data)) - (set-buffer edebug-buffer) - - (setq edebug-buffer-outside-point (point)) - (goto-char edebug-point) - - (if (eq 'before edebug-arg-mode) - ;; Check whether positions are up-to-date. - ;; This assumes point is never before symbol. - (if (not (memq (following-char) '(?\( ?\# ?\` ))) - (let ((debug-on-error nil)) - (error "Source has changed - reevaluate definition of %s" - edebug-function) - ))) - - (setcdr edebug-window-data - (edebug-adjust-window (cdr edebug-window-data))) - - ;; Test if there is input, not including keyboard macros. - (if (edebug-input-pending-p) - (progn - (setq edebug-execution-mode 'step - edebug-stop t) - (edebug-stop) - ;; (discard-input) ; is this unfriendly?? - )) - ;; Now display arrow based on mode. - (edebug-overlay-arrow) - - (cond - ((eq 'error edebug-arg-mode) - ;; Display error message - (setq edebug-execution-mode 'step) - (edebug-overlay-arrow) - (beep) - (if (eq 'quit (car edebug-value)) - (message "Quit") - (edebug-report-error edebug-value))) - (edebug-break - (cond - (edebug-global-break - (message "Global Break: %s => %s" - edebug-global-break-condition - edebug-global-break-result)) - (edebug-break-condition - (message "Break: %s => %s" - edebug-break-condition - edebug-break-result)) - ((not (eq edebug-execution-mode 'Continue-fast)) - (message "Break")) - (t))) - - (t (message ""))) - - (if (eq 'after edebug-arg-mode) - (progn - ;; Display result of previous evaluation. - (if (and edebug-break - (not (eq edebug-execution-mode 'Continue-fast))) - (sit-for 1)) ; Show break message. - (edebug-previous-result))) - - (cond - (edebug-break - (cond - ((eq edebug-execution-mode 'continue) (edebug-sit-for 1)) - ((eq edebug-execution-mode 'Continue-fast) (edebug-sit-for 0)) - (t (setq edebug-stop t)))) - ;; not edebug-break - ((eq edebug-execution-mode 'trace) - (edebug-sit-for 1)) ; Force update and pause. - ((eq edebug-execution-mode 'Trace-fast) - (edebug-sit-for 0)) ; Force update and continue. - ) - - (unwind-protect - (if (or edebug-stop - (memq edebug-execution-mode '(step next)) - (eq edebug-arg-mode 'error)) - (progn - ;; (setq edebug-execution-mode 'step) - ;; (edebug-overlay-arrow) ; This doesn't always show up. - (edebug-recursive-edit))) ; <---------- 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)))) - ;; Remember window-start for edebug-buffer, if still displayed. - (if window - (progn - (setcar edebug-window-data window) - (setcdr edebug-window-data (window-start window))))) - - ;; Save trace window point before restoring outside windows. - ;; Could generalize this for other buffers. - (setq edebug-trace-window (get-buffer-window edebug-trace-buffer)) - (if edebug-trace-window - (setq edebug-trace-window-start - (and edebug-trace-window - (window-start edebug-trace-window)))) - - ;; Restore windows before continuing. - (if edebug-save-windows - (progn - (edebug-set-windows edebug-outside-windows) - - ;; Restore displayed buffer points. - ;; Needed even if restoring windows because - ;; window-points are not restored. (should they be??) - (if edebug-save-displayed-buffer-points - (edebug-set-buffer-points edebug-buffer-points)) - - ;; Unrestore trace window's window-point. - (if edebug-trace-window - (set-window-start edebug-trace-window - edebug-trace-window-start)) - - ;; Unrestore edebug-buffer's window-start, if displayed. - (let ((window (car edebug-window-data))) - (if (and window (edebug-window-live-p window) - (eq (window-buffer) edebug-buffer)) - (progn - (set-window-start window (cdr edebug-window-data) - 'no-force) - ;; Unrestore edebug-buffer's window-point. - ;; Needed in addition to setting the buffer point - ;; - otherwise quitting doesn't leave point as is. - ;; But this causes point to not be restored at times. - ;; Also, it may not be a visible window. - ;; (set-window-point window edebug-point) - ))) - - ;; Unrestore edebug-buffer's point. Rerestored below. - ;; (goto-char edebug-point) ;; in edebug-buffer - ) - ;; Since we may be in a save-excursion, in case of quit, - ;; reselect the outside window only. - ;; Only needed if we are not recovering windows?? - (if (edebug-window-live-p edebug-outside-window) - (select-window edebug-outside-window)) - ) ; if edebug-save-windows - - ;; Restore current buffer always, in case application needs it. - (set-buffer edebug-outside-buffer) - ;; Restore point, and mark. - ;; Needed even if restoring windows because - ;; that doesn't restore point and mark in the current buffer. - ;; But don't restore point if edebug-buffer is current buffer. - (if (not (eq edebug-buffer edebug-outside-buffer)) - (goto-char edebug-outside-point)) - (if (marker-buffer (edebug-mark-marker)) - ;; Does zmacs-regions need to be nil while doing set-marker? - (set-marker (edebug-mark-marker) edebug-outside-mark)) - ) ; unwind-protect - ;; None of the following is done if quit or signal occurs. - - ;; Restore edebug-buffer's outside point. - ;; (edebug-trace "restore edebug-buffer point: %s" - ;; edebug-buffer-outside-point) - (let ((current-buffer (current-buffer))) - (set-buffer edebug-buffer) - (goto-char edebug-buffer-outside-point) - (set-buffer current-buffer)) - ;; ... nothing more. - ) - ;; Reset global variables to outside values in case they were changed. - (setq - 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) - ))) - - -(defvar edebug-number-of-recursions 0) -;; Number of recursive edits started by edebug. -;; Should be 0 at the top level. - -(defvar edebug-recursion-depth 0) -;; Value of recursion-depth when edebug was called. - -;; Dynamically declared unbound vars -(defvar edebug-outside-match-data) ; match data outside of edebug -(defvar edebug-backtrace-buffer) ; each recursive edit gets its own -(defvar edebug-inside-windows) -(defvar edebug-interactive-p) - -(defvar edebug-outside-map) -(defvar edebug-outside-standard-output) -(defvar edebug-outside-standard-input) -(defvar edebug-outside-last-command-char) -(defvar edebug-outside-last-command) -(defvar edebug-outside-this-command) -(defvar edebug-outside-last-input-char) - -;; Note: here we have defvars for variables that are -;; built-in in certain versions. -;; Each defvar makes a difference -;; in versions where the variable is *not* built-in. - -;; Emacs 18 -(defvar edebug-outside-unread-command-char) - -;; Lucid Emacs -(defvar edebug-outside-unread-command-event) ;; like unread-command-events -(defvar unread-command-event nil) - -;; 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 - (setq edebug-unread-command-char-warning - (get 'unread-command-char 'byte-obsolete-variable)) - (put 'unread-command-char 'byte-obsolete-variable nil) - (setq edebug-unread-command-event-warning - (get 'unread-command-event 'byte-obsolete-variable)) - (put 'unread-command-event 'byte-obsolete-variable nil)) - -(defun edebug-recursive-edit () - ;; 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 - (edebug-outside-match-data - (save-excursion ; might be unnecessary now?? - (set-buffer edebug-outside-buffer) ; in case match buffer different - (match-data))) - - ;;(edebug-number-of-recursions (1+ edebug-number-of-recursions)) - (edebug-recursion-depth (recursion-depth)) - edebug-entered ; bind locally to nil - (edebug-interactive-p nil) ; again non-interactive - edebug-backtrace-buffer ; each recursive edit gets its own - ;; The window configuration may be saved and restored - ;; during a recursive-edit - edebug-inside-windows - - (edebug-outside-map (current-local-map)) - - (edebug-outside-standard-output standard-output) - (edebug-outside-standard-input standard-input) - (edebug-outside-defining-kbd-macro defining-kbd-macro) - - (edebug-outside-last-command-char last-command-char) - (edebug-outside-last-command last-command) - (edebug-outside-this-command this-command) - (edebug-outside-last-input-char last-input-char) - - (edebug-outside-unread-command-char unread-command-char) - - (edebug-outside-last-input-event last-input-event) - (edebug-outside-last-command-event last-command-event) - (edebug-outside-unread-command-event unread-command-event) - (edebug-outside-unread-command-events unread-command-events) - (edebug-outside-last-event-frame last-event-frame) - (edebug-outside-last-nonmenu-event last-nonmenu-event) - (edebug-outside-track-mouse track-mouse) - ) - - (unwind-protect - (let ( - ;; Declare global values local but using the same global value. - ;; We could set these to the values for previous edebug call. - (last-command-char last-command-char) - (last-command last-command) - (this-command this-command) - (last-input-char last-input-char) - - ;; Assume no edebug command sets unread-command-char. - (unread-command-char -1) - - ;; More for Emacs 19 - (last-input-event nil) - (last-command-event nil) - (unread-command-event nil);; lemacs - (unread-command-events nil) - (last-event-frame nil) - (last-nonmenu-event nil) - (track-mouse nil) - - ;; Bind again to outside values. - (debug-on-error edebug-outside-debug-on-error) - (debug-on-quit edebug-outside-debug-on-quit) - - ;; Don't keep defining a kbd macro. - (defining-kbd-macro - (if edebug-continue-kbd-macro defining-kbd-macro)) - - ;; others?? - ) - - (if (fboundp 'zmacs-deactivate-region);; for lemacs - (zmacs-deactivate-region)) - (if (and (eq edebug-execution-mode 'go) - (not (memq edebug-arg-mode '(after error)))) - (message "Break")) - - (setq buffer-read-only t) - (setq signal-hook-function nil) - - (edebug-mode) - (unwind-protect - (recursive-edit) ; <<<<<<<<<< Recursive edit - - ;; Do the following, even if quit occurs. - (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)) - - (store-match-data edebug-outside-match-data) - - ;; Recursive edit may have changed buffers, - ;; so set it back before exiting let. - (if (buffer-name edebug-buffer) ; if it still exists - (progn - (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) - ) - ;; gotta have a buffer to let its buffer local variables be set - (get-buffer-create " bogus edebug buffer")) - ));; inner let - - ;; Reset global vars to outside values, in case they have been changed. - (setq - last-command-char edebug-outside-last-command-char - 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-event edebug-outside-unread-command-event - unread-command-events edebug-outside-unread-command-events - last-input-char edebug-outside-last-input-char - last-input-event edebug-outside-last-input-event - last-event-frame edebug-outside-last-event-frame - last-nonmenu-event edebug-outside-last-nonmenu-event - track-mouse edebug-outside-track-mouse - - standard-output edebug-outside-standard-output - standard-input edebug-outside-standard-input - defining-kbd-macro edebug-outside-defining-kbd-macro - )) - )) - - -;;; 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) - (if (not (pos-visible-in-window-p)) - (progn - ;; First try old-start - (if old-start - (set-window-start (selected-window) old-start)) - (if (not (pos-visible-in-window-p)) - (progn -;; (message "resetting window start") (sit-for 2) - (set-window-start - (selected-window) - (save-excursion - (forward-line - (if (< (point) (window-start)) -1 ; one line before if in back - (- (/ (window-height) 2)) ; center the line moving forward - )) - (beginning-of-line) - (point))))))) - (window-start)) - - - -(defconst edebug-arrow-alist - '((Continue-fast . "=") - (Trace-fast . "-") - (continue . ">") - (trace . "->") - (step . "=>") - (next . "=>") - (go . "<>") - (Go-nonstop . "..") ; not used - ) - "Association list of arrows for each edebug mode.") - -(defun edebug-overlay-arrow () - ;; Set up the overlay arrow at beginning-of-line in current buffer. - ;; The arrow string is derived from edebug-arrow-alist and - ;; edebug-execution-mode. - (let ((pos (save-excursion (beginning-of-line) (point)))) - (setq overlay-arrow-string - (cdr (assq edebug-execution-mode edebug-arrow-alist))) - (setq overlay-arrow-position (make-marker)) - (set-marker overlay-arrow-position pos (current-buffer)))) - - -(defun edebug-toggle-save-all-windows () - "Toggle the saving and restoring of all windows. -Also, each time you toggle it on, the inside and outside window -configurations become the same as the current configuration." - (interactive) - (setq edebug-save-windows (not edebug-save-windows)) - (if edebug-save-windows - (setq edebug-inside-windows - (setq edebug-outside-windows - (edebug-current-windows - edebug-save-windows)))) - (message "Window saving is %s for all windows." - (if edebug-save-windows "on" "off"))) - -(defmacro edebug-changing-windows (&rest body) - (` (let ((window (selected-window))) - (setq edebug-inside-windows (edebug-current-windows t)) - (edebug-set-windows edebug-outside-windows) - (,@ body) ;; Code to change edebug-save-windows - (setq edebug-outside-windows (edebug-current-windows - edebug-save-windows)) - ;; Problem: what about outside windows that are deleted inside? - (edebug-set-windows edebug-inside-windows)))) - -(defun edebug-toggle-save-selected-window () - "Toggle the saving and restoring of the selected window. -Also, each time you toggle it on, the inside and outside window -configurations become the same as the current configuration." - (interactive) - (cond - ((eq t edebug-save-windows) - ;; Save all outside windows except the selected one. - ;; Remove (selected-window) from outside-windows. - (edebug-changing-windows - (setq edebug-save-windows (delq window (edebug-window-list))))) - - ((memq (selected-window) edebug-save-windows) - (setq edebug-outside-windows - (delq (assq (selected-window) edebug-outside-windows) - edebug-outside-windows)) - (setq edebug-save-windows - (delq (selected-window) edebug-save-windows))) - (t ; Save a new window. - (edebug-changing-windows - (setq edebug-save-windows (cons window edebug-save-windows))))) - - (message "Window saving is %s for %s." - (if (memq (selected-window) edebug-save-windows) - "on" "off") - (selected-window))) - -(defun edebug-toggle-save-windows (arg) - "Toggle the saving and restoring of windows. -With prefix, toggle for just the selected window. -Otherwise, toggle for all windows." - (interactive "P") - (if arg - (edebug-toggle-save-selected-window) - (edebug-toggle-save-all-windows))) - - -(defun edebug-where () - "Show the debug windows and where we stopped in the program." - (interactive) - (if (not edebug-active) - (error "Edebug is not active")) - ;; Restore the window configuration to what it last was inside. - ;; But it is not always set. - experiment - ;;(if edebug-inside-windows - ;; (edebug-set-windows edebug-inside-windows)) - (edebug-pop-to-buffer edebug-buffer) - (goto-char edebug-point)) - -(defun edebug-view-outside () - "Change to the outside window configuration." - (interactive) - (if (not edebug-active) - (error "Edebug is not active")) - (setq edebug-inside-windows - (edebug-current-windows edebug-save-windows)) - (edebug-set-windows edebug-outside-windows) - (goto-char edebug-outside-point) - (message "Window configuration outside of Edebug. Return with %s" - (substitute-command-keys "\\<global-map>\\[edebug-where]"))) - - -(defun edebug-bounce-point (arg) - "Bounce the point in the outside current buffer. -If prefix arg is supplied, sit for that many seconds before returning. -The default is one second." - (interactive "p") - (if (not edebug-active) - (error "Edebug is not active")) - (save-excursion - ;; If the buffer's currently displayed, avoid set-window-configuration. - (save-window-excursion - (edebug-pop-to-buffer edebug-outside-buffer) - (goto-char edebug-outside-point) - (message "Current buffer: %s Point: %s Mark: %s" - (current-buffer) (point) - (if (marker-buffer (edebug-mark-marker)) - (marker-position (edebug-mark-marker)) "<not set>")) - (edebug-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. - -'(defvar edebug-display-buffer-list nil - "List of buffers that edebug will display when it is active.") - -'(defun edebug-display-buffer (buffer) - "Toggle display of a buffer inside of edebug." - (interactive "bBuffer: ") - (let ((already-displaying (memq buffer edebug-display-buffer-list))) - (setq edebug-display-buffer-list - (if already-displaying - (delq buffer edebug-display-buffer-list) - (cons buffer edebug-display-buffer-list))) - (message "Displaying %s %s" buffer - (if already-displaying "off" "on")))) - -;;; Breakpoint related functions - -(defun edebug-find-stop-point () - ;; Return (function . index) of the nearest edebug stop point. - (let* ((edebug-def-name (edebug-form-data-symbol)) - (edebug-data - (let ((data (get edebug-def-name 'edebug))) - (if (or (null data) (markerp data)) - (error "%s is not instrumented for Edebug" edebug-def-name)) - data)) ; we could do it automatically, if data is a marker. - ;; pull out parts of edebug-data. - (edebug-def-mark (car edebug-data)) - ;; (edebug-breakpoints (car (cdr edebug-data))) - - (offset-vector (nth 2 edebug-data)) - (offset (- (save-excursion - (if (looking-at "[ \t]") - ;; skip backwards until non-whitespace, or bol - (skip-chars-backward " \t")) - (point)) - edebug-def-mark)) - len i) - ;; the offsets are in order so we can do a linear search - (setq len (length offset-vector)) - (setq i 0) - (while (and (< i len) (> offset (aref offset-vector i))) - (setq i (1+ i))) - (if (and (< i len) - (<= offset (aref offset-vector i))) - ;; return the relevant info - (cons edebug-def-name i) - (message "Point is not on an expression in %s." - edebug-def-name) - ))) - - -(defun edebug-next-breakpoint () - "Move point to the next breakpoint, or first if none past point." - (interactive) - (let ((edebug-stop-point (edebug-find-stop-point))) - (if edebug-stop-point - (let* ((edebug-def-name (car edebug-stop-point)) - (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) - - ;; pull out parts of edebug-data - (edebug-def-mark (car edebug-data)) - (edebug-breakpoints (car (cdr edebug-data))) - (offset-vector (nth 2 edebug-data)) - breakpoint) - (if (not edebug-breakpoints) - (message "No breakpoints in this function.") - (let ((breaks edebug-breakpoints)) - (while (and breaks - (<= (car (car breaks)) index)) - (setq breaks (cdr breaks))) - (setq breakpoint - (if breaks - (car breaks) - ;; goto the first breakpoint - (car edebug-breakpoints))) - (goto-char (+ edebug-def-mark - (aref offset-vector (car breakpoint)))) - - (message "%s" - (concat (if (nth 2 breakpoint) - "Temporary " "") - (if (car (cdr breakpoint)) - (format "Condition: %s" - (edebug-safe-prin1-to-string - (car (cdr breakpoint)))) - ""))) - )))))) - - -(defun edebug-modify-breakpoint (flag &optional condition temporary) - "Modify the breakpoint for the form at point or after it according -to FLAG: set if t, clear if nil. Then move to that point. -If CONDITION or TEMPORARY are non-nil, add those attributes to -the breakpoint. " - (let ((edebug-stop-point (edebug-find-stop-point))) - (if edebug-stop-point - (let* ((edebug-def-name (car edebug-stop-point)) - (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) - - ;; pull out parts of edebug-data - (edebug-def-mark (car edebug-data)) - (edebug-breakpoints (car (cdr edebug-data))) - (offset-vector (nth 2 edebug-data)) - present) - ;; delete it either way - (setq present (assq index edebug-breakpoints)) - (setq edebug-breakpoints (delq present edebug-breakpoints)) - (if flag - (progn - ;; add it to the list and resort - (setq edebug-breakpoints - (edebug-sort-alist - (cons - (list index condition temporary) - edebug-breakpoints) '<)) - (if condition - (message "Breakpoint set in %s with condition: %s" - edebug-def-name condition) - (message "Breakpoint set in %s" edebug-def-name))) - (if present - (message "Breakpoint unset in %s" edebug-def-name) - (message "No breakpoint here"))) - - (setcar (cdr edebug-data) edebug-breakpoints) - (goto-char (+ edebug-def-mark (aref offset-vector index))) - )))) - -(defun edebug-set-breakpoint (arg) - "Set the breakpoint of nearest sexp. -With prefix argument, make it a temporary breakpoint." - (interactive "P") - (edebug-modify-breakpoint t nil arg)) - -(defun edebug-unset-breakpoint () - "Clear the breakpoint of nearest sexp." - (interactive) - (edebug-modify-breakpoint nil)) - - -;; For emacs 18, no read-expression-history -(defun edebug-set-conditional-breakpoint (arg condition) - "Set a conditional breakpoint at nearest sexp. -The condition is evaluated in the outside context. -With prefix argument, make it a temporary breakpoint." - ;; (interactive "P\nxCondition: ") - (interactive - (list - current-prefix-arg - ;; Edit previous condition as follows, but it is cumbersome: - (let ((edebug-stop-point (edebug-find-stop-point))) - (if edebug-stop-point - (let* ((edebug-def-name (car edebug-stop-point)) - (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) - (edebug-breakpoints (car (cdr edebug-data))) - (edebug-break-data (assq index edebug-breakpoints)) - (edebug-break-condition (car (cdr edebug-break-data)))) - (read-minibuffer - (format "Condition in %s: " edebug-def-name) - (if edebug-break-condition - (format "%s" edebug-break-condition) - (format "")))))))) - (edebug-modify-breakpoint t condition arg)) - - -(defun edebug-set-global-break-condition (expression) - (interactive (list (read-minibuffer - "Global Condition: " - (format "%s" edebug-global-break-condition)))) - (setq edebug-global-break-condition expression)) - - -;;; Mode switching functions - -(defun edebug-set-mode (mode shortmsg msg) - ;; Set the edebug mode to MODE. - ;; Display SHORTMSG, or MSG if not within edebug. - (if (eq (1+ edebug-recursion-depth) (recursion-depth)) - (progn - (setq edebug-execution-mode mode) - (message shortmsg) - ;; Continue execution - (exit-recursive-edit)) - ;; This is not terribly useful!! - (setq edebug-next-execution-mode mode) - (message msg))) - - -(defalias 'edebug-step-through-mode 'edebug-step-mode) - -(defun edebug-step-mode () - "Proceed to next stop point." - (interactive) - (edebug-set-mode 'step "" "Edebug will stop at next stop point.")) - -(defun edebug-next-mode () - "Proceed to next `after' stop point." - (interactive) - (edebug-set-mode 'next "" "Edebug will stop after next eval.")) - -(defun edebug-go-mode (arg) - "Go, evaluating until break. -With prefix ARG, set temporary break at current point and go." - (interactive "P") - (if arg - (edebug-set-breakpoint t)) - (edebug-set-mode 'go "Go..." "Edebug will go until break.")) - -(defun edebug-Go-nonstop-mode () - "Go, evaluating without debugging." - (interactive) - (edebug-set-mode 'Go-nonstop "Go-Nonstop..." - "Edebug will not stop at breaks.")) - - -(defun edebug-trace-mode () - "Begin trace mode." - (interactive) - (edebug-set-mode 'trace "Tracing..." "Edebug will trace with pause.")) - -(defun edebug-Trace-fast-mode () - "Trace with no wait at each step." - (interactive) - (edebug-set-mode 'Trace-fast - "Trace fast..." "Edebug will trace without pause.")) - -(defun edebug-continue-mode () - "Begin continue mode." - (interactive) - (edebug-set-mode 'continue "Continue..." - "Edebug will pause at breakpoints.")) - -(defun edebug-Continue-fast-mode () - "Trace with no wait at each step." - (interactive) - (edebug-set-mode 'Continue-fast "Continue fast..." - "Edebug will stop and go at breakpoints.")) - -;; ------------------------------------------------------------ -;; The following use the mode changing commands and breakpoints. - - -(defun edebug-goto-here () - "Proceed to this stop point." - (interactive) - (edebug-go-mode t)) - - -(defun edebug-stop () - "Stop execution and do not continue. -Useful for exiting from trace or continue loop." - (interactive) - (message "Stop")) - - -'(defun edebug-forward () - "Proceed to the exit of the next expression to be evaluated." - (interactive) - (edebug-set-mode - 'forward "Forward" - "Edebug will stop after exiting the next expression.")) - - -(defun edebug-forward-sexp (arg) - "Proceed from the current point to the end of the ARGth sexp ahead. -If there are not ARG sexps ahead, then do edebug-step-out." - (interactive "p") - (condition-case nil - (let ((parse-sexp-ignore-comments t)) - ;; Call forward-sexp repeatedly until done or failure. - (forward-sexp arg) - (edebug-go-mode t)) - (error - (edebug-step-out) - ))) - -(defun edebug-step-out () - "Proceed from the current point to the end of the containing sexp. -If there is no containing sexp that is not the top level defun, -go to the end of the last sexp, or if that is the same point, then step." - (interactive) - (condition-case nil - (let ((parse-sexp-ignore-comments t)) - (up-list 1) - (save-excursion - ;; Is there still a containing expression? - (up-list 1)) - (edebug-go-mode t)) - (error - ;; At top level - 1, so first check if there are more sexps at this level. - (let ((start-point (point))) -;; (up-list 1) - (down-list -1) - (if (= (point) start-point) - (edebug-step-mode) ; No more at this level, so step. - (edebug-go-mode t) - ))))) - -(defun edebug-instrument-function (func) - ;; Func should be a function symbol. - ;; Return the function symbol, or nil if not instrumented. - (let ((func-marker)) - (setq func-marker (get func 'edebug)) - (cond - ((markerp func-marker) - ;; It is uninstrumented, so instrument it. - (save-excursion - (set-buffer (marker-buffer func-marker)) - (goto-char func-marker) - (edebug-eval-top-level-form) - func)) - ((consp func-marker) - (message "%s is already instrumented." func) - func) - (t - ;; We could try harder, e.g. do a tags search. - (error "Don't know where %s is defined" func) - nil)))) - -(defun edebug-instrument-callee () - "Instrument the definition of the function or macro about to be called. -Do this when stopped before the form or it will be too late. -One side effect of using this command is that the next time the -function or macro is called, Edebug will be called there as well." - (interactive) - (if (not (looking-at "\(")) - (error "You must be before a list form") - (let ((func - (save-excursion - (down-list 1) - (if (looking-at "\(") - (edebug-form-data-name - (edebug-get-form-data-entry (point))) - (edebug-original-read (current-buffer)))))) - (edebug-instrument-function func)))) - - -(defun edebug-step-in () - "Step into the definition of the function or macro about to be called. -This first does `edebug-instrument-callee' to ensure that it is -instrumented. Then it does `edebug-on-entry' and switches to `go' mode." - (interactive) - (let ((func (edebug-instrument-callee))) - (if func - (progn - (edebug-on-entry func 'temp) - (edebug-go-mode nil))))) - -(defun edebug-on-entry (function &optional flag) - "Cause Edebug to stop when FUNCTION is called. -With prefix argument, make this temporary so it is automatically -cancelled the first time the function is entered." - (interactive "aEdebug on entry to: \nP") - ;; Could store this in the edebug data instead. - (put function 'edebug-on-entry (if flag 'temp t))) - -(defun cancel-edebug-on-entry (function) - (interactive "aEdebug on entry to: ") - (put function 'edebug-on-entry nil)) - - -(if (not (fboundp 'edebug-original-debug-on-entry)) - (fset 'edebug-original-debug-on-entry (symbol-function 'debug-on-entry))) -'(fset 'debug-on-entry 'edebug-debug-on-entry) ;; Should we do this? -;; Also need edebug-cancel-debug-on-entry - -'(defun edebug-debug-on-entry (function) - "Request FUNCTION to invoke debugger each time it is called. -If the user continues, FUNCTION's execution proceeds. -Works by modifying the definition of FUNCTION, -which must be written in Lisp, not predefined. -Use `cancel-debug-on-entry' to cancel the effect of this command. -Redefining FUNCTION also does that. - -This version is from Edebug. If the function is instrumented for -Edebug, it calls `edebug-on-entry'" - (interactive "aDebug on entry (to function): ") - (let ((func-data (get function 'edebug))) - (if (or (null func-data) (markerp func-data)) - (edebug-original-debug-on-entry function) - (edebug-on-entry function)))) - - -(defun edebug-top-level-nonstop () - "Set mode to Go-nonstop, and exit to top-level. -This is useful for exiting even if unwind-protect code may be executed." - (interactive) - (setq edebug-execution-mode 'Go-nonstop) - (top-level)) - - -;;(defun edebug-exit-out () -;; "Go until the current function exits." -;; (interactive) -;; (edebug-set-mode 'exiting "Exit...")) - - -;;; The following initial mode setting definitions are not used yet. - -'(defconst edebug-initial-mode-alist - '((edebug-Continue-fast . Continue-fast) - (edebug-Trace-fast . Trace-fast) - (edebug-continue . continue) - (edebug-trace . trace) - (edebug-go . go) - (edebug-step-through . step) - (edebug-Go-nonstop . Go-nonstop) - ) - "Association list between commands and the modes they set.") - - -'(defun edebug-set-initial-mode () - "Ask for the initial mode of the enclosing function. -The mode is requested via the key that would be used to set the mode in -edebug-mode." - (interactive) - (let* ((this-function (edebug-which-function)) - (keymap (if (eq edebug-mode-map (current-local-map)) - edebug-mode-map)) - (old-mode (or (get this-function 'edebug-initial-mode) - edebug-initial-mode)) - (key (read-key-sequence - (format - "Change initial edebug mode for %s from %s (%s) to (enter key): " - this-function - old-mode - (where-is-internal - (car (rassq old-mode edebug-initial-mode-alist)) - keymap 'firstonly - )))) - (mode (cdr (assq (key-binding key) edebug-initial-mode-alist))) - ) - (if (and mode - (or (get this-function 'edebug-initial-mode) - (not (eq mode edebug-initial-mode)))) - (progn - (put this-function 'edebug-initial-mode mode) - (message "Initial mode for %s is now: %s" - this-function mode)) - (error "Key must map to one of the mode changing commands") - ))) - -;;; 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." - (` (save-excursion ; of current-buffer - (if edebug-save-windows - (progn - ;; After excursion, we will - ;; restore to current window configuration. - (setq edebug-inside-windows - (edebug-current-windows edebug-save-windows)) - ;; Restore outside windows. - (edebug-set-windows edebug-outside-windows))) - - (set-buffer edebug-buffer) ; why? - ;; (use-local-map edebug-outside-map) - (store-match-data edebug-outside-match-data) - ;; Restore outside context. - (let (;; (edebug-inside-map (current-local-map)) ;; restore map?? - (last-command-char edebug-outside-last-command-char) - (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-event edebug-outside-unread-command-event) - (unread-command-events edebug-outside-unread-command-events) - (last-input-char edebug-outside-last-input-char) - (last-input-event edebug-outside-last-input-event) - (last-event-frame edebug-outside-last-event-frame) - (last-nonmenu-event edebug-outside-last-nonmenu-event) - (track-mouse edebug-outside-track-mouse) - (standard-output edebug-outside-standard-output) - (standard-input edebug-outside-standard-input) - - (executing-kbd-macro edebug-outside-executing-macro) - (defining-kbd-macro edebug-outside-defining-kbd-macro) - (pre-command-hook edebug-outside-pre-command-hook) - (post-command-hook edebug-outside-post-command-hook) - - ;; 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) - ) - (unwind-protect - (save-excursion ; of edebug-buffer - (set-buffer edebug-outside-buffer) - (goto-char edebug-outside-point) - (if (marker-buffer (edebug-mark-marker)) - (set-marker (edebug-mark-marker) edebug-outside-mark)) - (,@ body)) - - ;; Back to edebug-buffer. Restore rest of inside context. - ;; (use-local-map edebug-inside-map) - (if edebug-save-windows - ;; Restore inside windows. - (edebug-set-windows edebug-inside-windows)) - - ;; Save values that may have been changed. - (setq - edebug-outside-last-command-char last-command-char - 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-event unread-command-event - edebug-outside-unread-command-events unread-command-events - edebug-outside-last-input-char last-input-char - edebug-outside-last-input-event last-input-event - edebug-outside-last-event-frame last-event-frame - edebug-outside-last-nonmenu-event last-nonmenu-event - edebug-outside-track-mouse track-mouse - edebug-outside-standard-output standard-output - edebug-outside-standard-input standard-input - - edebug-outside-executing-macro executing-kbd-macro - edebug-outside-defining-kbd-macro defining-kbd-macro - edebug-outside-pre-command-hook pre-command-hook - edebug-outside-post-command-hook post-command-hook - - edebug-outside-o-a-p overlay-arrow-position - edebug-outside-o-a-s overlay-arrow-string - edebug-outside-c-i-e-a cursor-in-echo-area - ))) ; let - ))) - -(defvar cl-debug-env nil) ;; defined in cl; non-nil when lexical env used. - -(defun edebug-eval (edebug-expr) - ;; Are there cl lexical variables active? - (if cl-debug-env - (eval (cl-macroexpand-all edebug-expr cl-debug-env)) - (eval edebug-expr))) - -(defun edebug-safe-eval (edebug-expr) - ;; Evaluate EXPR safely. - ;; If there is an error, a string is returned describing the error. - (condition-case edebug-err - (edebug-eval edebug-expr) - (error (edebug-format "%s: %s" ;; could - (get (car edebug-err) 'error-message) - (car (cdr edebug-err)))))) - -;;; Printing - -;; Replace printing functions. - -;; obsolete names -(defalias 'edebug-install-custom-print-funcs 'edebug-install-custom-print) -(defalias 'edebug-reset-print-funcs 'edebug-uninstall-custom-print) -(defalias 'edebug-uninstall-custom-print-funcs 'edebug-uninstall-custom-print) - -(defun edebug-install-custom-print () - "Replace print functions used by Edebug with custom versions." - ;; Modifying the custom print functions, or changing print-length, - ;; print-level, print-circle, custom-print-list or custom-print-vector - ;; have immediate effect. - (interactive) - (require 'cust-print) - (defalias 'edebug-prin1 'custom-prin1) - (defalias 'edebug-print 'custom-print) - (defalias 'edebug-prin1-to-string 'custom-prin1-to-string) - (defalias 'edebug-format 'custom-format) - (defalias 'edebug-message 'custom-message) - "Installed") - -(eval-and-compile - (defun edebug-uninstall-custom-print () - "Replace edebug custom print functions with internal versions." - (interactive) - (defalias 'edebug-prin1 'prin1) - (defalias 'edebug-print 'print) - (defalias 'edebug-prin1-to-string 'prin1-to-string) - (defalias 'edebug-format 'format) - (defalias 'edebug-message 'message) - "Uninstalled") - - ;; Default print functions are the same as Emacs'. - (edebug-uninstall-custom-print)) - - -(defun edebug-report-error (edebug-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))) - (mapconcat (function (lambda (edebug-arg) - ;; continuing after an error may - ;; complain about edebug-arg. why?? - (prin1-to-string edebug-arg))) - (cdr edebug-value) ", "))) - -;; Define here in case they are not already defined. -(defvar print-level nil) -(defvar print-circle nil) -(defvar print-readably) ;; defined by lemacs -;; Alternatively, we could change the definition of -;; edebug-safe-prin1-to-string to only use these if defined. - -(defun edebug-safe-prin1-to-string (value) - (let ((print-escape-newlines t) - (print-length (or edebug-print-length print-length)) - (print-level (or edebug-print-level print-level)) - (print-circle (or edebug-print-circle print-circle)) - (print-readably nil)) ;; lemacs uses this. - (edebug-prin1-to-string value))) - -(defun edebug-compute-previous-result (edebug-previous-value) - (setq edebug-previous-result - (if (and (numberp edebug-previous-value) - (< edebug-previous-value 256) - (>= edebug-previous-value 0)) - (format "Result: %s = %s" edebug-previous-value - (single-key-description edebug-previous-value)) - (if edebug-unwrap-results - (setq edebug-previous-value - (edebug-unwrap* edebug-previous-value))) - (concat "Result: " - (edebug-safe-prin1-to-string edebug-previous-value))))) - -(defun edebug-previous-result () - "Print the previous result." - (interactive) - (message "%s" edebug-previous-result)) - -;;; Read, Eval and Print - -(defun edebug-eval-expression (edebug-expr) - "Evaluate an expression in the outside environment. -If interactive, prompt for the expression. -Print result in minibuffer." - (interactive "xEval: ") - (princ - (edebug-outside-excursion - (setq values (cons (edebug-eval edebug-expr) values)) - (edebug-safe-prin1-to-string (car values))))) - -(defun edebug-eval-last-sexp () - "Evaluate sexp before point in the outside environment; -print value in minibuffer." - (interactive) - (edebug-eval-expression (edebug-last-sexp))) - -(defun edebug-eval-print-last-sexp () - "Evaluate sexp before point in the outside environment; -print value into current buffer." - (interactive) - (let* ((edebug-form (edebug-last-sexp)) - (edebug-result-string - (edebug-outside-excursion - (edebug-safe-prin1-to-string (edebug-safe-eval edebug-form)))) - (standard-output (current-buffer))) - (princ "\n") - ;; princ the string to get rid of quotes. - (princ edebug-result-string) - (princ "\n") - )) - -;;; Edebug Minor Mode - -;; Global GUD bindings for all emacs-lisp-mode buffers. -(define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) -(define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) -(define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) -(define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where) - - -(defvar edebug-mode-map nil) -(if edebug-mode-map - nil - (progn - (setq edebug-mode-map (copy-keymap emacs-lisp-mode-map)) - ;; control - (define-key edebug-mode-map " " 'edebug-step-mode) - (define-key edebug-mode-map "n" 'edebug-next-mode) - (define-key edebug-mode-map "g" 'edebug-go-mode) - (define-key edebug-mode-map "G" 'edebug-Go-nonstop-mode) - (define-key edebug-mode-map "t" 'edebug-trace-mode) - (define-key edebug-mode-map "T" 'edebug-Trace-fast-mode) - (define-key edebug-mode-map "c" 'edebug-continue-mode) - (define-key edebug-mode-map "C" 'edebug-Continue-fast-mode) - - ;;(define-key edebug-mode-map "f" 'edebug-forward) not implemented - (define-key edebug-mode-map "f" 'edebug-forward-sexp) - (define-key edebug-mode-map "h" 'edebug-goto-here) - - (define-key edebug-mode-map "I" 'edebug-instrument-callee) - (define-key edebug-mode-map "i" 'edebug-step-in) - (define-key edebug-mode-map "o" 'edebug-step-out) - - ;; quitting and stopping - (define-key edebug-mode-map "q" 'top-level) - (define-key edebug-mode-map "Q" 'edebug-top-level-nonstop) - (define-key edebug-mode-map "a" 'abort-recursive-edit) - (define-key edebug-mode-map "S" 'edebug-stop) - - ;; breakpoints - (define-key edebug-mode-map "b" 'edebug-set-breakpoint) - (define-key edebug-mode-map "u" 'edebug-unset-breakpoint) - (define-key edebug-mode-map "B" 'edebug-next-breakpoint) - (define-key edebug-mode-map "x" 'edebug-set-conditional-breakpoint) - (define-key edebug-mode-map "X" 'edebug-set-global-break-condition) - - ;; evaluation - (define-key edebug-mode-map "r" 'edebug-previous-result) - (define-key edebug-mode-map "e" 'edebug-eval-expression) - (define-key edebug-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) - (define-key edebug-mode-map "E" 'edebug-visit-eval-list) - - ;; views - (define-key edebug-mode-map "w" 'edebug-where) - (define-key edebug-mode-map "v" 'edebug-view-outside) ;; maybe obsolete?? - (define-key edebug-mode-map "p" 'edebug-bounce-point) - (define-key edebug-mode-map "P" 'edebug-view-outside) ;; same as v - (define-key edebug-mode-map "W" 'edebug-toggle-save-windows) - - ;; misc - (define-key edebug-mode-map "?" 'edebug-help) - (define-key edebug-mode-map "d" 'edebug-backtrace) - - (define-key edebug-mode-map "-" 'negative-argument) - - ;; statistics - (define-key edebug-mode-map "=" 'edebug-temp-display-freq-count) - - ;; GUD bindings - (define-key edebug-mode-map "\C-c\C-s" 'edebug-step-mode) - (define-key edebug-mode-map "\C-c\C-n" 'edebug-next-mode) - (define-key edebug-mode-map "\C-c\C-c" 'edebug-go-mode) - - (define-key edebug-mode-map "\C-x " 'edebug-set-breakpoint) - (define-key edebug-mode-map "\C-c\C-d" 'edebug-unset-breakpoint) - (define-key edebug-mode-map "\C-c\C-t" - (function (lambda () (edebug-set-breakpoint t)))) - (define-key edebug-mode-map "\C-c\C-l" 'edebug-where) - )) - -;; Autoloading these global bindings doesn't make sense because -;; they cannot be used anyway unless Edebug is already loaded and active. - -(defvar global-edebug-prefix "\^XX" - "Prefix key for global edebug commands, available from any buffer.") - -(defvar global-edebug-map nil - "Global map of edebug commands, available from any buffer.") - -(if global-edebug-map - nil - (setq global-edebug-map (make-sparse-keymap)) - - (global-unset-key global-edebug-prefix) - (global-set-key global-edebug-prefix global-edebug-map) - - (define-key global-edebug-map " " 'edebug-step-mode) - (define-key global-edebug-map "g" 'edebug-go-mode) - (define-key global-edebug-map "G" 'edebug-Go-nonstop-mode) - (define-key global-edebug-map "t" 'edebug-trace-mode) - (define-key global-edebug-map "T" 'edebug-Trace-fast-mode) - (define-key global-edebug-map "c" 'edebug-continue-mode) - (define-key global-edebug-map "C" 'edebug-Continue-fast-mode) - - ;; breakpoints - (define-key global-edebug-map "b" 'edebug-set-breakpoint) - (define-key global-edebug-map "u" 'edebug-unset-breakpoint) - (define-key global-edebug-map "x" 'edebug-set-conditional-breakpoint) - (define-key global-edebug-map "X" 'edebug-set-global-break-condition) - - ;; views - (define-key global-edebug-map "w" 'edebug-where) - (define-key global-edebug-map "W" 'edebug-toggle-save-windows) - - ;; quitting - (define-key global-edebug-map "q" 'top-level) - (define-key global-edebug-map "Q" 'edebug-top-level-nonstop) - (define-key global-edebug-map "a" 'abort-recursive-edit) - - ;; statistics - (define-key global-edebug-map "=" 'edebug-display-freq-count) - ) - -(defun edebug-help () - (interactive) - (describe-function 'edebug-mode)) - -(defun edebug-mode () - "Mode for Emacs Lisp buffers while in Edebug. - -In addition to all Emacs Lisp commands (except those that modify the -buffer) there are local and global key bindings to several Edebug -specific commands. E.g. `edebug-step-mode' is bound to \\[edebug-step-mode] -in the Edebug buffer and \\<global-map>\\[edebug-step-mode] in any buffer. - -Also see bindings for the eval list buffer, *edebug*. - -The edebug buffer commands: -\\{edebug-mode-map} - -Global commands prefixed by `global-edebug-prefix': -\\{global-edebug-map} - -Options: -edebug-setup-hook -edebug-all-defs -edebug-all-forms -edebug-save-windows -edebug-save-displayed-buffer-points -edebug-initial-mode -edebug-trace -edebug-test-coverage -edebug-continue-kbd-macro -edebug-print-length -edebug-print-level -edebug-print-circle -edebug-on-error -edebug-on-quit -edebug-on-signal -edebug-unwrap-results -edebug-global-break-condition -" - (use-local-map edebug-mode-map)) - -;;; edebug eval list mode - -;; A list of expressions and their evaluations is displayed in *edebug*. - -(defun edebug-eval-result-list () - "Return a list of evaluations of edebug-eval-list" - ;; Assumes in outside environment. - ;; Don't do any edebug things now. - (let ((edebug-execution-mode 'Go-nonstop) - (edebug-trace nil)) - (mapcar 'edebug-safe-eval edebug-eval-list))) - -(defun edebug-eval-display-list (edebug-eval-result-list) - ;; Assumes edebug-eval-buffer exists. - (let ((edebug-eval-list-temp edebug-eval-list) - (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))) - (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)))) - -;; 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 EVAL-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) - ))) - -(defun edebug-eval-redisplay () - "Redisplay eval list in outside environment. -May only be called from within edebug-recursive-edit." - (edebug-create-eval-buffer) - (edebug-outside-excursion - (edebug-eval-display-list (edebug-eval-result-list)) - )) - -(defun edebug-visit-eval-list () - (interactive) - (edebug-eval-redisplay) - (edebug-pop-to-buffer edebug-eval-buffer)) - - -(defun edebug-update-eval-list () - "Replace the evaluation list with the sexps now in the eval buffer." - (interactive) - (let ((starting-point (point)) - new-list) - (goto-char (point-min)) - ;; get the first expression - (edebug-skip-whitespace) - (if (not (eobp)) - (progn - (forward-sexp 1) - (setq new-list (cons (edebug-last-sexp) new-list)))) - - (while (re-search-forward "^;" nil t) - (forward-line 1) - (skip-chars-forward " \t\n\r") - (if (and (/= ?\; (following-char)) - (not (eobp))) - (progn - (forward-sexp 1) - (setq new-list (cons (edebug-last-sexp) new-list))))) - - (setq edebug-eval-list (nreverse new-list)) - (edebug-eval-redisplay) - (goto-char starting-point))) - - -(defun edebug-delete-eval-item () - "Delete the item under point and redisplay." - ;; could add arg to do repeatedly - (interactive) - (if (re-search-backward "^;" nil 'nofail) - (forward-line 1)) - (delete-region - (point) (progn (re-search-forward "^;" nil 'nofail) - (beginning-of-line) - (point))) - (edebug-update-eval-list)) - - - -(defvar edebug-eval-mode-map nil - "Keymap for edebug-eval-mode. Superset of lisp-interaction-mode.") - -(if edebug-eval-mode-map - nil - (setq edebug-eval-mode-map (copy-keymap lisp-interaction-mode-map)) - - (define-key edebug-eval-mode-map "\C-c\C-w" 'edebug-where) - (define-key edebug-eval-mode-map "\C-c\C-d" 'edebug-delete-eval-item) - (define-key edebug-eval-mode-map "\C-c\C-u" 'edebug-update-eval-list) - (define-key edebug-eval-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) - (define-key edebug-eval-mode-map "\C-j" 'edebug-eval-print-last-sexp) - ) - - -(defun edebug-eval-mode () - "Mode for evaluation list buffer while in Edebug. - -In addition to all Interactive Emacs Lisp commands there are local and -global key bindings to several Edebug specific commands. E.g. -`edebug-step-mode' is bound to \\[edebug-step-mode] in the Edebug -buffer and \\<global-map>\\[edebug-step-mode] in any buffer. - -Eval list buffer commands: -\\{edebug-eval-mode-map} - -Global commands prefixed by global-edebug-prefix: -\\{global-edebug-map} -" - (lisp-interaction-mode) - (setq major-mode 'edebug-eval-mode) - (setq mode-name "Edebug-Eval") - (use-local-map edebug-eval-mode-map)) - -;;; Interface with standard debugger. - -;; (setq debugger 'edebug) ; to use the edebug debugger -;; (setq debugger 'debug) ; use the standard debugger - -;; Note that debug and its utilities must be byte-compiled to work, -;; 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) - "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) - (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)) - edebug-breakpoints - edebug-break-data - edebug-break-condition - edebug-global-break - (edebug-break (null edebug-arg-mode)) ;; if called explicitly - ) - (edebug-display) - (if (eq edebug-arg-mode 'error) - nil - edebug-value)) - - ;; Otherwise call debug normally. - ;; Still need to remove extraneous edebug calls from stack. - (apply 'debug edebug-arg-mode debugger-args) - )) - - -(defun edebug-backtrace () - "Display a non-working backtrace. Better than nothing..." - (interactive) - (if (or (not edebug-backtrace-buffer) - (null (buffer-name edebug-backtrace-buffer))) - (setq edebug-backtrace-buffer - (generate-new-buffer "*Backtrace*")) - ;; else, could just display edebug-backtrace-buffer - ) - (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer) - (setq edebug-backtrace-buffer standard-output) - (let ((print-escape-newlines t) - (print-length 50) - last-ok-point) - (backtrace) - - ;; Clean up the backtrace. - ;; Not quite right for current edebug scheme. - (set-buffer edebug-backtrace-buffer) - (setq truncate-lines t) - (goto-char (point-min)) - (setq last-ok-point (point)) - (if t (progn - - ;; Delete interspersed edebug internals. - (while (re-search-forward "^ \(?edebug" nil t) - (beginning-of-line) - (cond - ((looking-at "^ \(edebug-after") - ;; Previous lines may contain code, so just delete this line - (setq last-ok-point (point)) - (forward-line 1) - (delete-region last-ok-point (point))) - - ((looking-at "^ edebug") - (forward-line 1) - (delete-region last-ok-point (point)) - ))) - ))))) - - -;;; Trace display - -(defun edebug-trace-display (buf-name fmt &rest args) - "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)) - (let* ((oldbuf (current-buffer)) - (selected-window (selected-window)) - (buffer (get-buffer-create buf-name)) - buf-window) -;; (message "before pop-to-buffer") (sit-for 1) - (edebug-pop-to-buffer buffer) - (setq truncate-lines t) - (setq buf-window (selected-window)) - (goto-char (point-max)) - (insert (apply 'edebug-format fmt args) "\n") - ;; Make it visible. - (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) - (bury-buffer buffer) - (select-window selected-window) - (set-buffer oldbuf)) - buf-name) - - -(defun edebug-trace (fmt &rest args) - "Convenience call to edebug-trace-display using edebug-trace-buffer" - (apply 'edebug-trace-display edebug-trace-buffer fmt args)) - - -;;; Frequency count and coverage - -(defun edebug-display-freq-count () - "Display the frequency count data for each line of the current -definition. The frequency counts are inserted as comment lines after -each line, and you can undo all insertions with one `undo' command. - -The counts are inserted starting under the `(' before an expression -or the `)' after an expression, or on the last char of a symbol. -The counts are only displayed when they differ from previous counts on -the same line. - -If coverage is being tested, whenever all known results of an expression -are `eq', the char `=' will be appended after the count -for that expression. Note that this is always the case for an -expression only evaluated once. - -To clear the frequency count and coverage data for a definition, -reinstrument it." - (interactive) - (let* ((function (edebug-form-data-symbol)) - (counts (get function 'edebug-freq-count)) - (coverages (get function 'edebug-coverage)) - (data (get function 'edebug)) - (def-mark (car data)) ; mark at def start - (edebug-points (nth 2 data)) - (i (1- (length edebug-points))) - (last-index) - (first-index) - (start-of-line) - (start-of-count-line) - (last-count) - ) - (save-excursion - ;; Traverse in reverse order so offsets are correct. - (while (<= 0 i) - ;; Start at last expression in line. - (goto-char (+ def-mark (aref edebug-points i))) - (beginning-of-line) - (setq start-of-line (- (point) def-mark) - last-index i) - - ;; Find all indexes on same line. - (while (and (<= 0 (setq i (1- i))) - (<= start-of-line (aref edebug-points i)))) - ;; 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. - (insert ";#") - ;; i == first-index still - (while (<= (setq i (1+ i)) last-index) - (let ((count (aref counts i)) - (coverage (aref coverages i)) - (col (save-excursion - (goto-char (+ (aref edebug-points i) def-mark)) - (- (current-column) - (if (= ?\( (following-char)) 0 1))))) - (insert (make-string - (max 0 (- col (- (point) start-of-count-line))) ?\ ) - (if (and (< 0 count) - (not (memq coverage - '(unknown ok-coverage)))) - "=" "") - (if (= count last-count) "" (int-to-string count)) - " ") - (setq last-count count))) - (insert "\n") - (setq i first-index))))) - -(defun edebug-temp-display-freq-count () - "Temporarily display the frequency count data for the current definition. -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)) - (undo-boundary) - (edebug-display-freq-count) - (setq unread-command-char (read-char)) - (undo))) - - -;;; Menus - -(defun edebug-toggle (variable) - (set variable (not (eval variable))) - (message "%s: %s" variable (eval variable))) - -;; We have to require easymenu (even for Emacs 18) just so -;; the easy-menu-define macro call is compiled correctly. -(require 'easymenu) - -(defconst edebug-mode-menus - '("Edebug" - "----" - ["Stop" edebug-stop t] - ["Step" edebug-step-mode t] - ["Next" edebug-next-mode t] - ["Trace" edebug-trace-mode t] - ["Trace Fast" edebug-Trace-fast-mode t] - ["Continue" edebug-continue-mode t] - ["Continue Fast" edebug-Continue-fast-mode t] - ["Go" edebug-go-mode t] - ["Go Nonstop" edebug-Go-nonstop-mode t] - "----" - ["Help" edebug-help t] - ["Abort" abort-recursive-edit t] - ["Quit to Top Level" top-level t] - ["Quit Nonstop" edebug-top-level-nonstop t] - "----" - ("Jumps" - ["Forward Sexp" edebug-forward-sexp t] - ["Step In" edebug-step-in t] - ["Step Out" edebug-step-out t] - ["Goto Here" edebug-goto-here t]) - - ("Breaks" - ["Set Breakpoint" edebug-set-breakpoint t] - ["Unset Breakpoint" edebug-unset-breakpoint t] - ["Set Conditional Breakpoint" edebug-set-conditional-breakpoint t] - ["Set Global Break Condition" edebug-set-global-break-condition t] - ["Show Next Breakpoint" edebug-next-breakpoint t]) - - ("Views" - ["Where am I?" edebug-where t] - ["Bounce to Current Point" edebug-bounce-point t] - ["View Outside Windows" edebug-view-outside t] - ["Previous Result" edebug-previous-result t] - ["Show Backtrace" edebug-backtrace t] - ["Display Freq Count" edebug-display-freq-count t]) - - ("Eval" - ["Expression" edebug-eval-expression t] - ["Last Sexp" edebug-eval-last-sexp t] - ["Visit Eval List" edebug-visit-eval-list t]) - - ("Options" - ["Edebug All Defs" edebug-all-defs t] - ["Edebug All Forms" edebug-all-forms t] - "----" - ["Toggle Tracing" (edebug-toggle 'edebug-trace) t] - ["Toggle Coverage Testing" (edebug-toggle 'edebug-test-coverage) t] - ["Toggle Window Saving" edebug-toggle-save-windows t] - ["Toggle Point Saving" - (edebug-toggle 'edebug-save-displayed-buffer-points) t] - )) - "Lemacs style menus for Edebug.") - - -;;; Emacs version specific code - -;;; The default for all above is Emacs 18, because it is easier to compile -;;; Emacs 18 code in Emacs 19 than vice versa. This default will -;;; change once most people are using Emacs 19 or derivatives. - -;; Epoch specific code is in a separate file: edebug-epoch.el. - -;; The byte-compiler will complain about changes in number of arguments -;; to functions like mark and read-from-minibuffer. These warnings -;; may be ignored because the right call should always be made. - -(defun edebug-emacs-19-specific () - - (defalias 'edebug-window-live-p 'window-live-p) - - ;; Mark takes an argument in Emacs 19. - (defun edebug-mark () - (mark t));; Does this work for lemacs too? - - (defun edebug-set-conditional-breakpoint (arg condition) - "Set a conditional breakpoint at nearest sexp. -The condition is evaluated in the outside context. -With prefix argument, make it a temporary breakpoint." - ;; (interactive "P\nxCondition: ") - (interactive - (list - current-prefix-arg - ;; Read condition as follows; getting previous condition is cumbersome: - (let ((edebug-stop-point (edebug-find-stop-point))) - (if edebug-stop-point - (let* ((edebug-def-name (car edebug-stop-point)) - (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) - (edebug-breakpoints (car (cdr edebug-data))) - (edebug-break-data (assq index edebug-breakpoints)) - (edebug-break-condition (car (cdr edebug-break-data))) - (edebug-expression-history - ;; Prepend the current condition, if any. - (if edebug-break-condition - (cons edebug-break-condition read-expression-history) - read-expression-history))) - (prog1 - (read-from-minibuffer - "Condition: " nil read-expression-map t - 'edebug-expression-history) - (setq read-expression-history edebug-expression-history) - )))))) - (edebug-modify-breakpoint t condition arg)) - - (defun edebug-eval-expression (edebug-expr) - "Evaluate an expression in the outside environment. -If interactive, prompt for the expression. -Print result in minibuffer." - (interactive (list (read-from-minibuffer - "Eval: " nil read-expression-map t - 'read-expression-history))) - (princ - (edebug-outside-excursion - (setq values (cons (edebug-eval edebug-expr) values)) - (edebug-safe-prin1-to-string (car values))))) - - (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus) - (if window-system - (x-popup-menu nil (lookup-key edebug-mode-map [menu-bar Edebug]))) - ) - - -(defun edebug-lemacs-specific () - - ;; We need to bind zmacs-regions to nil around all calls to `mark' and - ;; `mark-marker' but don't bind it to nil before entering a recursive edit, - ;; that is, don't interfere with the binding the user might see while - ;; executing a command. - - (defvar zmacs-regions) - - (defun edebug-mark () - (let ((zmacs-regions nil)) - (mark))) - - (defun edebug-mark-marker () - (let ((zmacs-regions nil));; for lemacs - (mark-marker))) - - - (defun edebug-mode-menu (event) - (interactive "@event") - (popup-menu edebug-mode-menus)) - - (define-key edebug-mode-map 'button3 'edebug-mode-menu) - ) - -(defun edebug-emacs-version-specific () - (cond - ((string-match "Lucid" emacs-version);; Lucid Emacs - (edebug-lemacs-specific)) - - ((and (boundp 'epoch::version) epoch::version) - (require 'edebug-epoch)) - - ((not (string-match "^18" emacs-version)) - (edebug-emacs-19-specific)))) - -(edebug-emacs-version-specific) - - -;;; 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)) - (if edebug-unread-command-event-warning - (put 'unread-command-event 'byte-obsolete-variable - edebug-unread-command-event-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." - (mapcar - (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 - -(if (featurep 'cl) - (add-hook 'edebug-setup-hook - (function (lambda () (require 'cl-specs)))) - ;; The following causes cl-specs to be loaded if you load cl.el. - (add-hook 'cl-load-hook - (function (lambda () (require 'cl-specs))))) - -;;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu -(if (featurep 'cl-read) - (add-hook 'edebug-setup-hook - (function (lambda () (require 'edebug-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))))) - - -;;; Finalize Loading - -;;; 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) - -(provide 'edebug) - -;;; edebug.el ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el deleted file mode 100644 index ff84819c748..00000000000 --- a/lisp/emacs-lisp/eldoc.el +++ /dev/null @@ -1,458 +0,0 @@ -;;; eldoc.el --- show function arglist or variable docstring in echo area - -;; Copyright (C) 1995 Noah S. Friedman - -;; Author: Noah Friedman <friedman@prep.ai.mit.edu> -;; Maintainer: friedman@prep.ai.mit.edu -;; Keywords: extensions -;; Status: Works in Emacs 19 and XEmacs. -;; Created: 1995-10-06 - -;; LCD Archive Entry: -;; eldoc|Noah Friedman|friedman@prep.ai.mit.edu| -;; show function arglist or variable docstring in echo area| -;; $Date: 1996/07/14 16:46:25 $|$Revision: 1.6 $|~/misc/eldoc.el.gz| - -;; $Id: eldoc.el,v 1.6 1996/07/14 16:46:25 friedman Exp friedman $ - -;; 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 2, 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, you can either send email to this -;; program's maintainer or write to: The Free Software Foundation, -;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This program was inspired by the behavior of the Lisp Machine "mouse -;; documentation window"; as you type a function's symbol name as part of a -;; sexp, it will print the argument list for that function. However, this -;; program's behavior is different in a couple of significant ways. For -;; one, you need not actually type the function name; you need only move -;; point around in a sexp that calls it. However, if point is over a -;; documented variable, it will print the one-line documentation for that -;; variable instead, to remind you of that variable's purpose. - -;; One useful way to enable this minor mode is to put the following in your -;; .emacs: -;; -;; (autoload 'turn-on-eldoc-mode "eldoc" nil t) -;; (add-hook 'emacs-lisp-mode-hook 'turn-on-eldoc-mode) -;; (add-hook 'lisp-interaction-mode-hook 'turn-on-eldoc-mode) - -;;; Code: - -;;;###autoload -(defvar eldoc-mode nil - "*If non-nil, show the defined parameters for the elisp function near point. - -For the emacs lisp function at the beginning of the sexp which point is -within, show the defined parameters for the function in the echo area. -This information is extracted directly from the function or macro if it is -in pure lisp. - -If the emacs function is a subr, the parameters are obtained from the -documentation string if possible. - -If point is over a documented variable, print that variable's docstring -instead; see function `eldoc-print-var-docstring'. - -This variable is buffer-local.") -(make-variable-buffer-local 'eldoc-mode) - -(defvar eldoc-idle-delay 0.50 - "*Number of seconds of idle time to wait before printing. -If user input arrives before this interval of time has elapsed after the -last input, no documentation will be printed. - -If this variable is set to 0, no idle time is required.") - -(defvar eldoc-argument-case 'upcase - "Case to display argument names of functions, as a symbol. -This has two preferred values: `upcase' or `downcase'. -Actually, any name of a function which takes a string as an argument and -returns another string is acceptable.") - -(defvar eldoc-mode-message-commands nil - "*Obarray of command names where it is appropriate to print in the echo area. - -This is not done for all commands since some print their own -messages in the echo area, and these functions would instantly overwrite -them. But self-insert-command as well as most motion commands are good -candidates. - -It is probably best to manipulate this data structure with the commands -`eldoc-add-command' and `eldoc-remove-command'.") - -(cond ((null eldoc-mode-message-commands) - ;; If you increase the number of buckets, keep it a prime number. - (setq eldoc-mode-message-commands (make-vector 31 0)) - (let ((list '("self-insert-command" - "next-" "previous-" - "forward-" "backward-" - "beginning-of-" "end-of-" - "goto-" - "recenter" - "scroll-")) - (syms nil)) - (while list - (setq syms (all-completions (car list) obarray 'fboundp)) - (setq list (cdr list)) - (while syms - (set (intern (car syms) eldoc-mode-message-commands) t) - (setq syms (cdr syms))))))) - -;; Bookkeeping; the car contains the last symbol read from the buffer. -;; The cdr contains the string last displayed in the echo area, so it can -;; be printed again if necessary without reconsing. -(defvar eldoc-last-data '(nil . nil)) - -(defvar eldoc-minor-mode-string " ElDoc" - "*String to display in mode line when Eldoc Mode is enabled.") - -;; Put this minor mode on the global minor-mode-alist. -(or (assq 'eldoc-mode (default-value 'minor-mode-alist)) - (setq-default minor-mode-alist - (append (default-value 'minor-mode-alist) - '((eldoc-mode eldoc-minor-mode-string))))) - -;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages are -;; recorded in a log. Do not put eldoc messages in that log since -;; they are Legion. -(defmacro eldoc-message (&rest args) - (if (fboundp 'display-message) - ;; XEmacs 19.13 way of preventing log messages. - (list 'display-message '(quote no-log) (apply 'list 'format args)) - (list 'let (list (list 'message-log-max 'nil)) - (apply 'list 'message args)))) - - -;;;###autoload -(defun eldoc-mode (&optional prefix) - "*If non-nil, then enable eldoc-mode (see variable docstring)." - (interactive "P") - - ;; Make sure it's on the post-command-idle-hook if defined, otherwise put - ;; it on post-command-hook. The former first appeared in Emacs 19.30. - (add-hook (if (boundp 'post-command-idle-hook) - 'post-command-idle-hook - 'post-command-hook) - 'eldoc-mode-print-current-symbol-info) - - (setq eldoc-mode (if prefix - (>= (prefix-numeric-value prefix) 0) - (not eldoc-mode))) - - (and (interactive-p) - (if eldoc-mode - (message "eldoc-mode is enabled") - (message "eldoc-mode is disabled"))) - eldoc-mode) - -;;;###autoload -(defun turn-on-eldoc-mode () - "Unequivocally turn on eldoc-mode (see variable documentation)." - (interactive) - (eldoc-mode 1)) - -(defun eldoc-add-command (cmd) - "Add COMMAND to the list of commands which causes function arg display. -If called interactively, completion matches any bound function. - -When point is in a sexp, the function args are not reprinted in the echo -area after every possible interactive command because some of them print -their own messages in the echo area; the eldoc functions would instantly -overwrite them unless it is more restrained." - (interactive "aAdd function to eldoc message commands list: ") - (and (fboundp cmd) - (set (intern (symbol-name cmd) eldoc-mode-message-commands) t))) - -(defun eldoc-remove-command (cmd) - "Remove COMMAND from the list of commands which causes function arg display. -If called interactively, completion matches only those functions currently -in the list. - -When point is in a sexp, the function args are not reprinted in the echo -area after every possible interactive command because some of them print -their own messages in the echo area; the eldoc functions would instantly -overwrite them unless it is more restrained." - (interactive (list (completing-read - "Remove function from eldoc message commands list: " - eldoc-mode-message-commands 'boundp t))) - (and (symbolp cmd) - (setq cmd (symbol-name cmd))) - (if (fboundp 'unintern) - (unintern cmd eldoc-mode-message-commands) - (let ((s (intern-soft cmd eldoc-mode-message-commands))) - (and s - (makunbound s))))) - -(defun eldoc-mode-print-current-symbol-info () - (and eldoc-mode - (not executing-macro) - ;; Having this mode operate in the minibuffer makes it impossible to - ;; see what you're doing. - (not (eq (selected-window) (minibuffer-window))) - (sit-for eldoc-idle-delay) - (symbolp this-command) - (intern-soft (symbol-name this-command) eldoc-mode-message-commands) - (let ((current-symbol (eldoc-current-symbol)) - (current-fnsym (eldoc-fnsym-in-current-sexp))) - (cond ((eq current-symbol current-fnsym) - (eldoc-print-fnsym-args current-fnsym)) - (t - (or (eldoc-print-var-docstring current-symbol) - (eldoc-print-fnsym-args current-fnsym))))))) - - -(defun eldoc-print-var-docstring (&optional sym) - "Print the brief (one-line) documentation string for the variable at point. -If called with no argument, print the first line of the variable -documentation string for the symbol at point in the echo area. -If called with a symbol, print the line for that symbol. - -If the entire line cannot fit in the echo area, the variable name may be -truncated or eliminated entirely from the output to make room. -Any leading `*' in the docstring (which indicates the variable is a user -option) is not printed." - (interactive) - (let* ((s (or sym (eldoc-current-symbol))) - (name (symbol-name s)) - (doc (and s (documentation-property s 'variable-documentation t)))) - (and doc - (save-match-data - (and (string-match "\n" doc) - (setq doc (substring doc 0 (match-beginning 0)))) - (and (string-match "^\\*" doc) - (setq doc (substring doc 1))) - (let* ((doclen (+ (length name) (length ": ") (length doc))) - ;; Subtract 1 from window width since emacs seems not to - ;; write any chars to the last column, at least for some - ;; terminal types. - (strip (- doclen (1- (window-width (minibuffer-window)))))) - (cond ((> strip 0) - (let* ((len (length name))) - (cond ((>= strip len) - (eldoc-message "%s" doc)) - (t - (setq name (substring name 0 (- len strip))) - (eldoc-message "%s: %s" name doc))))) - (t - (eldoc-message "%s: %s" s doc)))) - t)))) - - -;;;###autoload -(defun eldoc-print-fnsym-args (&optional symbol) - "*Show the defined parameters for the function near point. -For the function at the beginning of the sexp which point is within, show -the defined parameters for the function in the echo area. -This information is extracted directly from the function or macro if it is -in pure lisp. -If the emacs function is a subr, the parameters are obtained from the -documentation string if possible." - (interactive) - (let ((sym (or symbol (eldoc-fnsym-in-current-sexp))) - (printit t) - (args nil)) - (cond ((not (and (symbolp sym) - (fboundp sym)))) - ((eq sym (car eldoc-last-data)) - (setq printit nil) - (setq args (cdr eldoc-last-data))) - ((subrp (eldoc-symbol-function sym)) - (setq args (eldoc-function-argstring-from-docstring sym)) - (setcdr eldoc-last-data args)) - (t - (setq args (eldoc-function-argstring sym)) - (setcdr eldoc-last-data args))) - (and args - printit - (eldoc-message "%s: %s" sym args)))) - -(defun eldoc-fnsym-in-current-sexp () - (let* ((p (point)) - (sym (progn - (while (and (eldoc-forward-sexp-safe -1) - (> (point) (point-min)))) - (cond ((or (= (point) (point-min)) - (memq (or (char-after (point)) 0) - '(?\( ?\")) - ;; If we hit a quotation mark before a paren, we - ;; are inside a specific string, not a list of - ;; symbols. - (eq (or (char-after (1- (point))) 0) ?\")) - nil) - (t (condition-case nil - (read (current-buffer)) - (error nil))))))) - (goto-char p) - (and (symbolp sym) - sym))) - -(defun eldoc-function-argstring (fn) - (let* ((prelim-def (eldoc-symbol-function fn)) - (def (if (eq (car-safe prelim-def) 'macro) - (cdr prelim-def) - prelim-def)) - (arglist (cond ((null def) nil) - ((byte-code-function-p def) - (if (fboundp 'compiled-function-arglist) - (funcall 'compiled-function-arglist def) - (aref def 0))) - ((eq (car-safe def) 'lambda) - (nth 1 def)) - (t t)))) - (eldoc-function-argstring-format arglist))) - -(defun eldoc-function-argstring-from-docstring (fn) - (let ((docstring (documentation fn 'raw)) - (doc nil) - (doclist nil) - (end nil)) - (save-match-data - ;; TODO: Move these into a separate table that is iterated over until - ;; a match is found. - (cond - ;; Try first searching for args starting with symbol name. - ;; This is to avoid matching parenthetical remarks in e.g. sit-for. - ((string-match (format "^(%s[^\n)]*)$" fn) docstring) - ;; end does not include trailing ")" sequence. - (setq end (- (match-end 0) 1)) - (if (string-match " +" docstring (match-beginning 0)) - (setq doc (substring docstring (match-end 0) end)) - (setq doc ""))) - - ;; Try again not requiring this symbol name in the docstring. - ;; This will be the case when looking up aliases. - ((string-match (format "^([^\n)]+)$" fn) docstring) - ;; end does not include trailing ")" sequence. - (setq end (- (match-end 0) 1)) - (if (string-match " +" docstring (match-beginning 0)) - (setq doc (substring docstring (match-end 0) end)) - (setq doc ""))) - - ;; Emacs subr docstring style: - ;; (fn arg1 arg2 ...): description... - ((string-match "^([^\n)]+):" docstring) - ;; end does not include trailing "):" sequence. - (setq end (- (match-end 0) 2)) - (if (string-match " +" docstring (match-beginning 0)) - (setq doc (substring docstring (match-end 0) end)) - (setq doc ""))) - - ;; XEmacs subr docstring style: - ;; "arguments: (arg1 arg2 ...) - ((string-match "^arguments: (\\([^\n)]+\\))" docstring) - ;; Also, skip leading paren, but the first word is actually an - ;; argument, not the function name. - (setq doc (substring docstring - (match-beginning 1) - (match-end 1)))) - - ;; This finds the argstring for `condition-case'. - ;; I don't know if there are any others with the same pattern. - ((string-match (format "^Usage looks like \\((%s[^\n)]*)\\)\\.$" fn) - docstring) - ;; end does not include trailing ")" sequence. - (setq end (- (match-end 1) 1)) - (if (string-match " +" docstring (match-beginning 1)) - (setq doc (substring docstring (match-end 0) end)) - (setq doc ""))) - - ;; This finds the argstring for `setq-default'. - ;; I don't know if there are any others with the same pattern. - ((string-match (format "^[ \t]+\\((%s[^\n)]*)\\)$" fn) docstring) - ;; end does not include trailing ")" sequence. - (setq end (- (match-end 1) 1)) - (if (string-match " +" docstring (match-beginning 1)) - (setq doc (substring docstring (match-end 0) end)) - (setq doc ""))) - - ;; This finds the argstring for `start-process'. - ;; I don't know if there are any others with the same pattern. - ((string-match "^Args are +\\([^\n]+\\)$" docstring) - (setq doc (substring docstring (match-beginning 1) (match-end 1)))) - ) - - (cond ((not (stringp doc)) - nil) - ((string-match "&" doc) - (let ((p 0) - (l (length doc))) - (while (< p l) - (cond ((string-match "[ \t\n]+" doc p) - (setq doclist - (cons (substring doc p (match-beginning 0)) - doclist)) - (setq p (match-end 0))) - (t - (setq doclist (cons (substring doc p) doclist)) - (setq p l)))) - (eldoc-function-argstring-format (nreverse doclist)))) - (t - (concat "(" (funcall eldoc-argument-case doc) ")")))))) - -(defun eldoc-function-argstring-format (arglist) - (cond ((not (listp arglist)) - (setq arglist nil)) - ((symbolp (car arglist)) - (setq arglist - (mapcar (function (lambda (s) - (if (memq s '(&optional &rest)) - (symbol-name s) - (funcall eldoc-argument-case - (symbol-name s))))) - arglist))) - ((stringp (car arglist)) - (setq arglist - (mapcar (function (lambda (s) - (if (member s '("&optional" "&rest")) - s - (funcall eldoc-argument-case s)))) - arglist)))) - (concat "(" (mapconcat 'identity arglist " ") ")")) - - -;; forward-sexp calls scan-sexps, which returns an error if it hits the -;; beginning or end of the sexp. This returns nil instead. -(defun eldoc-forward-sexp-safe (&optional count) - "Move forward across one balanced expression (sexp). -With argument, do it that many times. Negative arg -COUNT means -move backward across COUNT balanced expressions. -Return distance in buffer moved, or nil." - (or count (setq count 1)) - (condition-case err - (- (- (point) (progn - (let ((parse-sexp-ignore-comments t)) - (forward-sexp count)) - (point)))) - (error nil))) - -;; Do indirect function resolution if possible. -(defun eldoc-symbol-function (fsym) - (let ((defn (and (fboundp fsym) - (symbol-function fsym)))) - (and (symbolp defn) - (condition-case err - (setq defn (indirect-function fsym)) - (error (setq defn nil)))) - defn)) - -(defun eldoc-current-symbol () - (let ((c (char-after (point)))) - (and c - (memq (char-syntax c) '(?w ?_)) - (intern-soft (current-word))))) - -(provide 'eldoc) - -;;; eldoc.el ends here diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el deleted file mode 100644 index 7c07e900b38..00000000000 --- a/lisp/emacs-lisp/elp.el +++ /dev/null @@ -1,563 +0,0 @@ -;;; elp.el --- Emacs Lisp Profiler - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Author: 1994 Barry A. Warsaw <bwarsaw@cnri.reston.va.us> -;; Maintainer: tools-help@anthem.nlm.nih.gov -;; Created: 26-Feb-1994 -;; Version: 2.23 -;; Last Modified: 1994/12/28 22:39:31 -;; Keywords: Emacs Lisp Profile Timing - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; -;; If you want to profile a bunch of functions, set elp-function-list -;; to the list of symbols, then do a M-x elp-instrument-list. This -;; hacks those functions so that profiling information is recorded -;; whenever they are called. To print out the current results, use -;; M-x elp-results. With elp-reset-after-results set to non-nil, -;; profiling information will be reset whenever the results are -;; displayed. You can also reset all profiling info at any time with -;; M-x elp-reset-all. -;; -;; You can also instrument all functions in a package, provided that -;; the package follows the GNU coding standard of a common textural -;; prefix. Use M-x elp-instrument-package for this. -;; -;; If you want to sort the results, set elp-sort-by-function to some -;; predicate function. The three most obvious choices are predefined: -;; elp-sort-by-call-count, elp-sort-by-average-time, and -;; elp-sort-by-total-time. Also, you can prune from the output, all -;; functions that have been called fewer than a given number of times -;; by setting elp-report-limit. -;; -;; Elp can instrument byte-compiled functions just as easily as -;; interpreted functions, but it cannot instrument macros. However, -;; when you redefine a function (e.g. with eval-defun), you'll need to -;; re-instrument it with M-x elp-instrument-function. This will also -;; reset profiling information for that function. Elp can handle -;; interactive functions (i.e. commands), but of course any time spent -;; idling for user prompts will show up in the timing results. -;; -;; You can also designate a `master' function. Profiling times will -;; be gathered for instrumented functions only during execution of -;; this master function. Thus, if you have some defuns like: -;; -;; (defun foo () (do-something-time-intensive)) -;; (defun bar () (foo)) -;; (defun baz () (bar) (foo)) -;; -;; and you want to find out the amount of time spent in bar and foo, -;; but only during execution of bar, make bar the master. The call of -;; foo from baz will not add to foo's total timing sums. Use M-x -;; elp-set-master and M-x elp-unset-master to utilize this feature. -;; Only one master function can be set at a time. - -;; You can restore any function's original function definition with -;; elp-restore-function. The other instrument, restore, and reset -;; functions are provided for symmetry. - -;; Note that there are plenty of factors that could make the times -;; reported unreliable, including the accuracy and granularity of your -;; system clock, and the overhead spent in lisp calculating and -;; recording the intervals. The latter I figure is pretty constant -;; so, while the times may not be entirely accurate, I think they'll -;; give you a good feel for the relative amount of work spent in the -;; various lisp routines you are profiling. Note further that times -;; are calculated using wall-clock time, so other system load will -;; affect accuracy too. - -;; Here is a list of variable you can use to customize elp: -;; elp-function-list -;; elp-reset-after-results -;; elp-sort-by-function -;; elp-report-limit -;; -;; Here is a list of the interactive commands you can use: -;; elp-instrument-function -;; elp-restore-function -;; elp-instrument-list -;; elp-restore-list -;; elp-instrument-package -;; elp-restore-all -;; elp-reset-function -;; elp-reset-list -;; elp-reset-all -;; elp-set-master -;; elp-unset-master -;; elp-results -;; elp-submit-bug-report - -;; Note that there are plenty of factors that could make the times -;; reported unreliable, including the accuracy and granularity of your -;; system clock, and the overhead spent in lisp calculating and -;; recording the intervals. I figure the latter is pretty constant, -;; so while the times may not be entirely accurate, I think they'll -;; give you a good feel for the relative amount of work spent in the -;; various lisp routines you are profiling. Note further that times -;; are calculated using wall-clock time, so other system load will -;; affect accuracy too. You cannot profile anything longer than ~18 -;; hours since I throw away the most significant 16 bits of seconds -;; returned by current-time: 2^16 == 65536 seconds == ~1092 minutes == -;; ~18 hours. I doubt you will ever want to profile stuff on the -;; order of 18 hours anyway. - -;;; Background: - -;; This program is based on the only two existing Emacs Lisp profilers -;; that I'm aware of, Boaz Ben-Zvi's profile.el, and Root Boy Jim's -;; profiler.el. Both were written for Emacs 18 and both were pretty -;; good first shots at profiling, but I found that they didn't provide -;; the functionality or interface that I wanted. So I wrote this. -;; I've tested elp in GNU Emacs 19 and in GNU XEmacs. There's no -;; point in even trying to make this work with Emacs 18. - -;; Unlike previous profilers, elp uses Emacs 19's built-in function -;; current-time to return interval times. This obviates the need for -;; both an external C program and Emacs processes to communicate with -;; such a program, and thus simplifies the package as a whole. - -;;; Code: - - -;; start user configuration variables -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - -(defvar elp-function-list nil - "*List of function to profile.") - -(defvar elp-reset-after-results t - "*Non-nil means reset all profiling info after results are displayed. -Results are displayed with the `elp-results' command.") - -(defvar elp-sort-by-function nil - "*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 - -You can write you're own sort function. It should adhere to the -interface specified by the PRED argument for the `sort' defun. Each -\"element of LIST\" is really a 4 element vector where element 0 is -the call count, element 1 is the total time spent in the function, -element 2 is the average time spent in the function, and element 3 is -the symbol's name string.") - -(defvar elp-report-limit nil - "*Prevents some functions from being displayed in the results buffer. -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.") - - -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -;; end user configuration variables - - -(defconst elp-version "2.23" - "ELP version number.") - -(defconst elp-help-address "tools-help@anthem.nlm.nih.gov" - "Address accepting submissions of bug reports and questions.") - -(defvar elp-results-buffer "*ELP Profiling Results*" - "Buffer name for outputting profiling results.") - -(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.") - -(defvar elp-master nil - "Master function symbol.") - - -;;;###autoload -(defun elp-instrument-function (funsym) - "Instrument FUNSYM for profiling. -FUNSYM must be a symbol of a defined function." - (interactive "aFunction to instrument: ") - ;; TBD what should we do if the function is already instrumented??? - (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)) - ;; put rest of newguts together - (if (commandp funsym) - (setq newguts (append newguts '((interactive))))) - (setq newguts (append newguts (list - (list 'elp-wrapper - (list 'quote funsym) - (list 'and - '(interactive-p) - (not (not (commandp funsym)))) - '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 - ;; 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: - ;; I haven't tested non-local exits at all, so no guarantees. - ;; - ;; The 1st element is the total amount of time in usecs that have - ;; 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 funsym elp-timer-info-property infovec) - - ;; set the symbol's new profiling function definition to run - ;; elp-wrapper - (fset funsym newguts) - - ;; add this function to the instrumentation list - (or (memq funsym elp-all-instrumented-list) - (setq elp-all-instrumented-list - (cons funsym elp-all-instrumented-list))) - )) - -;;;###autoload -(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 while the - ;; function was instrumented and we don't want to destroy the new - ;; definition. - (and info - (assq 'elp-wrapper (symbol-function funsym)) - (fset funsym (aref info 2))))) - -;;;###autoload -(defun elp-instrument-list (&optional list) - "Instrument for profiling, all functions in `elp-function-list'. -Use optional LIST if provided instead." - (interactive "PList of functions to instrument: ") - (let ((list (or list elp-function-list))) - (mapcar 'elp-instrument-function list))) - -;;;###autoload -(defun elp-instrument-package (prefix) - "Instrument for profiling, all functions which start with PREFIX. -For example, to instrument all ELP functions, do the following: - - \\[elp-instrument-package] RET elp- RET" - (interactive "sPrefix of package to instrument: ") - (elp-instrument-list - (mapcar 'intern (all-completions prefix obarray - (function - (lambda (sym) - (and (fboundp sym) - (not (memq (car-safe - (symbol-function sym)) - '(macro keymap autoload)))))))))) - -(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))) - -(defun elp-restore-all () - "Restores the original definitions of all functions being profiled." - (interactive) - (elp-restore-list elp-all-instrumented-list)) - - -(defun elp-reset-function (funsym) - "Reset the profiling information for FUNSYM." - (interactive "aFunction to reset: ") - (let ((info (get funsym elp-timer-info-property))) - (or info - (error "%s is not instrumented for profiling." funsym)) - (aset info 0 0) ;reset call counter - (aset info 1 0.0) ;reset total time - ;; don't muck with aref 2 as that is the old symbol definition - )) - -(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: ") - (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)) - -(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 - (setq elp-master funsym - elp-record-p nil) - ;; make sure master function is instrumented - (or (memq funsym elp-all-instrumented-list) - (elp-instrument-function funsym))) - -(defun elp-unset-master () - "Unsets the master function." - (interactive) - ;; when there's no master function, recording is turned on by default. - (setq elp-master nil - elp-record-p t)) - - -(defsubst elp-get-time () - ;; get current time in seconds and microseconds. I throw away the - ;; most significant 16 bits of seconds since I doubt we'll ever want - ;; to profile lisp on the order of 18 hours. See notes at top of file. - (let ((now (current-time))) - (+ (float (nth 1 now)) (/ (float (nth 2 now)) 1000000.0)))) - -(defun elp-wrapper (funsym interactive-p 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 (elp-get-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 - (setq result - (if interactive-p - (call-interactively func) - (apply func args))) - ;; calculate total time in function - (aset info 1 (+ (aref info 1) (- (elp-get-time) enter-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 -(defvar elp-field-len nil) -(defvar elp-cc-len nil) -(defvar elp-at-len nil) -(defvar elp-et-len nil) - -(defun elp-sort-by-call-count (vec1 vec2) - ;; sort by highest call count. See `sort'. - (>= (aref vec1 0) (aref vec2 0))) - -(defun elp-sort-by-total-time (vec1 vec2) - ;; sort by highest total time spent in function. See `sort'. - (>= (aref vec1 1) (aref vec2 1))) - -(defun elp-sort-by-average-time (vec1 vec2) - ;; sort by highest average time spent in function. See `sort'. - (>= (aref vec1 2) (aref vec2 2))) - -(defsubst elp-pack-number (number width) - ;; pack the NUMBER string into WIDTH characters, watching out for - ;; very small or large numbers - (if (<= (length number) width) - number - ;; check for very large or small numbers - (if (string-match "^\\(.*\\)\\(e[+-].*\\)$" number) - (concat (substring - (substring number (match-beginning 1) (match-end 1)) - 0 - (- width (match-end 2) (- (match-beginning 2)) 3)) - "..." - (substring number (match-beginning 2) (match-end 2))) - (concat (substring number 0 width))))) - -(defun elp-output-result (resultvec) - ;; output the RESULTVEC into the results buffer. RESULTVEC is a 4 or - ;; more element vector where aref 0 is the call count, aref 1 is the - ;; total time spent in the function, aref 2 is the average time - ;; spent in the function, and aref 3 is the symbol's string - ;; name. All other elements in the vector are ignored. - (let* ((cc (aref resultvec 0)) - (tt (aref resultvec 1)) - (at (aref resultvec 2)) - (symname (aref resultvec 3)) - callcnt totaltime avetime) - (setq callcnt (number-to-string cc) - totaltime (number-to-string tt) - avetime (number-to-string at)) - ;; possibly prune the results - (if (and elp-report-limit - (numberp elp-report-limit) - (< cc elp-report-limit)) - nil - (insert symname) - (insert-char 32 (+ elp-field-len (- (length symname)) 2)) - ;; print stuff out, formatting it nicely - (insert callcnt) - (insert-char 32 (+ elp-cc-len (- (length callcnt)) 2)) - (let ((ttstr (elp-pack-number totaltime elp-et-len)) - (atstr (elp-pack-number avetime elp-at-len))) - (insert ttstr) - (insert-char 32 (+ elp-et-len (- (length ttstr)) 2)) - (insert atstr)) - (insert "\n")))) - -;;;###autoload -(defun elp-results () - "Display current profiling results. -If `elp-reset-after-results' is non-nil, then current profiling -information for all instrumented functions are reset after results are -displayed." - (interactive) - (let ((curbuf (current-buffer)) - (resultsbuf (get-buffer-create elp-results-buffer))) - (set-buffer resultsbuf) - (erase-buffer) - (beginning-of-buffer) - ;; get the length of the longest function name being profiled - (let* ((longest 0) - (title "Function Name") - (titlelen (length title)) - (elp-field-len titlelen) - (cc-header "Call Count") - (elp-cc-len (length cc-header)) - (et-header "Elapsed Time") - (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)) - ) ; end let* - (insert title) - (if (> longest titlelen) - (progn - (insert-char 32 (- longest titlelen)) - (setq elp-field-len longest))) - (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") - ;; if sorting is enabled, then sort the results list. in either - ;; case, call elp-output-result to output the result in the - ;; buffer - (if elp-sort-by-function - (setq resvec (sort resvec elp-sort-by-function))) - (mapcar 'elp-output-result resvec)) - ;; now pop up results buffer - (set-buffer curbuf) - (pop-to-buffer resultsbuf) - ;; reset profiling info if desired - (and elp-reset-after-results - (elp-reset-all)))) - - -(eval-when-compile - (require 'reporter)) - -;;;###autoload -(defun elp-submit-bug-report () - "Submit via mail, a bug report on elp." - (interactive) - (and - (y-or-n-p "Do you want to submit a report on elp? ") - (require 'reporter) - (reporter-submit-bug-report - elp-help-address (concat "elp " elp-version) - '(elp-report-limit - elp-reset-after-results - elp-sort-by-function)))) - - -(provide 'elp) - -;; elp.el ends here diff --git a/lisp/emacs-lisp/eval-reg.el b/lisp/emacs-lisp/eval-reg.el deleted file mode 100644 index d97a4ea46de..00000000000 --- a/lisp/emacs-lisp/eval-reg.el +++ /dev/null @@ -1,219 +0,0 @@ -;;; eval-reg.el --- Redefine eval-region, and subrs that use it, in Lisp - -;; Copyright (C) 1994, 1996 Daniel LaLiberte - -;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> -;; Keywords: 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 2, 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; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; eval-region, eval-buffer, and eval-current-buffer are redefined in -;; Lisp to allow customizations by Lisp code. eval-region calls -;; `read', `eval', and `prin1', so Lisp replacements of these -;; functions will affect eval-region and anything else that calls it. -;; eval-buffer and eval-current-buffer are redefined in Lisp to call -;; eval-region on the buffer. - -;; Because of dynamic binding, all local variables are protected from -;; being seen by eval by giving them funky names. But variables in -;; routines that call eval-region are similarly exposed. - -;; Perhaps this should be one of several files in an `elisp' package -;; that replaces Emacs Lisp subroutines with Lisp versions of the -;; same. - -;; Eval-region may be installed, after loading, by calling: -;; (elisp-eval-region-install). Installation can be undone with: -;; (elisp-eval-region-uninstall). - -;;; Code: - -'(defpackage "elisp-eval-region" - (:nicknames "elisp") - (:use "elisp") - (:export - elisp-eval-region-install - elisp-eval-region-uninstall - elisp-eval-region-level - with-elisp-eval-region - eval-region - eval-buffer - eval-current-buffer - )) -'(in-package elisp-eval-region) - -;; Save standard versions. -(if (not (fboundp 'original-eval-region)) - (defalias 'original-eval-region (symbol-function 'eval-region))) -(if (not (fboundp 'original-eval-buffer)) - (defalias 'original-eval-buffer - (if (fboundp 'eval-buffer) ;; only in Emacs 19 - (symbol-function 'eval-buffer) - 'undefined))) -(if (not (fboundp 'original-eval-current-buffer)) - (defalias 'original-eval-current-buffer - (symbol-function 'eval-current-buffer))) - -(defvar elisp-eval-region-level 0 - "If the value is 0, use the original version of `elisp-eval-region'. -Callers of `elisp-eval-region' should increment `elisp-eval-region-level' -while the Lisp version should be used. Installing `elisp-eval-region' -increments it once, and uninstalling decrements it.") - -;; Installing and uninstalling should always be used in pairs, -;; or just install once and never uninstall. -(defun elisp-eval-region-install () - (interactive) - (defalias 'eval-region 'elisp-eval-region) - (defalias 'eval-buffer 'elisp-eval-buffer) - (defalias 'eval-current-buffer 'elisp-eval-current-buffer) - (setq elisp-eval-region-level (1+ elisp-eval-region-level))) - -(defun elisp-eval-region-uninstall () - (interactive) - (if (> 1 elisp-eval-region-level) - (setq elisp-eval-region-level (1- elisp-eval-region-level)) - (setq elisp-eval-region-level 0) - (defalias 'eval-region (symbol-function 'original-eval-region)) - (defalias 'eval-buffer (symbol-function 'original-eval-buffer)) - (defalias 'eval-current-buffer - (symbol-function 'original-eval-current-buffer)) - )) - -(put 'with-elisp-eval-region 'lisp-indent-function 1) -(put 'with-elisp-eval-region 'lisp-indent-hook 1) -(put 'with-elisp-eval-region 'edebug-form-spec t) - -(defmacro with-elisp-eval-region (flag &rest body) - "If FLAG is nil, decrement `eval-region-level' while executing BODY. -The effect of decrementing all the way to zero is that `eval-region' -will use the original `eval-region', which may be the Emacs subr or some -previous redefinition. Before calling this macro, this package should -already have been installed, using `elisp-eval-region-install', which -increments the count once. So if another package still requires the -Lisp version of the code, the count will still be non-zero. - -The count is not bound locally by this macro, so changes by BODY to -its value will not be lost." - (` (let ((elisp-code (function (lambda () (,@ body))))) - (if (not (, flag)) - (unwind-protect - (progn - (setq elisp-eval-region-level (1- elisp-eval-region-level)) - (funcall elisp-code)) - (setq elisp-eval-region-level (1+ elisp-eval-region-level))) - (funcall elisp-code))))) - - -(defun elisp-eval-region (elisp-start elisp-end &optional elisp-output) - "Execute the region as Lisp code. -When called from programs, expects two arguments, -giving starting and ending indices in the current buffer -of the text to be executed. -Programs can pass third argument PRINTFLAG which controls printing of output: -nil means discard it; anything else is stream for print. - -This version, from `eval-reg.el', allows Lisp customization of read, -eval, and the printer." - - ;; Because this doesn't narrow to the region, one other difference - ;; concerns inserting whitespace after the expression being evaluated. - - (interactive "r") - (if (= 0 elisp-eval-region-level) - (original-eval-region elisp-start elisp-end elisp-output) - (let ((elisp-pnt (point)) - (elisp-buf (current-buffer));; Outside buffer - (elisp-inside-buf (current-buffer));; Buffer current while evalling - ;; Mark the end because it may move. - (elisp-end-marker (set-marker (make-marker) elisp-end)) - elisp-form - elisp-val) - (goto-char elisp-start) - (elisp-skip-whitespace) - (while (< (point) elisp-end-marker) - (setq elisp-form (read elisp-buf)) - - (let ((elisp-current-buffer (current-buffer))) - ;; Restore the inside current-buffer. - (set-buffer elisp-inside-buf) - (setq elisp-val (eval elisp-form)) - ;; Remember current buffer for next time. - (setq elisp-inside-buf (current-buffer)) - ;; Should this be protected? - (set-buffer elisp-current-buffer)) - - (if elisp-output - (let ((standard-output (or elisp-output t))) - (setq values (cons elisp-val values)) - (if (eq standard-output t) - (prin1 elisp-val) - (princ "\n") - (prin1 elisp-val) - (princ "\n") - ))) - (goto-char (min (max elisp-end-marker (point)) - (progn (elisp-skip-whitespace) (point)))) - ) ; while - (if elisp-output nil - ;; like save-excursion recovery, but done only if no error occurs - ;; but mark is not restored - (set-buffer elisp-buf) - (goto-char elisp-pnt)) - nil))) - - -(defun elisp-skip-whitespace () - ;; Leave point before the next token, skipping white space and comments. - (skip-chars-forward " \t\r\n\f") - (while (= (following-char) ?\;) - (skip-chars-forward "^\n\r") ; skip the comment - (skip-chars-forward " \t\r\n\f"))) - - -(defun elisp-eval-current-buffer (&optional elisp-output) - "Execute the current buffer as Lisp code. -Programs can pass argument PRINTFLAG which controls printing of output: -nil means discard it; anything else is stream for print. - -This version calls `eval-region' on the whole buffer." - ;; The standard eval-current-buffer doesn't use eval-region. - (interactive) - (eval-region (point-min) (point-max) elisp-output)) - - -(defun elisp-eval-buffer (&optional elisp-bufname elisp-printflag) - "Execute BUFFER as Lisp code. Use current buffer if BUFFER is nil. -Programs can pass argument PRINTFLAG which controls printing of -output: nil means discard it; anything else is stream for print. - -This version calls `eval-region' on the whole buffer." - (interactive) - (if (null elisp-bufname) - (setq elisp-bufname (current-buffer))) - (save-excursion - (set-buffer (or (get-buffer elisp-bufname) - (error "No such buffer: %s" elisp-bufname))) - (eval-region (point-min) (point-max) elisp-printflag))) - - -(provide 'eval-reg) - -;;; eval-reg.el ends here diff --git a/lisp/emacs-lisp/float.el b/lisp/emacs-lisp/float.el deleted file mode 100644 index f4fd9ae0ec9..00000000000 --- a/lisp/emacs-lisp/float.el +++ /dev/null @@ -1,458 +0,0 @@ -;;; float.el --- floating point arithmetic package. - -;; Copyright (C) 1986 Free Software Foundation, Inc. - -;; Author: Bill Rosenblatt -;; Maintainer: FSF -;; Keywords: extensions - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Floating point numbers are represented by dot-pairs (mant . exp) -;; where mant is the 24-bit signed integral mantissa and exp is the -;; base 2 exponent. -;; -;; Emacs LISP supports a 24-bit signed integer data type, which has a -;; range of -(2**23) to +(2**23)-1, or -8388608 to 8388607 decimal. -;; This gives six significant decimal digit accuracy. Exponents can -;; be anything in the range -(2**23) to +(2**23)-1. -;; -;; User interface: -;; function f converts from integer to floating point -;; function string-to-float converts from string to floating point -;; function fint converts a floating point to integer (with truncation) -;; function float-to-string converts from floating point to string -;; -;; Caveats: -;; - Exponents outside of the range of +/-100 or so will cause certain -;; functions (especially conversion routines) to take forever. -;; - Very little checking is done for fixed point overflow/underflow. -;; - No checking is done for over/underflow of the exponent -;; (hardly necessary when exponent can be 2**23). -;; -;; -;; Bill Rosenblatt -;; June 20, 1986 -;; - -;;; Code: - -;; fundamental implementation constants -(defconst exp-base 2 - "Base of exponent in this floating point representation.") - -(defconst mantissa-bits 24 - "Number of significant bits in this floating point representation.") - -(defconst decimal-digits 6 - "Number of decimal digits expected to be accurate.") - -(defconst expt-digits 2 - "Maximum permitted digits in a scientific notation exponent.") - -;; other constants -(defconst maxbit (1- mantissa-bits) - "Number of highest bit") - -(defconst mantissa-maxval (1- (ash 1 maxbit)) - "Maximum permissible value of mantissa") - -(defconst mantissa-minval (ash 1 maxbit) - "Minimum permissible value of mantissa") - -(defconst floating-point-regexp - "^[ \t]*\\(-?\\)\\([0-9]*\\)\ -\\(\\.\\([0-9]*\\)\\|\\)\ -\\(\\(\\([Ee]\\)\\(-?\\)\\([0-9][0-9]*\\)\\)\\|\\)[ \t]*$" - "Regular expression to match floating point numbers. Extract matches: -1 - minus sign -2 - integer part -4 - fractional part -8 - minus sign for power of ten -9 - power of ten -") - -(defconst high-bit-mask (ash 1 maxbit) - "Masks all bits except the high-order (sign) bit.") - -(defconst second-bit-mask (ash 1 (1- maxbit)) - "Masks all bits except the highest-order magnitude bit") - -;; various useful floating point constants -(setq _f0 '(0 . 1)) - -(setq _f1/2 '(4194304 . -23)) - -(setq _f1 '(4194304 . -22)) - -(setq _f10 '(5242880 . -19)) - -;; support for decimal conversion routines -(setq powers-of-10 (make-vector (1+ decimal-digits) _f1)) -(aset powers-of-10 1 _f10) -(aset powers-of-10 2 '(6553600 . -16)) -(aset powers-of-10 3 '(8192000 . -13)) -(aset powers-of-10 4 '(5120000 . -9)) -(aset powers-of-10 5 '(6400000 . -6)) -(aset powers-of-10 6 '(8000000 . -3)) - -(setq all-decimal-digs-minval (aref powers-of-10 (1- decimal-digits)) - highest-power-of-10 (aref powers-of-10 decimal-digits)) - -(defun fashl (fnum) ; floating-point arithmetic shift left - (cons (ash (car fnum) 1) (1- (cdr fnum)))) - -(defun fashr (fnum) ; floating point arithmetic shift right - (cons (ash (car fnum) -1) (1+ (cdr fnum)))) - -(defun normalize (fnum) - (if (> (car fnum) 0) ; make sure next-to-highest bit is set - (while (zerop (logand (car fnum) second-bit-mask)) - (setq fnum (fashl fnum))) - (if (< (car fnum) 0) ; make sure highest bit is set - (while (zerop (logand (car fnum) high-bit-mask)) - (setq fnum (fashl fnum))) - (setq fnum _f0))) ; "standard 0" - fnum) - -(defun abs (n) ; integer absolute value - (if (>= n 0) n (- n))) - -(defun fabs (fnum) ; re-normalize after taking abs value - (normalize (cons (abs (car fnum)) (cdr fnum)))) - -(defun xor (a b) ; logical exclusive or - (and (or a b) (not (and a b)))) - -(defun same-sign (a b) ; two f-p numbers have same sign? - (not (xor (natnump (car a)) (natnump (car b))))) - -(defun extract-match (str i) ; used after string-match - (condition-case () - (substring str (match-beginning i) (match-end i)) - (error ""))) - -;; support for the multiplication function -(setq halfword-bits (/ mantissa-bits 2) ; bits in a halfword - masklo (1- (ash 1 halfword-bits)) ; isolate the lower halfword - maskhi (lognot masklo) ; isolate the upper halfword - round-limit (ash 1 (/ halfword-bits 2))) - -(defun hihalf (n) ; return high halfword, shifted down - (ash (logand n maskhi) (- halfword-bits))) - -(defun lohalf (n) ; return low halfword - (logand n masklo)) - -;; Visible functions - -;; Arithmetic functions -(defun f+ (a1 a2) - "Returns the sum of two floating point numbers." - (let ((f1 (fmax a1 a2)) - (f2 (fmin a1 a2))) - (if (same-sign a1 a2) - (setq f1 (fashr f1) ; shift right to avoid overflow - f2 (fashr f2))) - (normalize - (cons (+ (car f1) (ash (car f2) (- (cdr f2) (cdr f1)))) - (cdr f1))))) - -(defun f- (a1 &optional a2) ; unary or binary minus - "Returns the difference of two floating point numbers." - (if a2 - (f+ a1 (f- a2)) - (normalize (cons (- (car a1)) (cdr a1))))) - -(defun f* (a1 a2) ; multiply in halfword chunks - "Returns the product of two floating point numbers." - (let* ((i1 (car (fabs a1))) - (i2 (car (fabs a2))) - (sign (not (same-sign a1 a2))) - (prodlo (+ (hihalf (* (lohalf i1) (lohalf i2))) - (lohalf (* (hihalf i1) (lohalf i2))) - (lohalf (* (lohalf i1) (hihalf i2))))) - (prodhi (+ (* (hihalf i1) (hihalf i2)) - (hihalf (* (hihalf i1) (lohalf i2))) - (hihalf (* (lohalf i1) (hihalf i2))) - (hihalf prodlo)))) - (if (> (lohalf prodlo) round-limit) - (setq prodhi (1+ prodhi))) ; round off truncated bits - (normalize - (cons (if sign (- prodhi) prodhi) - (+ (cdr (fabs a1)) (cdr (fabs a2)) mantissa-bits))))) - -(defun f/ (a1 a2) ; SLOW subtract-and-shift algorithm - "Returns the quotient of two floating point numbers." - (if (zerop (car a2)) ; if divide by 0 - (signal 'arith-error (list "attempt to divide by zero" a1 a2)) - (let ((bits (1- maxbit)) - (quotient 0) - (dividend (car (fabs a1))) - (divisor (car (fabs a2))) - (sign (not (same-sign a1 a2)))) - (while (natnump bits) - (if (< (- dividend divisor) 0) - (setq quotient (ash quotient 1)) - (setq quotient (1+ (ash quotient 1)) - dividend (- dividend divisor))) - (setq dividend (ash dividend 1) - bits (1- bits))) - (normalize - (cons (if sign (- quotient) quotient) - (- (cdr (fabs a1)) (cdr (fabs a2)) (1- maxbit))))))) - -(defun f% (a1 a2) - "Returns the remainder of first floating point number divided by second." - (f- a1 (f* (ftrunc (f/ a1 a2)) a2))) - - -;; Comparison functions -(defun f= (a1 a2) - "Returns t if two floating point numbers are equal, nil otherwise." - (equal a1 a2)) - -(defun f> (a1 a2) - "Returns t if first floating point number is greater than second, -nil otherwise." - (cond ((and (natnump (car a1)) (< (car a2) 0)) - t) ; a1 nonnegative, a2 negative - ((and (> (car a1) 0) (<= (car a2) 0)) - t) ; a1 positive, a2 nonpositive - ((and (<= (car a1) 0) (natnump (car a2))) - nil) ; a1 nonpos, a2 nonneg - ((/= (cdr a1) (cdr a2)) ; same signs. exponents differ - (> (cdr a1) (cdr a2))) ; compare the mantissas. - (t - (> (car a1) (car a2))))) ; same exponents. - -(defun f>= (a1 a2) - "Returns t if first floating point number is greater than or equal to -second, nil otherwise." - (or (f> a1 a2) (f= a1 a2))) - -(defun f< (a1 a2) - "Returns t if first floating point number is less than second, -nil otherwise." - (not (f>= a1 a2))) - -(defun f<= (a1 a2) - "Returns t if first floating point number is less than or equal to -second, nil otherwise." - (not (f> a1 a2))) - -(defun f/= (a1 a2) - "Returns t if first floating point number is not equal to second, -nil otherwise." - (not (f= a1 a2))) - -(defun fmin (a1 a2) - "Returns the minimum of two floating point numbers." - (if (f< a1 a2) a1 a2)) - -(defun fmax (a1 a2) - "Returns the maximum of two floating point numbers." - (if (f> a1 a2) a1 a2)) - -(defun fzerop (fnum) - "Returns t if the floating point number is zero, nil otherwise." - (= (car fnum) 0)) - -(defun floatp (fnum) - "Returns t if the arg is a floating point number, nil otherwise." - (and (consp fnum) (integerp (car fnum)) (integerp (cdr fnum)))) - -;; Conversion routines -(defun f (int) - "Convert the integer argument to floating point, like a C cast operator." - (normalize (cons int '0))) - -(defun int-to-hex-string (int) - "Convert the integer argument to a C-style hexadecimal string." - (let ((shiftval -20) - (str "0x") - (hex-chars "0123456789ABCDEF")) - (while (<= shiftval 0) - (setq str (concat str (char-to-string - (aref hex-chars - (logand (lsh int shiftval) 15)))) - shiftval (+ shiftval 4))) - str)) - -(defun ftrunc (fnum) ; truncate fractional part - "Truncate the fractional part of a floating point number." - (cond ((natnump (cdr fnum)) ; it's all integer, return number as is - fnum) - ((<= (cdr fnum) (- maxbit)) ; it's all fractional, return 0 - '(0 . 1)) - (t ; otherwise mask out fractional bits - (let ((mant (car fnum)) (exp (cdr fnum))) - (normalize - (cons (if (natnump mant) ; if negative, use absolute value - (ash (ash mant exp) (- exp)) - (- (ash (ash (- mant) exp) (- exp)))) - exp)))))) - -(defun fint (fnum) ; truncate and convert to integer - "Convert the floating point number to integer, with truncation, -like a C cast operator." - (let* ((tf (ftrunc fnum)) (tint (car tf)) (texp (cdr tf))) - (cond ((>= texp mantissa-bits) ; too high, return "maxint" - mantissa-maxval) - ((<= texp (- mantissa-bits)) ; too low, return "minint" - mantissa-minval) - (t ; in range - (ash tint texp))))) ; shift so that exponent is 0 - -(defun float-to-string (fnum &optional sci) - "Convert the floating point number to a decimal string. -Optional second argument non-nil means use scientific notation." - (let* ((value (fabs fnum)) (sign (< (car fnum) 0)) - (power 0) (result 0) (str "") - (temp 0) (pow10 _f1)) - - (if (f= fnum _f0) - "0" - (if (f>= value _f1) ; find largest power of 10 <= value - (progn ; value >= 1, power is positive - (while (f<= (setq temp (f* pow10 highest-power-of-10)) value) - (setq pow10 temp - power (+ power decimal-digits))) - (while (f<= (setq temp (f* pow10 _f10)) value) - (setq pow10 temp - power (1+ power)))) - (progn ; value < 1, power is negative - (while (f> (setq temp (f/ pow10 highest-power-of-10)) value) - (setq pow10 temp - power (- power decimal-digits))) - (while (f> pow10 value) - (setq pow10 (f/ pow10 _f10) - power (1- power))))) - ; get value in range 100000 to 999999 - (setq value (f* (f/ value pow10) all-decimal-digs-minval) - result (ftrunc value)) - (let (int) - (if (f> (f- value result) _f1/2) ; round up if remainder > 0.5 - (setq int (1+ (fint result))) - (setq int (fint result))) - (setq str (int-to-string int)) - (if (>= int 1000000) - (setq power (1+ power)))) - - (if sci ; scientific notation - (setq str (concat (substring str 0 1) "." (substring str 1) - "E" (int-to-string power))) - - ; regular decimal string - (cond ((>= power (1- decimal-digits)) - ; large power, append zeroes - (let ((zeroes (- power decimal-digits))) - (while (natnump zeroes) - (setq str (concat str "0") - zeroes (1- zeroes))))) - - ; negative power, prepend decimal - ((< power 0) ; point and zeroes - (let ((zeroes (- (- power) 2))) - (while (natnump zeroes) - (setq str (concat "0" str) - zeroes (1- zeroes))) - (setq str (concat "0." str)))) - - (t ; in range, insert decimal point - (setq str (concat - (substring str 0 (1+ power)) - "." - (substring str (1+ power))))))) - - (if sign ; if negative, prepend minus sign - (concat "-" str) - str)))) - - -;; string to float conversion. -;; accepts scientific notation, but ignores anything after the first two -;; digits of the exponent. -(defun string-to-float (str) - "Convert the string to a floating point number. -Accepts a decimal string in scientific notation, with exponent preceded -by either E or e. Only the six most significant digits of the integer -and fractional parts are used; only the first two digits of the exponent -are used. Negative signs preceding both the decimal number and the exponent -are recognized." - - (if (string-match floating-point-regexp str 0) - (let (power) - (f* - ; calculate the mantissa - (let* ((int-subst (extract-match str 2)) - (fract-subst (extract-match str 4)) - (digit-string (concat int-subst fract-subst)) - (mant-sign (equal (extract-match str 1) "-")) - (leading-0s 0) (round-up nil)) - - ; get rid of leading 0's - (setq power (- (length int-subst) decimal-digits)) - (while (and (< leading-0s (length digit-string)) - (= (aref digit-string leading-0s) ?0)) - (setq leading-0s (1+ leading-0s))) - (setq power (- power leading-0s) - digit-string (substring digit-string leading-0s)) - - ; if more than 6 digits, round off - (if (> (length digit-string) decimal-digits) - (setq round-up (>= (aref digit-string decimal-digits) ?5) - digit-string (substring digit-string 0 decimal-digits)) - (setq power (+ power (- decimal-digits (length digit-string))))) - - ; round up and add minus sign, if necessary - (f (* (+ (string-to-int digit-string) - (if round-up 1 0)) - (if mant-sign -1 1)))) - - ; calculate the exponent (power of ten) - (let* ((expt-subst (extract-match str 9)) - (expt-sign (equal (extract-match str 8) "-")) - (expt 0) (chunks 0) (tens 0) (exponent _f1) - (func 'f*)) - - (setq expt (+ (* (string-to-int - (substring expt-subst 0 - (min expt-digits (length expt-subst)))) - (if expt-sign -1 1)) - power)) - (if (< expt 0) ; if power of 10 negative - (setq expt (- expt) ; take abs val of exponent - func 'f/)) ; and set up to divide, not multiply - - (setq chunks (/ expt decimal-digits) - tens (% expt decimal-digits)) - ; divide or multiply by "chunks" of 10**6 - (while (> chunks 0) - (setq exponent (funcall func exponent highest-power-of-10) - chunks (1- chunks))) - ; divide or multiply by remaining power of ten - (funcall func exponent (aref powers-of-10 tens))))) - - _f0)) ; if invalid, return 0 - -(provide 'float) - -;;; float.el ends here diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el deleted file mode 100644 index 0020f720b60..00000000000 --- a/lisp/emacs-lisp/gulp.el +++ /dev/null @@ -1,152 +0,0 @@ -;;; gulp.el --- Ask for updates for Lisp packages - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: Sam Shteingold <shteingd@math.ucla.edu> -;; Maintainer: FSF -;; Keywords: maintenance - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Search the emacs/{version}/lisp directory for *.el files, extract the -;; name of the author or maintainer and send him e-mail requesting -;; update. - -;;; Code: - -(defvar gulp-discard "^;+ *Maintainer: *FSF *$" - "*The regexp matching the packages not requiring the request for updates.") - -(defvar gulp-tmp-buffer "*gulp*" "The name of the temporary buffer.") - -(defvar gulp-max-len 2000 - "*Distance into a Lisp source file to scan for keywords.") - -(defvar gulp-request-header - (concat - "This message was created automatically. -A new version of GNU Emacs, " - (format "%d.%d" emacs-major-version (+ emacs-minor-version 1)) - ", is entering the pretest state, -and it is high time to submit the updates to the various emacs packages. -You're listed as the maintainer of the following package(s):\n\n") - "*The starting text of a gulp message.") - -(defvar gulp-request-end - (concat - "\nIf you have any changes since the version in the previous release (" - (format "%d.%d" emacs-major-version emacs-minor-version) - "), -please send them to me ASAP. - -Thanks.") - "*The closing text in a gulp message.") - -(defun gulp-send-requests (dir &optional time) - "Send requests for updates to the authors of Lisp packages in directory DIR. -For each maintainer, the message consists of `gulp-request-header', -followed by the list of packages (with modification times if the optional -prefix argument TIME is non-nil), concluded with `gulp-request-end'. - -You can't edit the messages, but you can confirm whether to send each one. - -The list of addresses for which you decided not to send mail -is left in the `*gulp*' buffer at the end." - (interactive "DRequest updates for Lisp directory: \nP") - (save-excursion - (set-buffer (get-buffer-create gulp-tmp-buffer)) - (let ((m-p-alist (gulp-create-m-p-alist - (directory-files dir nil "^[^=].*\\.el$" t) - dir)) - ;; Temporarily inhibit undo in the *gulp* buffer. - (buffer-undo-list t) - mail-setup-hook msg node) - (while (setq node (car m-p-alist)) - (setq msg (gulp-create-message (cdr node) time)) - (setq mail-setup-hook - '(lambda () - (mail-subject) - (insert "It's time for Emacs updates again") - (goto-char (point-max)) - (insert msg))) - (mail nil (car node)) - (if (y-or-n-p "Send? ") (mail-send) - (kill-this-buffer) - (set-buffer gulp-tmp-buffer) - (insert (format "%s\n\n" node))) - (setq m-p-alist (cdr m-p-alist)))) - (set-buffer gulp-tmp-buffer) - (setq buffer-undo-list nil))) - - -(defun gulp-create-message (rec time) - "Return the message string for REC, which is a list like (FILE TIME)." - (let (node (str gulp-request-header)) - (while (setq node (car rec)) - (setq str (concat str "\t" (car node) - (if time (concat "\tLast modified:\t" (cdr node))) - "\n")) - (setq rec (cdr rec))) - (concat str gulp-request-end))) - - -(defun gulp-create-m-p-alist (flist dir) - "Create the maintainer/package alist for files in FLIST in DIR. -That is a list of elements, each of the form (MAINTAINER PACKAGES...)." - (save-excursion - (let (mplist filen node mnt-tm mnt tm) - (get-buffer-create gulp-tmp-buffer) - (set-buffer gulp-tmp-buffer) - (setq buffer-undo-list t) - (while flist - (setq fl-tm (gulp-maintainer (setq filen (car flist)) dir)) - (if (setq tm (cdr fl-tm) mnt (car fl-tm));; there is a definite maintainer - (if (setq node (assoc mnt mplist));; this is not a new maintainer - (setq mplist (cons (cons mnt (cons (cons filen tm) (cdr node))) - (delete node mplist))) - (setq mplist (cons (list mnt (cons filen (cdr fl-tm))) mplist)))) - (message "%s -- %s" filen fl-tm) - (setq flist (cdr flist))) - (erase-buffer) - mplist))) - -(defun gulp-maintainer (filenm dir) - "Return a list (MAINTAINER TIMESTAMP) for the package FILENM in directory DIR." - (save-excursion - (let* ((fl (concat dir filenm)) mnt - (timest (format-time-string "%Y-%m-%d %a %T %Z" - (elt (file-attributes fl) 5)))) - (set-buffer gulp-tmp-buffer) - (erase-buffer) - (insert-file-contents fl nil 0 gulp-max-len) - (goto-char 1) - (if (re-search-forward gulp-discard nil t) - (setq mnt nil) ;; do nothing, return nil - (goto-char 1) - (if (and (re-search-forward "^;+ *Maintainer: \\(.*\\)$" nil t) - (> (length (setq mnt (match-string 1))) 0)) - () ;; found! - (goto-char 1) - (if (re-search-forward "^;+ *Author: \\(.*\\)$" nil t) - (setq mnt (match-string 1)))) - (if (= (length mnt) 0) (setq mnt nil))) ;; "^;; Author: $" --> nil - (cons mnt timest)))) - -;;; gulp.el ends here diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el deleted file mode 100644 index b1f3cfdbd65..00000000000 --- a/lisp/emacs-lisp/helper.el +++ /dev/null @@ -1,157 +0,0 @@ -;;; helper.el --- utility help package supporting help in electric modes - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: help - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;; hey, here's a helping hand. - -;; Bind this to a string for <blank> in "... Other keys <blank>". -;; Helper-help uses this to construct help string when scrolling. -;; Defaults to "return" -(defvar Helper-return-blurb nil) - -;; Keymap implementation doesn't work too well for non-standard loops. -;; But define it anyway for those who can use it. Non-standard loops -;; will probably have to use Helper-help. You can't autoload the -;; keymap either. - - -(defvar Helper-help-map nil) -(if Helper-help-map - nil - (setq Helper-help-map (make-keymap)) - ;(fillarray Helper-help-map 'undefined) - (define-key Helper-help-map "m" 'Helper-describe-mode) - (define-key Helper-help-map "b" 'Helper-describe-bindings) - (define-key Helper-help-map "c" 'Helper-describe-key-briefly) - (define-key Helper-help-map "k" 'Helper-describe-key) - ;(define-key Helper-help-map "f" 'Helper-describe-function) - ;(define-key Helper-help-map "v" 'Helper-describe-variable) - (define-key Helper-help-map "?" 'Helper-help-options) - (define-key Helper-help-map (char-to-string help-char) 'Helper-help-options) - (fset 'Helper-help-map Helper-help-map)) - -(defun Helper-help-scroller () - (let ((blurb (or (and (boundp 'Helper-return-blurb) - Helper-return-blurb) - "return"))) - (save-window-excursion - (goto-char (window-start (selected-window))) - (if (get-buffer-window "*Help*") - (pop-to-buffer "*Help*") - (switch-to-buffer "*Help*")) - (goto-char (point-min)) - (let ((continue t) state) - (while continue - (setq state (+ (* 2 (if (pos-visible-in-window-p (point-max)) 1 0)) - (if (pos-visible-in-window-p (point-min)) 1 0))) - (message - (nth state - '("Space forward, Delete back. Other keys %s" - "Space scrolls forward. Other keys %s" - "Delete scrolls back. Other keys %s" - "Type anything to %s")) - blurb) - (setq continue (read-char)) - (cond ((and (memq continue '(?\ ?\C-v)) (< state 2)) - (scroll-up)) - ((= continue ?\C-l) - (recenter)) - ((and (= continue ?\177) (zerop (% state 2))) - (scroll-down)) - (t (setq continue nil)))))))) - -(defun Helper-help-options () - "Describe help options." - (interactive) - (message "c (key briefly), m (mode), k (key), b (bindings)") - ;(message "c (key briefly), m (mode), k (key), v (variable), f (function)") - (sit-for 4)) - -(defun Helper-describe-key-briefly (key) - "Briefly describe binding of KEY." - (interactive "kDescribe key briefly: ") - (describe-key-briefly key) - (sit-for 4)) - -(defun Helper-describe-key (key) - "Describe binding of KEY." - (interactive "kDescribe key: ") - (save-window-excursion (describe-key key)) - (Helper-help-scroller)) - -(defun Helper-describe-function () - "Describe a function. Name read interactively." - (interactive) - (save-window-excursion (call-interactively 'describe-function)) - (Helper-help-scroller)) - -(defun Helper-describe-variable () - "Describe a variable. Name read interactively." - (interactive) - (save-window-excursion (call-interactively 'describe-variable)) - (Helper-help-scroller)) - -(defun Helper-describe-mode () - "Describe the current mode." - (interactive) - (let ((name mode-name) - (documentation (documentation major-mode))) - (save-excursion - (set-buffer (get-buffer-create "*Help*")) - (erase-buffer) - (insert name " Mode\n" documentation) - (help-mode))) - (Helper-help-scroller)) - -;;;###autoload -(defun Helper-describe-bindings () - "Describe local key bindings of current mode." - (interactive) - (message "Making binding list...") - (save-window-excursion (describe-bindings)) - (Helper-help-scroller)) - -;;;###autoload -(defun Helper-help () - "Provide help for current mode." - (interactive) - (let ((continue t) c) - (while continue - (message "Help (Type ? for further options)") - (setq c (read-key-sequence nil)) - (setq c (lookup-key Helper-help-map c)) - (cond ((eq c 'Helper-help-options) - (Helper-help-options)) - ((commandp c) - (call-interactively c) - (setq continue nil)) - (t - (ding) - (setq continue nil)))))) - -(provide 'helper) - -;;; helper.el ends here diff --git a/lisp/emacs-lisp/levents.el b/lisp/emacs-lisp/levents.el deleted file mode 100644 index bc5c06c9cbc..00000000000 --- a/lisp/emacs-lisp/levents.el +++ /dev/null @@ -1,233 +0,0 @@ -;;; levents.el --- emulate the Lucid event data type and associated functions. - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Things we cannot emulate in Lisp: -;; It is not possible to emulate current-mouse-event as a variable, -;; though it is not hard to obtain the data from (this-command-keys). - -;; We do not have a variable unread-command-event; -;; instead, we have the more general unread-command-events. - -;; Our read-key-sequence and read-char are not precisely -;; compatible with those in Lucid Emacs, but they should work ok. - -;;; Code: - -(defun next-command-event (event) - (error "You must rewrite to use `read-command-event' instead of `next-command-event'")) - -(defun next-event (event) - (error "You must rewrite to use `read-event' instead of `next-event'")) - -(defun dispatch-event (event) - (error "`dispatch-event' not supported")) - -;; Make events of type eval, menu and timeout -;; execute properly. - -(define-key global-map [menu] 'execute-eval-event) -(define-key global-map [timeout] 'execute-eval-event) -(define-key global-map [eval] 'execute-eval-event) - -(defun execute-eval-event (event) - (interactive "e") - (funcall (nth 1 event) (nth 2 event))) - -(put 'eval 'event-symbol-elements '(eval)) -(put 'menu 'event-symbol-elements '(eval)) -(put 'timeout 'event-symbol-elements '(eval)) - -(defun allocate-event () - "Returns an empty event structure. -In this emulation, it returns nil." - nil) - -(defun button-press-event-p (obj) - "True if the argument is a mouse-button-press event object." - (and (consp obj) (symbolp (car obj)) - (memq 'down (get (car obj) 'event-symbol-elements)))) - -(defun button-release-event-p (obj) - "True if the argument is a mouse-button-release event object." - (and (consp obj) (symbolp (car obj)) - (or (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun character-to-event (ch &optional event) - "Converts a numeric ASCII value to an event structure, replete with -bucky bits. The character is the first argument, and the event to fill -in is the second. This function contains knowledge about what the codes -mean -- for example, the number 9 is converted to the character Tab, -not the distinct character Control-I. - -Beware that character-to-event and event-to-character are not strictly -inverse functions, since events contain much more information than the -ASCII character set can encode." - ch) - -(defun copy-event (event1 &optional event2) - "Make a copy of the given event object. -In this emulation, `copy-event' just returns its argument." - event1) - -(defun deallocate-event (event) - "Allow the given event structure to be reused. -In actual Lucid Emacs, you MUST NOT use this event object after -calling this function with it. You will lose. It is not necessary to -call this function, as event objects are garbage- collected like all -other objects; however, it may be more efficient to explicitly -deallocate events when you are sure that that is safe. - -This emulation does not actually deallocate or reuse events -except via garbage collection and `cons'." - nil) - -(defun enqueue-eval-event: (function object) - "Add an eval event to the back of the queue. -It will be the next event read after all pending events." - (setq unread-command-events - (nconc unread-command-events - (list (list 'eval function object))))) - -(defun eval-event-p (obj) - "True if the argument is an eval or menu event object." - (eq (car-safe obj) 'eval)) - -(defun event-button (event) - "Return the button-number of the given mouse-button-press event." - (let ((sym (car (get (car event) 'event-symbol-elements)))) - (cdr (assq sym '((mouse-1 . 1) (mouse-2 . 2) (mouse-3 . 3) - (mouse-4 . 4) (mouse-5 . 5)))))) - -(defun event-function (event) - "Return the callback function of the given timeout, menu, or eval event." - (nth 1 event)) - -(defun event-key (event) - "Returns the KeySym of the given key-press event. -The value is an ASCII printing character (not upper case) or a symbol." - (if (symbolp event) - (car (get event 'event-symbol-elements)) - (let ((base (logand event (1- (lsh 1 18))))) - (downcase (if (< base 32) (logior base 64) base))))) - -(defun event-object (event) - "Returns the function argument of the given timeout, menu, or eval event." - (nth 2 event)) - -(defun event-point (event) - "Returns the character position of the given mouse-related event. -If the event did not occur over a window, or did -not occur over text, then this returns nil. Otherwise, it returns an index -into the buffer visible in the event's window." - (posn-point (event-end event))) - -(defun event-process (event) - "Returns the process of the given process-output event." - (nth 1 event)) - -(defun event-timestamp (event) - "Returns the timestamp of the given event object. -In Lucid Emacs, this works for any kind of event. -In this emulation, it returns nil for non-mouse-related events." - (and (listp event) - (posn-timestamp (event-end event)))) - -(defun event-to-character (event &optional lenient) - "Returns the closest ASCII approximation to the given event object. -If the event isn't a keypress, this returns nil. -If the second argument is non-nil, then this is lenient in its -translation; it will ignore modifier keys other than control and meta, -and will ignore the shift modifier on those characters which have no -shifted ASCII equivalent (Control-Shift-A for example, will be mapped to -the same ASCII code as Control-A.) If the second arg is nil, then nil -will be returned for events which have no direct ASCII equivalent." - (if (symbolp event) - (and lenient - (cdr (assq event '((backspace . 8) (delete . 127) (tab . 9) - (return . 10) (enter . 10))))) - ;; Our interpretation is, ASCII means anything a number can represent. - (if (integerp event) - event nil))) - -(defun event-window (event) - "Returns the window of the given mouse-related event object." - (posn-window (event-end event))) - -(defun event-x (event) - "Returns the X position in characters of the given mouse-related event." - (/ (car (posn-col-row (event-end event))) - (frame-char-width (window-frame (event-window event))))) - -(defun event-x-pixel (event) - "Returns the X position in pixels of the given mouse-related event." - (car (posn-col-row (event-end event)))) - -(defun event-y (event) - "Returns the Y position in characters of the given mouse-related event." - (/ (cdr (posn-col-row (event-end event))) - (frame-char-height (window-frame (event-window event))))) - -(defun event-y-pixel (event) - "Returns the Y position in pixels of the given mouse-related event." - (cdr (posn-col-row (event-end event)))) - -(defun key-press-event-p (obj) - "True if the argument is a keyboard event object." - (or (integerp obj) - (and (symbolp obj) - (get obj 'event-symbol-elements)))) - -(defun menu-event-p (obj) - "True if the argument is a menu event object." - (eq (car-safe obj) 'menu)) - -(defun motion-event-p (obj) - "True if the argument is a mouse-motion event object." - (eq (car-safe obj) 'mouse-movement)) - -(defun read-command-event () - "Return the next keyboard or mouse event; execute other events. -This is similar to the function `next-command-event' of Lucid Emacs, -but different in that it returns the event rather than filling in -an existing event object." - (let (event) - (while (progn - (setq event (read-event)) - (not (or (key-press-event-p event) - (button-press-event-p event) - (button-release-event-p event) - (menu-event-p event)))) - (let ((type (car-safe event))) - (cond ((eq type 'eval) - (funcall (nth 1 event) (nth 2 event))) - ((eq type 'switch-frame) - (select-frame (nth 1 event)))))) - event)) - -(defun process-event-p (obj) - "True if the argument is a process-output event object. -GNU Emacs 19 does not currently generate process-output events." - (eq (car-safe obj) 'process)) - -;;; levents.el ends here diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el deleted file mode 100644 index 8a6af05993f..00000000000 --- a/lisp/emacs-lisp/lisp-mnt.el +++ /dev/null @@ -1,554 +0,0 @@ -;;; lisp-mnt.el --- minor mode for Emacs Lisp maintainers - -;; Copyright (C) 1992, 1994 Free Software Foundation, Inc. - -;; Author: Eric S. Raymond <esr@snark.thyrsus.com> -;; Maintainer: Eric S. Raymond <esr@snark.thyrsus.com> -;; Created: 14 Jul 1992 -;; Version: $Id: lisp-mnt.el,v 1.16 1996/02/06 21:35:20 erik Exp rms $ -;; Keywords: docs -;; X-Bogus-Bureaucratic-Cruft: Gruad will get you if you don't watch out! - -;; 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 2, 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; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This minor mode adds some services to Emacs-Lisp editing mode. -;; -;; First, it knows about the header conventions for library packages. -;; One entry point supports generating synopses from a library directory. -;; Another can be used to check for missing headers in library files. -;; -;; Another entry point automatically addresses bug mail to a package's -;; maintainer or author. - -;; This file can be loaded by your lisp-mode-hook. Have it (require 'lisp-mnt) - -;; This file is an example of the header conventions. Note the following -;; features: -;; -;; * Header line --- makes it possible to extract a one-line summary of -;; the package's uses automatically for use in library synopses, KWIC -;; indexes and the like. -;; -;; Format is three semicolons, followed by the filename, followed by -;; three dashes, followed by the summary. All fields space-separated. -;; -;; * Author line --- contains the name and net address of at least -;; the principal author. -;; -;; If there are multiple authors, they should be listed on continuation -;; lines led by ;;<TAB>, like this: -;; -;; ;; Author: Ashwin Ram <Ram-Ashwin@cs.yale.edu> -;; ;; Dave Sill <de5@ornl.gov> -;; ;; David Lawrence <tale@pawl.rpi.edu> -;; ;; Noah Friedman <friedman@ai.mit.edu> -;; ;; Joe Wells <jbw@maverick.uswest.com> -;; ;; Dave Brennan <brennan@hal.com> -;; ;; Eric Raymond <esr@snark.thyrsus.com> -;; -;; This field may have some special values; notably "FSF", meaning -;; "Free Software Foundation". -;; -;; * Maintainer line --- should be a single name/address as in the Author -;; line, or an address only, or the string "FSF". If there is no maintainer -;; line, the person(s) in the Author field are presumed to be it. The example -;; in this file is mildly bogus because the maintainer line is redundant. -;; The idea behind these two fields is to be able to write a Lisp function -;; that does "send mail to the author" without having to mine the name out by -;; hand. Please be careful about surrounding the network address with <> if -;; there's also a name in the field. -;; -;; * Created line --- optional, gives the original creation date of the -;; file. For historical interest, basically. -;; -;; * Version line --- intended to give the reader a clue if they're looking -;; at a different version of the file than the one they're accustomed to. This -;; may be an RCS or SCCS header. -;; -;; * Adapted-By line --- this is for FSF's internal use. The person named -;; in this field was the one responsible for installing and adapting the -;; package for the distribution. (This file doesn't have one because the -;; author *is* one of the maintainers.) -;; -;; * Keywords line --- used by the finder code (now under construction) -;; for finding Emacs Lisp code related to a topic. -;; -;; * X-Bogus-Bureaucratic-Cruft line --- this is a joke and an example -;; of a comment header. Headers starting with `X-' should never be used -;; for any real purpose; this is the way to safely add random headers -;; without invoking the wrath of any program. -;; -;; * Commentary line --- enables Lisp code to find the developer's and -;; maintainers' explanations of the package internals. -;; -;; * Change log line --- optional, exists to terminate the commentary -;; section and start a change-log part, if one exists. -;; -;; * Code line --- exists so Lisp can know where commentary and/or -;; change-log sections end. -;; -;; * Footer line --- marks end-of-file so it can be distinguished from -;; an expanded formfeed or the results of truncation. - -;;; Change Log: - -;; Tue Jul 14 23:44:17 1992 ESR -;; * Created. - -;;; Code: - -(require 'picture) ; provides move-to-column-force -(require 'emacsbug) - -;;; Variables: - -(defvar lm-header-prefix "^;;*[ \t]+\\(@\(#\)\\)?[ \t]*\\([\$]\\)?" - "Prefix that is ignored before the tag. -For example, you can write the 1st line synopsis string and headers like this -in your Lisp package: - - ;; @(#) package.el -- pacakge description - ;; - ;; @(#) $Maintainer: Person Foo Bar $ - -The @(#) construct is used by unix what(1) and -then $identifier: doc string $ is used by GNU ident(1)") - -(defvar lm-comment-column 16 - "Column used for placing formatted output.") - -(defvar lm-commentary-header "Commentary\\|Documentation" - "Regexp which matches start of documentation section.") - -(defvar lm-history-header "Change Log\\|History" - "Regexp which matches the start of code log section.") - -;;; Functions: - -;; These functions all parse the headers of the current buffer - -(defsubst lm-get-header-re (header &optional mode) - "Returns regexp for matching HEADER. -If called with optional MODE and with value `section', -return section regexp instead." - (cond ((eq mode 'section) - (concat "^;;;;* " header ":[ \t]*$")) - (t - (concat lm-header-prefix header ":[ \t]*")))) - -(defsubst lm-get-package-name () - "Returns package name by looking at the first line." - (save-excursion - (goto-char (point-min)) - (if (and (looking-at (concat lm-header-prefix)) - (progn (goto-char (match-end 0)) - (looking-at "\\([^\t ]+\\)") - (match-end 1))) - (buffer-substring (match-beginning 1) (match-end 1)) - ))) - -(defun lm-section-mark (header &optional after) - "Return the buffer location of a given section start marker. -The HEADER is the section mark string to search for. -If AFTER is non-nil, return the location of the next line." - (save-excursion - (let ((case-fold-search t)) - (goto-char (point-min)) - (if (re-search-forward (lm-get-header-re header 'section) nil t) - (progn - (beginning-of-line) - (if after (forward-line 1)) - (point)) - nil)))) - -(defsubst lm-code-mark () - "Return the buffer location of the `Code' start marker." - (lm-section-mark "Code")) - -(defsubst lm-commentary-mark () - "Return the buffer location of the `Commentary' start marker." - (lm-section-mark lm-commentary-header)) - -(defsubst lm-history-mark () - "Return the buffer location of the `History' start marker." - (lm-section-mark lm-history-header)) - -(defun lm-header (header) - "Return the contents of the header named HEADER." - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t) - ;; RCS ident likes format "$identifier: data$" - (looking-at "\\([^$\n]+\\)") - (match-end 1)) - (buffer-substring (match-beginning 1) (match-end 1)) - nil))) - -(defun lm-header-multiline (header) - "Return the contents of the header named HEADER, with continuation lines. -The returned value is a list of strings, one per line." - (save-excursion - (goto-char (point-min)) - (let ((res (lm-header header))) - (cond - (res - (setq res (list res)) - (forward-line 1) - - (while (and (looking-at (concat lm-header-prefix "[\t ]+")) - (progn - (goto-char (match-end 0)) - (looking-at "\\(.*\\)")) - (match-end 1)) - (setq res (cons (buffer-substring - (match-beginning 1) - (match-end 1)) - res)) - (forward-line 1)) - )) - res - ))) - -;; These give us smart access to the header fields and commentary - -(defun lm-summary (&optional file) - "Return the one-line summary of file FILE, or current buffer if FILE is nil." - (save-excursion - (if file - (find-file file)) - (goto-char (point-min)) - (prog1 - (if (and - (looking-at lm-header-prefix) - (progn (goto-char (match-end 0)) - (looking-at "[^ ]+[ \t]+--+[ \t]+\\(.*\\)"))) - (buffer-substring (match-beginning 1) (match-end 1))) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-crack-address (x) - "Split up an email address into full name and real email address. -The value is a cons of the form (FULLNAME . ADDRESS)." - (cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x) - (cons (substring x (match-beginning 1) (match-end 1)) - (substring x (match-beginning 2) (match-end 2)))) - ((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x) - (cons (substring x (match-beginning 2) (match-end 2)) - (substring x (match-beginning 1) (match-end 1)))) - ((string-match "\\S-+@\\S-+" x) - (cons nil x)) - (t - (cons x nil)))) - -(defun lm-authors (&optional file) - "Return the author list of file FILE, or current buffer if FILE is nil. -Each element of the list is a cons; the car is the full name, -the cdr is an email address." - (save-excursion - (if file - (find-file file)) - (let ((authorlist (lm-header-multiline "author"))) - (prog1 - (mapcar 'lm-crack-address authorlist) - (if file - (kill-buffer (current-buffer))) - )))) - -(defun lm-maintainer (&optional file) - "Return the maintainer of file FILE, or current buffer if FILE is nil. -The return value has the form (NAME . ADDRESS)." - (save-excursion - (if file - (find-file file)) - (prog1 - (let ((maint (lm-header "maintainer"))) - (if maint - (lm-crack-address maint) - (car (lm-authors)))) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-creation-date (&optional file) - "Return the created date given in file FILE, or current buffer if FILE is nil." - (save-excursion - (if file - (find-file file)) - (prog1 - (lm-header "created") - (if file - (kill-buffer (current-buffer))) - ))) - - -(defun lm-last-modified-date (&optional file) - "Return the modify-date given in file FILE, or current buffer if FILE is nil." - (save-excursion - (if file - (find-file file)) - (prog1 - (if (progn - (goto-char (point-min)) - (re-search-forward - "\\$Id: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) " - (lm-code-mark) t)) - (format "%s %s %s" - (buffer-substring (match-beginning 3) (match-end 3)) - (nth (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))) - '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) - (buffer-substring (match-beginning 1) (match-end 1)) - )) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-version (&optional file) - "Return the version listed in file FILE, or current buffer if FILE is nil. -This can befound in an RCS or SCCS header to crack it out of." - (save-excursion - (if file - (find-file file)) - (prog1 - (or - (lm-header "version") - (let ((header-max (lm-code-mark))) - (goto-char (point-min)) - (cond - ;; Look for an RCS header - ((re-search-forward "\\$Id: [^ ]+ \\([^ ]+\\) " header-max t) - (buffer-substring (match-beginning 1) (match-end 1))) - - ;; Look for an SCCS header - ((re-search-forward - (concat - (regexp-quote "@(#)") - (regexp-quote (file-name-nondirectory (buffer-file-name))) - "\t\\([012345679.]*\\)") - header-max t) - (buffer-substring (match-beginning 1) (match-end 1))) - - (t nil)))) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-keywords (&optional file) - "Return the keywords given in file FILE, or current buffer if FILE is nil." - (save-excursion - (if file - (find-file file)) - (prog1 - (let ((keywords (lm-header "keywords"))) - (and keywords (downcase keywords))) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-adapted-by (&optional file) - "Return the adapted-by names in file FILE, or current buffer if FILE is nil. -This is the name of the person who cleaned up this package for -distribution." - (save-excursion - (if file - (find-file file)) - (prog1 - (lm-header "adapted-by") - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-commentary (&optional file) - "Return the commentary in file FILE, or current buffer if FILE is nil. -The value is returned as a string. In the text, the commentary starts -with tag `Commentary' and ends with tag `Change Log' or `History'." - (save-excursion - (if file - (find-file file)) - (prog1 - (let ((commentary (lm-commentary-mark)) - (change-log (lm-history-mark)) - (code (lm-code-mark)) - ) - (cond - ((and commentary change-log) - (buffer-substring commentary change-log)) - ((and commentary code) - (buffer-substring commentary code)) - (t - nil))) - (if file - (kill-buffer (current-buffer))) - ))) - -;;; Verification and synopses - -(defun lm-insert-at-column (col &rest strings) - "Insert list of STRINGS, at column COL." - (if (> (current-column) col) (insert "\n")) - (move-to-column-force col) - (apply 'insert strings)) - -(defun lm-verify (&optional file showok &optional verb) - "Check that the current buffer (or FILE if given) is in proper format. -If FILE is a directory, recurse on its files and generate a report in -a temporary buffer." - (interactive) - (let* ((verb (or verb (interactive-p))) - ret - name - ) - (if verb - (setq ret "Ok.")) ;init value - - (if (and file (file-directory-p file)) - (setq - ret - (progn - (switch-to-buffer (get-buffer-create "*lm-verify*")) - (erase-buffer) - (mapcar - '(lambda (f) - (if (string-match ".*\\.el$" f) - (let ((status (lm-verify f))) - (if status - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column status "\n")) - (and showok - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column "OK\n"))))))) - (directory-files file)) - )) - (save-excursion - (if file - (find-file file)) - (setq name (lm-get-package-name)) - - (setq - ret - (prog1 - (cond - ((null name) - "Can't find a package NAME") - - ((not (lm-authors)) - "Author: tag missing.") - - ((not (lm-maintainer)) - "Maintainer: tag missing.") - - ((not (lm-summary)) - "Can't find a one-line 'Summary' description") - - ((not (lm-keywords)) - "Keywords: tag missing.") - - ((not (lm-commentary-mark)) - "Can't find a 'Commentary' section marker.") - - ((not (lm-history-mark)) - "Can't find a 'History' section marker.") - - ((not (lm-code-mark)) - "Can't find a 'Code' section marker") - - ((progn - (goto-char (point-max)) - (not - (re-search-backward - (concat "^;;;[ \t]+" name "[ \t]+ends here[ \t]*$" - "\\|^;;;[ \t]+ End of file[ \t]+" name) - nil t - ))) - (format "Can't find a footer line for [%s]" name)) - (t - ret)) - (if file - (kill-buffer (current-buffer))) - )))) - (if verb - (message ret)) - ret - )) - -(defun lm-synopsis (&optional file showall) - "Generate a synopsis listing for the buffer or the given FILE if given. -If FILE is a directory, recurse on its files and generate a report in -a temporary buffer. If SHOWALL is non-nil, also generate a line for files -which do not include a recognizable synopsis." - (interactive - (list - (read-file-name "Synopsis for (file or dir): "))) - - (if (and file (file-directory-p file)) - (progn - (switch-to-buffer (get-buffer-create "*lm-verify*")) - (erase-buffer) - (mapcar - '(lambda (f) - (if (string-match ".*\\.el$" f) - (let ((syn (lm-synopsis f))) - (if syn - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column syn "\n")) - (and showall - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column "NA\n"))))))) - (directory-files file)) - ) - (save-excursion - (if file - (find-file file)) - (prog1 - (lm-summary) - (if file - (kill-buffer (current-buffer))) - )))) - -(defun lm-report-bug (topic) - "Report a bug in the package currently being visited to its maintainer. -Prompts for bug subject. Leaves you in a mail buffer." - (interactive "sBug Subject: ") - (let ((package (lm-get-package-name)) - (addr (lm-maintainer)) - (version (lm-version))) - (mail nil - (if addr - (concat (car addr) " <" (cdr addr) ">") - bug-gnu-emacs) - topic) - (goto-char (point-max)) - (insert "\nIn " - package - (if version (concat " version " version) "") - "\n\n") - (message - (substitute-command-keys "Type \\[mail-send] to send bug report.")))) - -(provide 'lisp-mnt) - -;;; lisp-mnt.el ends here - diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el deleted file mode 100644 index 26eab753c38..00000000000 --- a/lisp/emacs-lisp/lisp-mode.el +++ /dev/null @@ -1,838 +0,0 @@ -;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands. - -;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: lisp, languages - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The base major mode for editing Lisp code (used also for Emacs Lisp). -;; This mode is documented in the Emacs manual - -;;; Code: - -(defvar lisp-mode-syntax-table nil "") -(defvar emacs-lisp-mode-syntax-table nil "") -(defvar lisp-mode-abbrev-table nil "") - -(if (not emacs-lisp-mode-syntax-table) - (let ((i 0)) - (setq emacs-lisp-mode-syntax-table (make-syntax-table)) - (while (< i ?0) - (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) - (setq i (1+ i))) - (setq i (1+ ?9)) - (while (< i ?A) - (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) - (setq i (1+ i))) - (setq i (1+ ?Z)) - (while (< i ?a) - (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) - (setq i (1+ i))) - (setq i (1+ ?z)) - (while (< i 128) - (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) - (setq i (1+ i))) - (modify-syntax-entry ? " " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\t " " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\n "> " emacs-lisp-mode-syntax-table) - ;; Give CR the same syntax as newline, for selective-display. - (modify-syntax-entry ?\^m "> " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\; "< " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?` "' " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?' "' " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?, "' " emacs-lisp-mode-syntax-table) - ;; Used to be singlequote; changed for flonums. - (modify-syntax-entry ?. "_ " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?# "' " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\" "\" " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\\ "\\ " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\( "() " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\) ")( " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\[ "(] " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\] ")[ " emacs-lisp-mode-syntax-table))) - -(if (not lisp-mode-syntax-table) - (progn (setq lisp-mode-syntax-table - (copy-syntax-table emacs-lisp-mode-syntax-table)) - (modify-syntax-entry ?\| "\" " lisp-mode-syntax-table) - (modify-syntax-entry ?\[ "_ " lisp-mode-syntax-table) - (modify-syntax-entry ?\] "_ " lisp-mode-syntax-table))) - -(define-abbrev-table 'lisp-mode-abbrev-table ()) - -(defvar lisp-imenu-generic-expression - '( - (nil - "^\\s-*(def\\(un\\|subst\\|macro\\|advice\\)\\s-+\\([-A-Za-z0-9+]+\\)" 2) - ("Variables" - "^\\s-*(def\\(var\\|const\\)\\s-+\\([-A-Za-z0-9+]+\\)" 2) - ("Types" - "^\\s-*(def\\(type\\|struct\\|class\\|ine-condition\\)\\s-+\\([-A-Za-z0-9+]+\\)" - 2)) - - "Imenu generic expression for Lisp mode. See `imenu-generic-expression'.") - -(defun lisp-mode-variables (lisp-syntax) - (cond (lisp-syntax - (set-syntax-table lisp-mode-syntax-table))) - (setq local-abbrev-table lisp-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat page-delimiter "\\|$" )) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (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) - ;; 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. - (make-local-variable 'adaptive-fill-mode) - (setq adaptive-fill-mode nil) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'lisp-indent-line) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'lisp-indent-region) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'outline-regexp) - (setq outline-regexp ";;; \\|(....") - (make-local-variable 'comment-start) - (setq comment-start ";") - (make-local-variable 'comment-start-skip) - ;; 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 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'lisp-comment-indent) - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression lisp-imenu-generic-expression)) - -(defvar shared-lisp-mode-map () - "Keymap for commands shared by all sorts of Lisp modes.") - -(if shared-lisp-mode-map - () - (setq shared-lisp-mode-map (make-sparse-keymap)) - (define-key shared-lisp-mode-map "\e\C-q" 'indent-sexp) - (define-key shared-lisp-mode-map "\177" 'backward-delete-char-untabify)) - -(defvar emacs-lisp-mode-map () - "Keymap for Emacs Lisp mode. -All commands in `shared-lisp-mode-map' are inherited by this map.") - -(if emacs-lisp-mode-map - () - (let ((map (make-sparse-keymap "Emacs-Lisp"))) - (setq emacs-lisp-mode-map - (nconc (make-sparse-keymap) shared-lisp-mode-map)) - (define-key emacs-lisp-mode-map "\e\t" 'lisp-complete-symbol) - (define-key emacs-lisp-mode-map "\e\C-x" 'eval-defun) - (define-key emacs-lisp-mode-map [menu-bar] (make-sparse-keymap)) - (define-key emacs-lisp-mode-map [menu-bar emacs-lisp] - (cons "Emacs-Lisp" map)) - (define-key map [edebug-defun] - '("Instrument Function for Debugging" . edebug-defun)) - (define-key map [byte-recompile] - '("Byte-recompile Directory..." . byte-recompile-directory)) - (define-key map [emacs-byte-compile-and-load] - '("Byte-compile And Load" . emacs-lisp-byte-compile-and-load)) - (define-key map [byte-compile] - '("Byte-compile This File" . emacs-lisp-byte-compile)) - (define-key map [separator-eval] '("--")) - (define-key map [eval-buffer] '("Evaluate Buffer" . eval-current-buffer)) - (define-key map [eval-region] '("Evaluate Region" . eval-region)) - (define-key map [eval-sexp] '("Evaluate Last S-expression" . eval-last-sexp)) - (define-key map [separator-format] '("--")) - (define-key map [comment-region] '("Comment Out Region" . comment-region)) - (define-key map [indent-region] '("Indent Region" . indent-region)) - (define-key map [indent-line] '("Indent Line" . lisp-indent-line)) - (put 'eval-region 'menu-enable 'mark-active) - (put 'comment-region 'menu-enable 'mark-active) - (put 'indent-region 'menu-enable 'mark-active))) - -(defun emacs-lisp-byte-compile () - "Byte compile the file containing the current buffer." - (interactive) - (if buffer-file-name - (byte-compile-file buffer-file-name) - (error "The buffer must be saved in a file first"))) - -(defun emacs-lisp-byte-compile-and-load () - "Byte-compile the current file (if it has changed), then load compiled code." - (interactive) - (or buffer-file-name - (error "The buffer must be saved in a file first")) - (require 'bytecomp) - ;; Recompile if file or buffer has changed since last compilation. - (if (and (buffer-modified-p) - (y-or-n-p (format "save buffer %s first? " (buffer-name)))) - (save-buffer)) - (let ((compiled-file-name (byte-compile-dest-file buffer-file-name))) - (if (file-newer-than-file-p compiled-file-name buffer-file-name) - (load-file compiled-file-name) - (byte-compile-file buffer-file-name t)))) - -(defun emacs-lisp-mode () - "Major mode for editing Lisp code to run in Emacs. -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{emacs-lisp-mode-map} -Entry to this mode calls the value of `emacs-lisp-mode-hook' -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map emacs-lisp-mode-map) - (set-syntax-table emacs-lisp-mode-syntax-table) - (setq major-mode 'emacs-lisp-mode) - (setq mode-name "Emacs-Lisp") - (lisp-mode-variables nil) - (run-hooks 'emacs-lisp-mode-hook)) - -(defvar lisp-mode-map () - "Keymap for ordinary Lisp mode. -All commands in `shared-lisp-mode-map' are inherited by this map.") - -(if lisp-mode-map - () - (setq lisp-mode-map - (nconc (make-sparse-keymap) shared-lisp-mode-map)) - (define-key lisp-mode-map "\e\C-x" 'lisp-eval-defun) - (define-key lisp-mode-map "\C-c\C-z" 'run-lisp)) - -(defun lisp-mode () - "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{lisp-mode-map} -Note that `run-lisp' may be used either to start an inferior Lisp job -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." - (interactive) - (kill-all-local-variables) - (use-local-map lisp-mode-map) - (setq major-mode 'lisp-mode) - (setq mode-name "Lisp") - (lisp-mode-variables t) - (set-syntax-table lisp-mode-syntax-table) - (run-hooks 'lisp-mode-hook)) - -;; This will do unless shell.el is loaded. -(defun lisp-eval-defun nil - "Send the current defun to the Lisp process made by \\[run-lisp]." - (interactive) - (error "Process lisp does not exist")) - -(defvar lisp-interaction-mode-map () - "Keymap for Lisp Interaction moe. -All commands in `shared-lisp-mode-map' are inherited by this map.") - -(if lisp-interaction-mode-map - () - (setq lisp-interaction-mode-map - (nconc (make-sparse-keymap) shared-lisp-mode-map)) - (define-key lisp-interaction-mode-map "\e\C-x" 'eval-defun) - (define-key lisp-interaction-mode-map "\e\t" 'lisp-complete-symbol) - (define-key lisp-interaction-mode-map "\n" 'eval-print-last-sexp)) - -(defun lisp-interaction-mode () - "Major mode for typing and evaluating Lisp forms. -Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression -before point, and prints its value into the buffer, advancing point. - -Commands: -Delete converts tabs to spaces as it moves back. -Paragraphs are separated only by blank lines. -Semicolons start comments. -\\{lisp-interaction-mode-map} -Entry to this mode calls the value of `lisp-interaction-mode-hook' -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map lisp-interaction-mode-map) - (setq major-mode 'lisp-interaction-mode) - (setq mode-name "Lisp Interaction") - (set-syntax-table emacs-lisp-mode-syntax-table) - (lisp-mode-variables nil) - (run-hooks 'lisp-interaction-mode-hook)) - -(defun eval-print-last-sexp () - "Evaluate sexp before point; print value into current buffer." - (interactive) - (let ((standard-output (current-buffer))) - (terpri) - (eval-last-sexp t) - (terpri))) - -(defun eval-last-sexp (eval-last-sexp-arg-internal) - "Evaluate sexp before point; print value in minibuffer. -With argument, print output into current buffer." - (interactive "P") - (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)) - (opoint (point))) - (prin1 (let ((stab (syntax-table))) - (eval (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (forward-sexp -1) - (save-restriction - (narrow-to-region (point-min) opoint) - (read (current-buffer)))) - (set-syntax-table stab))))))) - -(defun eval-defun (eval-defun-arg-internal) - "Evaluate defun that point is in or before. -Print value in minibuffer. -With argument, insert value in current buffer after the defun." - (interactive "P") - (let ((standard-output (if eval-defun-arg-internal (current-buffer) t)) - (form (save-excursion - (end-of-defun) - (beginning-of-defun) - (read (current-buffer))))) - (if (and (eq (car form) 'defvar) - (cdr-safe (cdr-safe form))) - (setq form (cons 'defconst (cdr form)))) - (prin1 (eval form)))) - -(defun lisp-comment-indent () - (if (looking-at "\\s<\\s<\\s<") - (current-column) - (if (looking-at "\\s<\\s<") - (let ((tem (calculate-lisp-indent))) - (if (listp tem) (car tem) tem)) - (skip-chars-backward " \t") - (max (if (bolp) 0 (1+ (current-column))) - comment-column)))) - -(defvar lisp-indent-offset nil "") -(defvar lisp-indent-function 'lisp-indent-function "") - -(defun lisp-indent-line (&optional whole-exp) - "Indent current line as Lisp code. -With argument, indent any additional lines of the same expression -rigidly along with this one." - (interactive "P") - (let ((indent (calculate-lisp-indent)) shift-amt beg end - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\s<\\s<") - ;; Don't alter indentation of a ;;; comment line. - (goto-char (- (point-max) pos)) - (if (and (looking-at "\\s<") (not (looking-at "\\s<\\s<"))) - ;; Single-semicolon comment lines should be indented - ;; as comment lines, not as code. - (progn (indent-for-comment) (forward-char -1)) - (if (listp indent) (setq indent (car indent))) - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - nil - (delete-region beg (point)) - (indent-to indent))) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - ;; If desired, shift remaining lines of expression the same amount. - (and whole-exp (not (zerop shift-amt)) - (save-excursion - (goto-char beg) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point)) - (> end beg)) - (indent-code-rigidly beg end shift-amt))))) - -(defvar calculate-lisp-indent-last-sexp) - -(defun calculate-lisp-indent (&optional parse-start) - "Return appropriate indentation for current line as Lisp code. -In usual case returns an integer: the column to indent to. -Can instead return a list, whose car is the column to indent to. -This means that following lines at the same level of indentation -should not necessarily be indented the same way. -The second element of the list is the buffer position -of the start of the containing expression." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - state paren-depth - ;; setting this to a number inhibits calling hook - (desired-indent nil) - (retry t) - calculate-lisp-indent-last-sexp containing-sexp) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - ;; Find outermost containing sexp - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) - ;; Find innermost containing sexp - (while (and retry - state - (> (setq paren-depth (elt state 0)) 0)) - (setq retry nil) - (setq calculate-lisp-indent-last-sexp (elt state 2)) - (setq containing-sexp (elt state 1)) - ;; Position following last unclosed open. - (goto-char (1+ containing-sexp)) - ;; Is there a complete sexp since then? - (if (and calculate-lisp-indent-last-sexp - (> calculate-lisp-indent-last-sexp (point))) - ;; Yes, but is there a containing sexp after that? - (let ((peek (parse-partial-sexp calculate-lisp-indent-last-sexp - indent-point 0))) - (if (setq retry (car (cdr peek))) (setq state peek))))) - (if retry - nil - ;; Innermost containing sexp found - (goto-char (1+ containing-sexp)) - (if (not calculate-lisp-indent-last-sexp) - ;; indent-point immediately follows open paren. - ;; Don't call hook. - (setq desired-indent (current-column)) - ;; Find the start of first element of containing sexp. - (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) - (cond ((looking-at "\\s(") - ;; First element of containing sexp is a list. - ;; Indent under that list. - ) - ((> (save-excursion (forward-line 1) (point)) - calculate-lisp-indent-last-sexp) - ;; This is the first line to start within the containing sexp. - ;; It's almost certainly a function call. - (if (= (point) calculate-lisp-indent-last-sexp) - ;; Containing sexp has nothing before this line - ;; except the first element. Indent under that element. - nil - ;; Skip the first element, find start of second (the first - ;; argument of the function call) and indent under. - (progn (forward-sexp 1) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp - 0 t))) - (backward-prefix-chars)) - (t - ;; Indent beneath first sexp on same line as - ;; calculate-lisp-indent-last-sexp. Again, it's - ;; almost certainly a function call. - (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) calculate-lisp-indent-last-sexp - 0 t) - (backward-prefix-chars))))) - ;; Point is at the point to indent under unless we are inside a string. - ;; Call indentation hook except when overridden by lisp-indent-offset - ;; or if the desired indentation has already been computed. - (let ((normal-indent (current-column))) - (cond ((elt state 3) - ;; Inside a string, don't change indentation. - (goto-char indent-point) - (skip-chars-forward " \t") - (current-column)) - ((and (integerp lisp-indent-offset) containing-sexp) - ;; Indent by constant offset - (goto-char containing-sexp) - (+ (current-column) lisp-indent-offset)) - (desired-indent) - ((and (boundp 'lisp-indent-function) - lisp-indent-function - (not retry)) - (or (funcall lisp-indent-function indent-point state) - normal-indent)) - (t - normal-indent)))))) - -(defun lisp-indent-function (indent-point state) - (let ((normal-indent (current-column))) - (goto-char (1+ (elt state 1))) - (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) - (if (and (elt state 2) - (not (looking-at "\\sw\\|\\s_"))) - ;; car of form doesn't seem to be a a symbol - (progn - (if (not (> (save-excursion (forward-line 1) (point)) - calculate-lisp-indent-last-sexp)) - (progn (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp 0 t))) - ;; Indent under the list or under the first sexp on the same - ;; line as calculate-lisp-indent-last-sexp. Note that first - ;; thing on that line has to be complete sexp since we are - ;; inside the innermost containing sexp. - (backward-prefix-chars) - (current-column)) - (let ((function (buffer-substring (point) - (progn (forward-sexp 1) (point)))) - method) - (setq method (or (get (intern-soft function) 'lisp-indent-function) - (get (intern-soft function) 'lisp-indent-hook))) - (cond ((or (eq method 'defun) - (and (null method) - (> (length function) 3) - (string-match "\\`def" function))) - (lisp-indent-defform state indent-point)) - ((integerp method) - (lisp-indent-specform method state - indent-point normal-indent)) - (method - (funcall method state indent-point))))))) - -(defvar lisp-body-indent 2 - "Number of columns to indent the second line of a `(def...)' form.") - -(defun lisp-indent-specform (count state indent-point normal-indent) - (let ((containing-form-start (elt state 1)) - (i count) - body-indent containing-form-column) - ;; Move to the start of containing form, calculate indentation - ;; to use for non-distinguished forms (> count), and move past the - ;; function symbol. lisp-indent-function guarantees that there is at - ;; least one word or symbol character following open paren of containing - ;; form. - (goto-char containing-form-start) - (setq containing-form-column (current-column)) - (setq body-indent (+ lisp-body-indent containing-form-column)) - (forward-char 1) - (forward-sexp 1) - ;; Now find the start of the last form. - (parse-partial-sexp (point) indent-point 1 t) - (while (and (< (point) indent-point) - (condition-case () - (progn - (setq count (1- count)) - (forward-sexp 1) - (parse-partial-sexp (point) indent-point 1 t)) - (error nil)))) - ;; Point is sitting on first character of last (or count) sexp. - (if (> count 0) - ;; A distinguished form. If it is the first or second form use double - ;; lisp-body-indent, else normal indent. With lisp-body-indent bound - ;; to 2 (the default), this just happens to work the same with if as - ;; the older code, but it makes unwind-protect, condition-case, - ;; with-output-to-temp-buffer, et. al. much more tasteful. The older, - ;; less hacked, behavior can be obtained by replacing below with - ;; (list normal-indent containing-form-start). - (if (<= (- i count) 1) - (list (+ containing-form-column (* 2 lisp-body-indent)) - containing-form-start) - (list normal-indent containing-form-start)) - ;; A non-distinguished form. Use body-indent if there are no - ;; distinguished forms and this is the first undistinguished form, - ;; or if this is the first undistinguished form and the preceding - ;; distinguished form has indentation at least as great as body-indent. - (if (or (and (= i 0) (= count 0)) - (and (= count 0) (<= body-indent normal-indent))) - body-indent - normal-indent)))) - -(defun lisp-indent-defform (state indent-point) - (goto-char (car (cdr state))) - (forward-line 1) - (if (> (point) (car (cdr (cdr state)))) - (progn - (goto-char (car (cdr state))) - (+ lisp-body-indent (current-column))))) - - -;; (put 'progn 'lisp-indent-function 0), say, causes progn to be indented -;; like defun if the first form is placed on the next line, otherwise -;; it is indented like any other form (i.e. forms line up under first). - -(put 'lambda 'lisp-indent-function 'defun) -(put 'autoload 'lisp-indent-function 'defun) -(put 'progn 'lisp-indent-function 0) -(put 'prog1 'lisp-indent-function 1) -(put 'prog2 'lisp-indent-function 2) -(put 'save-excursion 'lisp-indent-function 0) -(put 'save-window-excursion 'lisp-indent-function 0) -(put 'save-selected-window 'lisp-indent-function 0) -(put 'save-restriction 'lisp-indent-function 0) -(put 'save-match-data 'lisp-indent-function 0) -(put 'save-current-buffer 'lisp-indent-function 0) -(put 'with-current-buffer 'lisp-indent-function 1) -(put 'combine-after-change-calls 'lisp-indent-function 0) -(put 'with-output-to-string 'lisp-indent-function 0) -(put 'with-temp-file 'lisp-indent-function 1) -(put 'with-temp-buffer 'lisp-indent-function 0) -(put 'let 'lisp-indent-function 1) -(put 'let* 'lisp-indent-function 1) -(put 'while 'lisp-indent-function 1) -(put 'if 'lisp-indent-function 2) -(put 'catch 'lisp-indent-function 1) -(put 'condition-case 'lisp-indent-function 2) -(put 'unwind-protect 'lisp-indent-function 1) -(put 'with-output-to-temp-buffer 'lisp-indent-function 1) -(put 'eval-after-load 'lisp-indent-function 1) - -(defun indent-sexp (&optional endpos) - "Indent each line of the list starting just after point. -If optional arg ENDPOS is given, indent each line, stopping when -ENDPOS is encountered." - (interactive) - (let ((indent-stack (list nil)) - (next-depth 0) - ;; If ENDPOS is non-nil, use nil as STARTING-POINT - ;; so that calculate-lisp-indent will find the beginning of - ;; the defun we are in. - ;; If ENDPOS is nil, it is safe not to scan before point - ;; since every line we indent is more deeply nested than point is. - (starting-point (if endpos nil (point))) - (last-point (point)) - last-depth bol outer-loop-done inner-loop-done state this-indent) - (or endpos - ;; Get error now if we don't have a complete sexp after point. - (save-excursion (forward-sexp 1))) - (save-excursion - (setq outer-loop-done nil) - (while (if endpos (< (point) endpos) - (not outer-loop-done)) - (setq last-depth next-depth - inner-loop-done nil) - ;; Parse this line so we can learn the state - ;; to indent the next line. - ;; This inner loop goes through only once - ;; unless a line ends inside a string. - (while (and (not inner-loop-done) - (not (setq outer-loop-done (eobp)))) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - ;; If the line contains a comment other than the sort - ;; that is indented like code, - ;; indent it now with indent-for-comment. - ;; Comments indented like code are right already. - ;; In any case clear the in-comment flag in the state - ;; because parse-partial-sexp never sees the newlines. - (if (car (nthcdr 4 state)) - (progn (indent-for-comment) - (end-of-line) - (setcar (nthcdr 4 state) nil))) - ;; If this line ends inside a string, - ;; go straight to next line, remaining within the inner loop, - ;; and turn off the \-flag. - (if (car (nthcdr 3 state)) - (progn - (forward-line 1) - (setcar (nthcdr 5 state) nil)) - (setq inner-loop-done t))) - (and endpos - (<= next-depth 0) - (progn - (setq indent-stack (append indent-stack - (make-list (- next-depth) nil)) - last-depth (- last-depth next-depth) - next-depth 0))) - (or outer-loop-done endpos - (setq outer-loop-done (<= next-depth 0))) - (if outer-loop-done - (forward-line 1) - (while (> last-depth next-depth) - (setq indent-stack (cdr indent-stack) - last-depth (1- last-depth))) - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - last-depth (1+ last-depth))) - ;; Now go to the next line and indent it according - ;; to what we learned from parsing the previous one. - (forward-line 1) - (setq bol (point)) - (skip-chars-forward " \t") - ;; But not if the line is blank, or just a comment - ;; (except for double-semi comments; indent them as usual). - (if (or (eobp) (looking-at "\\s<\\|\n")) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - (setq this-indent (car indent-stack)) - (let ((val (calculate-lisp-indent - (if (car indent-stack) (- (car indent-stack)) - starting-point)))) - (if (integerp val) - (setcar indent-stack - (setq this-indent val)) - (setcar indent-stack (- (car (cdr val)))) - (setq this-indent (car val))))) - (if (/= (current-column) this-indent) - (progn (delete-region bol (point)) - (indent-to this-indent))))) - (or outer-loop-done - (setq outer-loop-done (= (point) last-point)) - (setq last-point (point))))))) - -;; Indent every line whose first char is between START and END inclusive. -(defun lisp-indent-region (start end) - (save-excursion - (let ((endmark (copy-marker end))) - (goto-char start) - (and (bolp) (not (eolp)) - (lisp-indent-line)) - (indent-sexp endmark) - (set-marker endmark nil)))) - -;;;; Lisp paragraph filling commands. - -(defun lisp-fill-paragraph (&optional justify) - "Like \\[fill-paragraph], but handle Emacs Lisp comments. -If any of the current line is a comment, fill the comment or the -paragraph of it that point is in, preserving the comment's indentation -and initial semicolons." - (interactive "P") - (let ( - ;; Non-nil if the current line contains a comment. - has-comment - - ;; Non-nil if the current line contains code and a comment. - has-code-and-comment - - ;; If has-comment, the appropriate fill-prefix for the comment. - comment-fill-prefix - ) - - ;; Figure out what kind of comment we are looking at. - (save-excursion - (beginning-of-line) - (cond - - ;; A line with nothing but a comment on it? - ((looking-at "[ \t]*;[; \t]*") - (setq has-comment t - comment-fill-prefix (buffer-substring (match-beginning 0) - (match-end 0)))) - - ;; A line with some code, followed by a comment? Remember that the - ;; semi which starts the comment shouldn't be part of a string or - ;; character. - ((condition-case nil - (save-restriction - (narrow-to-region (point-min) - (save-excursion (end-of-line) (point))) - (while (not (looking-at ";\\|$")) - (skip-chars-forward "^;\n\"\\\\?") - (cond - ((eq (char-after (point)) ?\\) (forward-char 2)) - ((memq (char-after (point)) '(?\" ??)) (forward-sexp 1)))) - (looking-at ";+[\t ]*")) - (error nil)) - (setq has-comment t has-code-and-comment t) - (setq comment-fill-prefix - (concat (make-string (/ (current-column) 8) ?\t) - (make-string (% (current-column) 8) ?\ ) - (buffer-substring (match-beginning 0) (match-end 0))))))) - - (if (not has-comment) - (fill-paragraph justify) - - ;; Narrow to include only the comment, and then fill the region. - (save-excursion - (save-restriction - (beginning-of-line) - (narrow-to-region - ;; Find the first line we should include in the region to fill. - (save-excursion - (while (and (zerop (forward-line -1)) - (looking-at "^[ \t]*;"))) - ;; We may have gone too far. Go forward again. - (or (looking-at ".*;") - (forward-line 1)) - (point)) - ;; Find the beginning of the first line past the region to fill. - (save-excursion - (while (progn (forward-line 1) - (looking-at "^[ \t]*;"))) - (point))) - - ;; Lines with only semicolons on them can be paragraph boundaries. - (let* ((paragraph-start (concat paragraph-start "\\|[ \t;]*$")) - (paragraph-separate (concat paragraph-start "\\|[ \t;]*$")) - (paragraph-ignore-fill-prefix nil) - (fill-prefix comment-fill-prefix) - (after-line (if has-code-and-comment - (save-excursion - (forward-line 1) (point)))) - (end (progn - (forward-paragraph) - (or (bolp) (newline 1)) - (point))) - ;; If this comment starts on a line with code, - ;; include that like in the filling. - (beg (progn (backward-paragraph) - (if (eq (point) after-line) - (forward-line -1)) - (point)))) - (fill-region-as-paragraph beg end - justify nil - (save-excursion - (goto-char beg) - (if (looking-at fill-prefix) - nil - (re-search-forward comment-start-skip) - (point)))))))) - t)) - -(defun indent-code-rigidly (start end arg &optional nochange-regexp) - "Indent all lines of code, starting in the region, sideways by ARG columns. -Does not affect lines starting inside comments or strings, assuming that -the start of the region is not inside them. - -Called from a program, takes args START, END, COLUMNS and NOCHANGE-REGEXP. -The last is a regexp which, if matched at the beginning of a line, -means don't indent that line." - (interactive "r\np") - (let (state) - (save-excursion - (goto-char end) - (setq end (point-marker)) - (goto-char start) - (or (bolp) - (setq state (parse-partial-sexp (point) - (progn - (forward-line 1) (point)) - nil nil state))) - (while (< (point) end) - (or (car (nthcdr 3 state)) - (and nochange-regexp - (looking-at nochange-regexp)) - ;; If line does not start in string, indent it - (let ((indent (current-indentation))) - (delete-region (point) (progn (skip-chars-forward " \t") (point))) - (or (eolp) - (indent-to (max 0 (+ indent arg)) 0)))) - (setq state (parse-partial-sexp (point) - (progn - (forward-line 1) (point)) - nil nil state)))))) - -(provide 'lisp-mode) - -;;; lisp-mode.el ends here diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el deleted file mode 100644 index 767c96e620b..00000000000 --- a/lisp/emacs-lisp/lisp.el +++ /dev/null @@ -1,316 +0,0 @@ -;;; lisp.el --- Lisp editing commands for Emacs - -;; Copyright (C) 1985, 1986, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: lisp, languages - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Lisp editing commands to go with Lisp major mode. - -;;; Code: - -;; Note that this variable is used by non-lisp modes too. -(defvar defun-prompt-regexp nil - "*Non-nil => regexp to ignore, before the character that starts a defun. -This is only necessary if the opening paren or brace is not in column 0. -See `beginning-of-defun'.") -(make-variable-buffer-local 'defun-prompt-regexp) - -(defvar parens-require-spaces t - "Non-nil => `insert-parentheses' should insert whitespace as needed.") - -(defun forward-sexp (&optional arg) - "Move forward across one balanced expression (sexp). -With argument, do it that many times. Negative arg -N means -move backward across N balanced expressions." - (interactive "p") - (or arg (setq arg 1)) - (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) - (if (< arg 0) (backward-prefix-chars))) - -(defun backward-sexp (&optional arg) - "Move backward across one balanced expression (sexp). -With argument, do it that many times. Negative arg -N means -move forward across N balanced expressions." - (interactive "p") - (or arg (setq arg 1)) - (forward-sexp (- arg))) - -(defun mark-sexp (arg) - "Set mark ARG sexps from point. -The place mark goes is the same place \\[forward-sexp] would -move to with the same argument." - (interactive "p") - (push-mark - (save-excursion - (forward-sexp arg) - (point)) - nil t)) - -(defun forward-list (&optional arg) - "Move forward across one balanced group of parentheses. -With argument, do it that many times. -Negative arg -N means move backward across N groups of parentheses." - (interactive "p") - (or arg (setq arg 1)) - (goto-char (or (scan-lists (point) arg 0) (buffer-end arg)))) - -(defun backward-list (&optional arg) - "Move backward across one balanced group of parentheses. -With argument, do it that many times. -Negative arg -N means move forward across N groups of parentheses." - (interactive "p") - (or arg (setq arg 1)) - (forward-list (- arg))) - -(defun down-list (arg) - "Move forward down one level of parentheses. -With argument, do this that many times. -A negative argument means move backward but still go down a level. -In Lisp programs, an argument is required." - (interactive "p") - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) - (setq arg (- arg inc))))) - -(defun backward-up-list (arg) - "Move backward out of one level of parentheses. -With argument, do this that many times. -A negative argument means move forward but still to a less deep spot. -In Lisp programs, an argument is required." - (interactive "p") - (up-list (- arg))) - -(defun up-list (arg) - "Move forward out of one level of parentheses. -With argument, do this that many times. -A negative argument means move backward but still to a less deep spot. -In Lisp programs, an argument is required." - (interactive "p") - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) - (setq arg (- arg inc))))) - -(defun kill-sexp (arg) - "Kill the sexp (balanced expression) following the cursor. -With argument, kill that many sexps after the cursor. -Negative arg -N means kill N sexps before the cursor." - (interactive "p") - (let ((opoint (point))) - (forward-sexp arg) - (kill-region opoint (point)))) - -(defun backward-kill-sexp (arg) - "Kill the sexp (balanced expression) preceding the cursor. -With argument, kill that many sexps before the cursor. -Negative arg -N means kill N sexps after the cursor." - (interactive "p") - (kill-sexp (- arg))) - -(defun beginning-of-defun (&optional arg) - "Move backward to the beginning of a defun. -With argument, do it that many times. Negative arg -N -means move forward to Nth following beginning of defun. -Returns t unless search stops due to beginning or end of buffer. - -Normally a defun starts when there is an char with open-parenthesis -syntax at the beginning of a line. If `defun-prompt-regexp' is -non-nil, then a string which matches that regexp may precede the -open-parenthesis, and point ends up at the beginning of the line." - (interactive "p") - (and (beginning-of-defun-raw arg) - (progn (beginning-of-line) t))) - -(defun beginning-of-defun-raw (&optional arg) - "Move point to the character that starts a defun. -This is identical to beginning-of-defun, except that point does not move -to the beginning of the line when `defun-prompt-regexp' is non-nil." - (interactive "p") - (and arg (< arg 0) (not (eobp)) (forward-char 1)) - (and (re-search-backward (if defun-prompt-regexp - (concat "^\\s(\\|" - "\\(" defun-prompt-regexp "\\)\\s(") - "^\\s(") - nil 'move (or arg 1)) - (progn (goto-char (1- (match-end 0)))) t)) - -(defun buffer-end (arg) - (if (> arg 0) (point-max) (point-min))) - -(defun end-of-defun (&optional arg) - "Move forward to next end of defun. With argument, do it that many times. -Negative argument -N means move back to Nth preceding end of defun. - -An end of a defun occurs right after the close-parenthesis that matches -the open-parenthesis that starts a defun; see `beginning-of-defun'." - (interactive "p") - (if (or (null arg) (= arg 0)) (setq arg 1)) - (let ((first t)) - (while (and (> arg 0) (< (point) (point-max))) - (let ((pos (point)) npos) - (while (progn - (if (and first - (progn - (end-of-line 1) - (beginning-of-defun-raw 1))) - nil - (or (bobp) (forward-char -1)) - (beginning-of-defun-raw -1)) - (setq first nil) - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1)) - (<= (point) pos)))) - (setq arg (1- arg))) - (while (< arg 0) - (let ((pos (point))) - (beginning-of-defun-raw 1) - (forward-sexp 1) - (forward-line 1) - (if (>= (point) pos) - (if (beginning-of-defun-raw 2) - (progn - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1))) - (goto-char (point-min))))) - (setq arg (1+ arg))))) - -(defun mark-defun () - "Put mark at end of this defun, point at beginning. -The defun marked is the one that contains point or follows point." - (interactive) - (push-mark (point)) - (end-of-defun) - (push-mark (point) nil t) - (beginning-of-defun) - (re-search-backward "^\n" (- (point) 1) t)) - -(defun narrow-to-defun (&optional arg) - "Make text outside current defun invisible. -The defun visible is the one that contains point or follows point." - (interactive) - (save-excursion - (widen) - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (narrow-to-region (point) end)))) - -(defun insert-parentheses (arg) - "Enclose following ARG sexps in parentheses. Leave point after open-paren. -A negative ARG encloses the preceding ARG sexps instead. -No argument is equivalent to zero: just insert `()' and leave point between. -If `parens-require-spaces' is non-nil, this command also inserts a space -before and after, depending on the surrounding characters." - (interactive "P") - (if arg (setq arg (prefix-numeric-value arg)) - (setq arg 0)) - (cond ((> arg 0) (skip-chars-forward " \t")) - ((< arg 0) (forward-sexp arg) (setq arg (- arg)))) - (and parens-require-spaces - (not (bobp)) - (memq (char-syntax (preceding-char)) '(?w ?_ ?\) )) - (insert " ")) - (insert ?\() - (save-excursion - (or (eq arg 0) (forward-sexp arg)) - (insert ?\)) - (and parens-require-spaces - (not (eobp)) - (memq (char-syntax (following-char)) '(?w ?_ ?\( )) - (insert " ")))) - -(defun move-past-close-and-reindent () - "Move past next `)', delete indentation before it, then indent after it." - (interactive) - (up-list 1) - (forward-char -1) - (while (save-excursion ; this is my contribution - (let ((before-paren (point))) - (back-to-indentation) - (= (point) before-paren))) - (delete-indentation)) - (forward-char 1) - (newline-and-indent)) - -(defun lisp-complete-symbol () - "Perform completion on Lisp symbol preceding point. -Compare that symbol against the known Lisp symbols. - -The context determines which symbols are 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." - (interactive) - (let* ((end (point)) - (buffer-syntax (syntax-table)) - (beg (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (backward-sexp 1) - (while (= (char-syntax (following-char)) ?\') - (forward-char 1)) - (point)) - (set-syntax-table buffer-syntax))) - (pattern (buffer-substring beg end)) - (predicate - (if (eq (char-after (1- beg)) ?\() - 'fboundp - (function (lambda (sym) - (or (boundp sym) (fboundp sym) - (symbol-plist sym)))))) - (completion (try-completion pattern obarray predicate))) - (cond ((eq completion t)) - ((null completion) - (message "Can't find completion for \"%s\"" pattern) - (ding)) - ((not (string= pattern completion)) - (delete-region beg end) - (insert completion)) - (t - (message "Making completion list...") - (let ((list (all-completions pattern obarray predicate)) - (completion-fixup-function - (function (lambda () (if (save-excursion - (goto-char (max (point-min) (- (point) 4))) - (looking-at " <f>")) - (forward-char -4)))))) - (setq list (sort list 'string<)) - (or (eq predicate 'fboundp) - (let (new) - (while list - (setq new (cons (if (fboundp (intern (car list))) - (list (car list) " <f>") - (car list)) - new)) - (setq list (cdr list))) - (setq list (nreverse new)))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list list))) - (message "Making completion list...%s" "done"))))) - -;;; lisp.el ends here diff --git a/lisp/emacs-lisp/lmenu.el b/lisp/emacs-lisp/lmenu.el deleted file mode 100644 index a878f6ca206..00000000000 --- a/lisp/emacs-lisp/lmenu.el +++ /dev/null @@ -1,506 +0,0 @@ -;;; lmenu.el --- emulate Lucid's menubar support - -;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Keywords: emulations - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - - -;; First, emulate the Lucid menubar support in GNU Emacs 19. - -;; Arrange to use current-menubar to set up part of the menu bar. - -(defvar current-menubar) - -(setq recompute-lucid-menubar 'recompute-lucid-menubar) -(defun recompute-lucid-menubar () - (define-key lucid-menubar-map [menu-bar] - (condition-case nil - (make-lucid-menu-keymap "menu-bar" current-menubar) - (error (message "Invalid data in current-menubar moved to lucid-failing-menubar") - (sit-for 1) - (setq lucid-failing-menubar current-menubar - current-menubar nil)))) - (setq lucid-menu-bar-dirty-flag nil)) - -(defvar lucid-menubar-map (make-sparse-keymap)) -(or (assq 'current-menubar minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'current-menubar lucid-menubar-map) - minor-mode-map-alist))) - -(defun set-menubar-dirty-flag () - (force-mode-line-update) - (setq lucid-menu-bar-dirty-flag t)) - -(defvar add-menu-item-count 0) - -;; This is a variable whose value is always nil. -(defvar make-lucid-menu-keymap-disable nil) - -;; Return a menu keymap corresponding to a Lucid-style menu list -;; MENU-ITEMS, and with name MENU-NAME. -(defun make-lucid-menu-keymap (menu-name menu-items) - (let ((menu (make-sparse-keymap menu-name))) - ;; Process items in reverse order, - ;; since the define-key loop reverses them again. - (setq menu-items (reverse menu-items)) - (while menu-items - (let ((item (car menu-items)) - command name callback) - (cond ((stringp item) - (setq command nil) - (setq name (if (string-match "^-+$" item) "" item))) - ((consp item) - (setq command (make-lucid-menu-keymap (car item) (cdr item))) - (setq name (car item))) - ((vectorp item) - (setq command (make-symbol (format "menu-function-%d" - add-menu-item-count)) - add-menu-item-count (1+ add-menu-item-count) - name (aref item 0) - callback (aref item 1)) - (if (symbolp callback) - (fset command callback) - (fset command (list 'lambda () '(interactive) callback))) - (put command 'menu-alias t) - (let ((i 2)) - (while (< i (length item)) - (cond - ((eq (aref item i) ':active) - (put command 'menu-enable - (or (aref item (1+ i)) - 'make-lucid-menu-keymap-disable)) - (setq i (+ 2 i))) - ((eq (aref item i) ':suffix) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':keys) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':style) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':selected) - ;; unimplemented - (setq i (+ 2 i))) - ((and (symbolp (aref item i)) - (= ?: (string-to-char (symbol-name (aref item i))))) - (error "Unrecognized menu item keyword: %S" - (aref item i))) - ((= i 2) - ;; old-style format: active-p &optional suffix - (put command 'menu-enable - (or (aref item i) 'make-lucid-menu-keymap-disable)) - ;; suffix is unimplemented - (setq i (length item))) - (t - (error "Unexpected menu item value: %S" - (aref item i)))))))) - (if (null command) - ;; Handle inactive strings specially--allow any number - ;; of identical ones. - (setcdr menu (cons (list nil name) (cdr menu))) - (if name - (define-key menu (vector (intern name)) (cons name command))))) - (setq menu-items (cdr menu-items))) - menu)) - -(defun popup-menu (menu-desc) - "Pop up the given menu. -A menu is a list of menu items, strings, and submenus. - -The first element of a menu must be a string, which is the name of the -menu. This is the string that will be displayed in the parent menu, if -any. For toplevel menus, it is ignored. This string is not displayed -in the menu itself. - -A menu item is a vector containing: - - - the name of the menu item (a string); - - the `callback' of that item; - - a list of keywords with associated values: - - :active active-p a form specifying whether this item is selectable; - - :suffix suffix a string to be appended to the name as an `argument' - to the command, like `Kill Buffer NAME'; - - :keys command-keys a string, suitable for `substitute-command-keys', - to specify the keyboard equivalent of a command - when the callback is a form (this is not necessary - when the callback is a symbol, as the keyboard - equivalent is computed automatically in that case); - - :style style a symbol: nil for a normal menu item, `toggle' for - a toggle button (a single option that can be turned - on or off), or `radio' for a radio button (one of a - group of mutually exclusive options); - - :selected form for `toggle' or `radio' style, a form that specifies - whether the button will be in the selected state. - -Alternately, the vector may contain exactly 3 or 4 elements, with the third -element specifying `active-p' and the fourth specifying `suffix'. - -If the `callback' of a menu item is a symbol, then it must name a command. -It will be invoked with `call-interactively'. If it is a list, then it is -evaluated with `eval'. - -If an element of a menu is a string, then that string will be presented in -the menu as unselectable text. - -If an element of a menu is a string consisting solely of hyphens, then that -item will be presented as a solid horizontal line. - -If an element of a menu is a list, it is treated as a submenu. The name of -that submenu (the first element in the list) will be used as the name of the -item representing this menu on the parent. - -The syntax, more precisely: - - form := <something to pass to `eval'> - command := <a symbol or string, to pass to `call-interactively'> - callback := command | form - active-p := <t or nil, whether this thing is selectable> - text := <string, non selectable> - name := <string> - suffix := <string> - command-keys := <string> - object-style := 'nil' | 'toggle' | 'radio' - keyword := ':active' active-p - | ':suffix' suffix - | ':keys' command-keys - | ':style' object-style - | ':selected' form - menu-item := '[' name callback active-p [ suffix ] ']' - | '[' name callback [ keyword ]+ ']' - menu := '(' name [ menu-item | menu | text ]+ ')'" - (let ((menu (make-lucid-menu-keymap (car menu-desc) (cdr menu-desc))) - (pos (mouse-pixel-position)) - answer cmd) - (while (and menu - (setq answer (x-popup-menu (list (list (nth 1 pos) - (nthcdr 2 pos)) - (car pos)) - menu))) - (setq cmd (lookup-key menu (apply 'vector answer))) - (setq menu nil) - (and cmd - (if (keymapp cmd) - (setq menu cmd) - (call-interactively cmd)))))) - -(defun popup-dialog-box (data) - "Pop up a dialog box. -A dialog box description is a list. - - - The first element of the list is a string to display in the dialog box. - - The rest of the elements are descriptions of the dialog box's buttons. - Each one is a vector of three elements: - - The first element is the text of the button. - - The second element is the `callback'. - - The third element is t or nil, whether this button is selectable. - -If the `callback' of a button is a symbol, then it must name a command. -It will be invoked with `call-interactively'. If it is a list, then it is -evaluated with `eval'. - -One (and only one) of the buttons may be `nil'. This marker means that all -following buttons should be flushright instead of flushleft. - -The syntax, more precisely: - - form := <something to pass to `eval'> - command := <a symbol or string, to pass to `call-interactively'> - callback := command | form - active-p := <t, nil, or a form to evaluate to decide whether this - button should be selectable> - name := <string> - partition := 'nil' - button := '[' name callback active-p ']' - dialog := '(' name [ button ]+ [ partition [ button ]+ ] ')'" - (let ((name (car data)) - (tail (cdr data)) - converted - choice meaning) - (while tail - (if (null (car tail)) - (setq converted (cons nil converted)) - (let ((item (aref (car tail) 0)) - (callback (aref (car tail) 1)) - (enable (aref (car tail) 2))) - (setq converted - (cons (if enable (cons item callback) item) - converted)))) - (setq tail (cdr tail))) - (setq choice (x-popup-dialog t (cons name (nreverse converted)))) - (if choice - (if (symbolp choice) - (call-interactively choice) - (eval choice))))) - -;; This is empty because the usual elements of the menu bar -;; are provided by menu-bar.el instead. -;; It would not make sense to duplicate them here. -(defconst default-menubar nil) - -(defun set-menubar (menubar) - "Set the default menubar to be menubar." - (setq-default current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - -(defun set-buffer-menubar (menubar) - "Set the buffer-local menubar to be menubar." - (make-local-variable 'current-menubar) - (setq current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - - -;;; menu manipulation functions - -(defun find-menu-item (menubar item-path-list &optional parent) - "Searches MENUBAR for item given by ITEM-PATH-LIST. -Returns (ITEM . PARENT), where PARENT is the immediate parent of - the item found. -Signals an error if the item is not found." - (or parent (setq item-path-list (mapcar 'downcase item-path-list))) - (if (not (consp menubar)) - nil - (let ((rest menubar) - result) - (while rest - (if (and (car rest) - (equal (car item-path-list) - (downcase (if (vectorp (car rest)) - (aref (car rest) 0) - (if (stringp (car rest)) - (car rest) - (car (car rest))))))) - (setq result (car rest) rest nil) - (setq rest (cdr rest)))) - (if (cdr item-path-list) - (if (consp result) - (find-menu-item (cdr result) (cdr item-path-list) result) - (if result - (signal 'error (list "not a submenu" result)) - (signal 'error (list "no such submenu" (car item-path-list))))) - (cons result parent))))) - - -(defun disable-menu-item (path) - "Make the named menu item be unselectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (consp item) (error "can't disable menus, only menu items")) - (aset item 2 nil) - (set-menubar-dirty-flag) - item)) - - -(defun enable-menu-item (path) - "Make the named menu item be selectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (consp item) (error "%S is a menu, not a menu item" path)) - (aset item 2 t) - (set-menubar-dirty-flag) - item)) - - -(defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before) - (if before (setq before (downcase before))) - (let* ((menubar current-menubar) - (menu (condition-case () - (car (find-menu-item menubar menu-path)) - (error nil))) - (item (if (listp menu) - (car (find-menu-item (cdr menu) (list item-name))) - (signal 'error (list "not a submenu" menu-path))))) - (or menu - (let ((rest menu-path) - (so-far menubar)) - (while rest -;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) - (setq menu - (if (eq so-far menubar) - (car (find-menu-item so-far (list (car rest)))) - (car (find-menu-item (cdr so-far) (list (car rest)))))) - (or menu - (let ((rest2 so-far)) - (or rest2 - (error "Trying to modify a menu that doesn't exist")) - (while (and (cdr rest2) (car (cdr rest2))) - (setq rest2 (cdr rest2))) - (setcdr rest2 - (nconc (list (setq menu (list (car rest)))) - (cdr rest2))))) - (setq so-far menu) - (setq rest (cdr rest))))) - (or menu (setq menu menubar)) - (if item - nil ; it's already there - (if item-p - (setq item (vector item-name item-data enabled-p)) - (setq item (cons item-name item-data))) - ;; if BEFORE is specified, try to add it there. - (if before - (setq before (car (find-menu-item menu (list before))))) - (let ((rest menu) - (added-before nil)) - (while rest - (if (eq before (car (cdr rest))) - (progn - (setcdr rest (cons item (cdr rest))) - (setq rest nil added-before t)) - (setq rest (cdr rest)))) - (if (not added-before) - ;; adding before the first item on the menubar itself is harder - (if (and (eq menu menubar) (eq before (car menu))) - (setq menu (cons item menu) - current-menubar menu) - ;; otherwise, add the item to the end. - (nconc menu (list item)))))) - (if item-p - (progn - (aset item 1 item-data) - (aset item 2 (not (null enabled-p)))) - (setcar item item-name) - (setcdr item item-data)) - (set-menubar-dirty-flag) - item)) - -(defun add-menu-item (menu-path item-name function enabled-p &optional before) - "Add a menu item to some menu, creating the menu first if necessary. -If the named item exists already, it is changed. -MENU-PATH identifies the menu under which the new menu item should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". -ITEM-NAME is the string naming the menu item to be added. -FUNCTION is the command to invoke when this menu item is selected. - If it is a symbol, then it is invoked with `call-interactively', in the same - way that functions bound to keys are invoked. If it is a list, then the - list is simply evaluated. -ENABLED-P controls whether the item is selectable or not. -BEFORE, if provided, is the name of a menu item before which this item should - be added, if this item is not on the menu already. If the item is already - present, it will not be moved." - (or menu-path (error "must specify a menu path")) - (or item-name (error "must specify an item name")) - (add-menu-item-1 t menu-path item-name function enabled-p before)) - - -(defun delete-menu-item (path) - "Remove the named menu item from the menu hierarchy. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (or (cdr pair) menubar))) - (if (not item) - nil - ;; the menubar is the only special case, because other menus begin - ;; with their name. - (if (eq menu current-menubar) - (setq current-menubar (delq item menu)) - (delq item menu)) - (set-menubar-dirty-flag) - item))) - - -(defun relabel-menu-item (path new-name) - "Change the string of the specified menu item. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". -NEW-NAME is the string that the menu item will be printed as from now on." - (or (stringp new-name) - (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (and (consp item) - (stringp (car item))) - (setcar item new-name) - (aset item 0 new-name)) - (set-menubar-dirty-flag) - item)) - -(defun add-menu (menu-path menu-name menu-items &optional before) - "Add a menu to the menubar or one of its submenus. -If the named menu exists already, it is changed. -MENU-PATH identifies the menu under which the new menu should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". - If MENU-PATH is nil, then the menu will be added to the menubar itself. -MENU-NAME is the string naming the menu to be added. -MENU-ITEMS is a list of menu item descriptions. - Each menu item should be a vector of three elements: - - a string, the name of the menu item; - - a symbol naming a command, or a form to evaluate; - - and a form whose value determines whether this item is selectable. -BEFORE, if provided, is the name of a menu before which this menu should - be added, if this menu is not on its parent already. If the menu is already - present, it will not be moved." - (or menu-name (error "must specify a menu name")) - (or menu-items (error "must specify some menu items")) - (add-menu-item-1 nil menu-path menu-name menu-items t before)) - - - -(defvar put-buffer-names-in-file-menu t) - - -;; Don't unconditionally enable menu bars; leave that up to the user. -;;(let ((frames (frame-list))) -;; (while frames -;; (modify-frame-parameters (car frames) '((menu-bar-lines . 1))) -;; (setq frames (cdr frames)))) -;;(or (assq 'menu-bar-lines default-frame-alist) -;; (setq default-frame-alist -;; (cons '(menu-bar-lines . 1) default-frame-alist))) - -(set-menubar default-menubar) - -(provide 'lmenu) - -;;; lmenu.el ends here diff --git a/lisp/emacs-lisp/lselect.el b/lisp/emacs-lisp/lselect.el deleted file mode 100644 index c6c64a909f8..00000000000 --- a/lisp/emacs-lisp/lselect.el +++ /dev/null @@ -1,230 +0,0 @@ -;;; lselect.el --- Lucid interface to X Selections - -;; Copyright (C) 1990, 1993 Free Software Foundation, Inc. - -;; Keywords: emulations - -;; This won't completely work until we support or emulate Lucid-style extents. -;; Based on Lucid's selection code. - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;; The selection code requires us to use certain symbols whose names are -;;; all upper-case; this may seem tasteless, but it makes there be a 1:1 -;;; correspondence between these symbols and X Atoms (which are upcased.) - -(defalias 'x-get-cutbuffer 'x-get-cut-buffer) -(defalias 'x-store-cutbuffer 'x-set-cut-buffer) - -(or (find-face 'primary-selection) - (make-face 'primary-selection)) - -(or (find-face 'secondary-selection) - (make-face 'secondary-selection)) - -(defun x-get-secondary-selection () - "Return text selected from some X window." - (x-get-selection-internal 'SECONDARY 'STRING)) - -(defvar primary-selection-extent nil - "The extent of the primary selection; don't use this.") - -(defvar secondary-selection-extent nil - "The extent of the secondary selection; don't use this.") - - -(defun x-select-make-extent-for-selection (selection previous-extent face) - ;; Given a selection, this makes an extent in the buffer which holds that - ;; selection, for highlighting purposes. If the selection isn't associated - ;; with a buffer, this does nothing. - (let ((buffer nil) - (valid (and (extentp previous-extent) - (extent-buffer previous-extent) - (buffer-name (extent-buffer previous-extent)))) - start end) - (cond ((stringp selection) - ;; if we're selecting a string, lose the previous extent used - ;; to highlight the selection. - (setq valid nil)) - ((consp selection) - (setq start (min (car selection) (cdr selection)) - end (max (car selection) (cdr selection)) - valid (and valid - (eq (marker-buffer (car selection)) - (extent-buffer previous-extent))) - buffer (marker-buffer (car selection)))) - ((extentp selection) - (setq start (extent-start-position selection) - end (extent-end-position selection) - valid (and valid - (eq (extent-buffer selection) - (extent-buffer previous-extent))) - buffer (extent-buffer selection))) - ) - (if (and (not valid) - (extentp previous-extent) - (extent-buffer previous-extent) - (buffer-name (extent-buffer previous-extent))) - (delete-extent previous-extent)) - (if (not buffer) - ;; string case - nil - ;; normal case - (if valid - (set-extent-endpoints previous-extent start end) - (setq previous-extent (make-extent start end buffer)) - ;; use same priority as mouse-highlighting so that conflicts between - ;; the selection extent and a mouse-highlighted extent are resolved - ;; by the usual size-and-endpoint-comparison method. - (set-extent-priority previous-extent mouse-highlight-priority) - (set-extent-face previous-extent face))))) - - -(defun x-own-selection (selection &optional type) - "Make a primary X Selection of the given argument. -The argument may be a string, a cons of two markers, or an extent. -In the latter cases the selection is considered to be the text -between the markers, or the between extents endpoints." - (interactive (if (not current-prefix-arg) - (list (read-string "Store text for pasting: ")) - (list (cons ;; these need not be ordered. - (copy-marker (point-marker)) - (copy-marker (mark-marker)))))) - (or type (setq type 'PRIMARY)) - (x-set-selection selection type) - (cond ((eq type 'PRIMARY) - (setq primary-selection-extent - (x-select-make-extent-for-selection - selection primary-selection-extent 'primary-selection))) - ((eq type 'SECONDARY) - (setq secondary-selection-extent - (x-select-make-extent-for-selection - selection secondary-selection-extent 'secondary-selection)))) - selection) - - -(defun x-own-secondary-selection (selection &optional type) - "Make a secondary X Selection of the given argument. The argument may be a -string or a cons of two markers (in which case the selection is considered to -be the text between those markers.)" - (interactive (if (not current-prefix-arg) - (list (read-string "Store text for pasting: ")) - (list (cons ;; these need not be ordered. - (copy-marker (point-marker)) - (copy-marker (mark-marker)))))) - (x-own-selection selection 'SECONDARY)) - - -(defun x-own-clipboard (string) - "Paste the given string to the X Clipboard." - (x-own-selection string 'CLIPBOARD)) - - -(defun x-disown-selection (&optional secondary-p) - "Assuming we own the selection, disown it. With an argument, discard the -secondary selection instead of the primary selection." - (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY))) - -(defun x-dehilight-selection (selection) - "for use as a value of x-lost-selection-hooks." - (cond ((eq selection 'PRIMARY) - (if primary-selection-extent - (let ((inhibit-quit t)) - (delete-extent primary-selection-extent) - (setq primary-selection-extent nil))) - (if zmacs-regions (zmacs-deactivate-region))) - ((eq selection 'SECONDARY) - (if secondary-selection-extent - (let ((inhibit-quit t)) - (delete-extent secondary-selection-extent) - (setq secondary-selection-extent nil))))) - nil) - -(setq x-lost-selection-hooks 'x-dehilight-selection) - -(defun x-notice-selection-requests (selection type successful) - "for possible use as the value of x-sent-selection-hooks." - (if (not successful) - (message "Selection request failed to convert %s to %s" - selection type) - (message "Sent selection %s as %s" selection type))) - -(defun x-notice-selection-failures (selection type successful) - "for possible use as the value of x-sent-selection-hooks." - (or successful - (message "Selection request failed to convert %s to %s" - selection type))) - -;(setq x-sent-selection-hooks 'x-notice-selection-requests) -;(setq x-sent-selection-hooks 'x-notice-selection-failures) - - -;;; Random utility functions - -(defun x-kill-primary-selection () - "If there is a selection, delete the text it covers, and copy it to -both the kill ring and the Clipboard." - (interactive) - (or (x-selection-owner-p) (error "emacs does not own the primary selection")) - (setq last-command nil) - (or primary-selection-extent - (error "the primary selection is not an extent?")) - (save-excursion - (set-buffer (extent-buffer primary-selection-extent)) - (kill-region (extent-start-position primary-selection-extent) - (extent-end-position primary-selection-extent))) - (x-disown-selection nil)) - -(defun x-delete-primary-selection () - "If there is a selection, delete the text it covers *without* copying it to -the kill ring or the Clipboard." - (interactive) - (or (x-selection-owner-p) (error "emacs does not own the primary selection")) - (setq last-command nil) - (or primary-selection-extent - (error "the primary selection is not an extent?")) - (save-excursion - (set-buffer (extent-buffer primary-selection-extent)) - (delete-region (extent-start-position primary-selection-extent) - (extent-end-position primary-selection-extent))) - (x-disown-selection nil)) - -(defun x-copy-primary-selection () - "If there is a selection, copy it to both the kill ring and the Clipboard." - (interactive) - (setq last-command nil) - (or (x-selection-owner-p) (error "emacs does not own the primary selection")) - (or primary-selection-extent - (error "the primary selection is not an extent?")) - (save-excursion - (set-buffer (extent-buffer primary-selection-extent)) - (copy-region-as-kill (extent-start-position primary-selection-extent) - (extent-end-position primary-selection-extent)))) - -(defun x-yank-clipboard-selection () - "If someone owns a Clipboard selection, insert it at point." - (interactive) - (setq last-command nil) - (let ((clip (x-get-clipboard))) - (or clip (error "there is no clipboard selection")) - (push-mark) - (insert clip))) - -;;; lselect.el ends here. diff --git a/lisp/emacs-lisp/lucid.el b/lisp/emacs-lisp/lucid.el deleted file mode 100644 index 5c609137ffe..00000000000 --- a/lisp/emacs-lisp/lucid.el +++ /dev/null @@ -1,223 +0,0 @@ -;;; lucid.el --- Emulate some Lucid Emacs functions. - -;; Copyright (C) 1993, 1995 Free Software Foundation, Inc. - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defun copy-tree (tree) - (if (consp tree) - (cons (copy-tree (car tree)) - (copy-tree (cdr tree))) - (if (vectorp tree) - (let* ((new (copy-sequence tree)) - (i (1- (length new)))) - (while (>= i 0) - (aset new i (copy-tree (aref new i))) - (setq i (1- i))) - new) - tree))) - -(defalias 'current-time-seconds 'current-time) - -(defun remprop (symbol prop) - (let ((plist (symbol-plist symbol))) - (while (eq (car plist) prop) - (setplist symbol (setq plist (cdr (cdr plist))))) - (while plist - (if (eq (nth 2 plist) prop) - (setcdr (cdr plist) (nthcdr 4 plist))) - (setq plist (cdr (cdr plist)))))) - -(defun map-keymap (function keymap &optional sort-first) - "Call FUNCTION for every binding in KEYMAP. -This includes bindings inherited from a parent keymap. -FUNCTION receives two arguments each time it is called: -the character (more generally, the event type) that is bound, -and the binding it has. - -Note that passing the event type directly to `define-key' does not work -in Emacs 19. We do not emulate that particular feature of Lucid Emacs. -If your code does that, modify it to make a vector containing the event -type that you get. That will work in both versions of Emacs." - (if sort-first - (let (list) - (map-keymap (function (lambda (a b) - (setq list (cons (cons a b) list)))) - keymap) - (setq list (sort list - (function (lambda (a b) - (setq a (car a) b (car b)) - (if (integerp a) - (if (integerp b) (< a b) - t) - (if (integerp b) t - (string< a b))))))) - (while list - (funcall function (car (car list)) (cdr (car list))) - (setq list (cdr list)))) - (while (consp keymap) - (if (consp (car keymap)) - (funcall function (car (car keymap)) (cdr (car keymap))) - (if (vectorp (car keymap)) - (let ((i (1- (length (car keymap)))) - (vector (car keymap))) - (while (>= i 0) - (funcall function i (aref vector i)) - (setq i (1- i)))))) - (setq keymap (cdr keymap))))) - -(defun read-number (prompt &optional integers-only) - "Read a number from the minibuffer. -Keep reentering the minibuffer until we get suitable input. -If optional argument INTEGERS-ONLY is non-nil, insist on an integer." - (interactive) - (let (success - (number nil) - (predicate (if integers-only 'integerp 'numberp))) - (while (not success) - (let ((input-string (read-string prompt))) - (condition-case () - (setq number (read input-string)) - (error)) - (if (funcall predicate number) - (setq success t) - (let ((cursor-in-echo-area t)) - (message "Please type %s" - (if integers-only "an integer" "a number")) - (sit-for 1))))) - number)) - -(defun real-path-name (name &optional default) - (file-truename (expand-file-name name default))) - -;; It's not clear what to return if the mouse is not in FRAME. -(defun read-mouse-position (frame) - (let ((pos (mouse-position))) - (if (eq (car pos) frame) - (cdr pos)))) - -(defun switch-to-other-buffer (arg) - "Switch to the previous buffer. -With a numeric arg N, switch to the Nth most recent buffer. -With an arg of 0, buries the current buffer at the -bottom of the buffer stack." - (interactive "p") - (if (eq arg 0) - (bury-buffer (current-buffer))) - (switch-to-buffer - (if (<= arg 1) (other-buffer (current-buffer)) - (nth arg - (apply 'nconc - (mapcar - (lambda (buf) - (if (= ?\ (string-to-char (buffer-name buf))) - nil - (list buf))) - (buffer-list))))))) - -(defalias 'find-face 'internal-find-face) -(defalias 'get-face 'internal-get-face) -(defalias 'try-face-font 'internal-try-face-font) - -(defalias 'exec-to-string 'shell-command-to-string) - -(defun make-extent (beg end &optional buffer) - (make-overlay beg end buffer)) - -(defun set-extent-property (extent prop value) - (if (eq prop 'duplicable) - (cond ((and value (not (overlay-get extent prop))) - ;; If becoming duplicable, copy all overlayprops to text props. - (add-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent))) - ;; If becoming no longer duplicable, remove these text props. - ((and (not value) (overlay-get extent prop)) - (remove-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent)))) - ;; If extent is already duplicable, put this property - ;; on the text as well as on the overlay. - (if (overlay-get extent 'duplicable) - (put-text-property (overlay-start extent) - (overlay-end extent) - prop value (overlay-buffer extent)))) - (overlay-put extent prop value)) - -(defun set-extent-face (extent face) - (set-extent-property extent 'face face)) - -(defun delete-extent (extent) - (set-extent-property extent 'duplicable nil) - (delete-overlay extent)) - -;; Support the Lucid names with `screen' instead of `frame'. - -(defalias 'current-screen-configuration 'current-frame-configuration) -(defalias 'delete-screen 'delete-frame) -(defalias 'find-file-new-screen 'find-file-other-frame) -(defalias 'find-file-read-only-new-screen 'find-file-read-only-other-frame) -(defalias 'find-tag-new-screen 'find-tag-other-frame) -;;(defalias 'focus-screen 'focus-frame) -(defalias 'iconify-screen 'iconify-frame) -(defalias 'mail-new-screen 'mail-other-frame) -(defalias 'make-screen-invisible 'make-frame-invisible) -(defalias 'make-screen-visible 'make-frame-visible) -;; (defalias 'minibuffer-screen-list 'minibuffer-frame-list) -(defalias 'modify-screen-parameters 'modify-frame-parameters) -(defalias 'next-screen 'next-frame) -;; (defalias 'next-multiscreen-window 'next-multiframe-window) -;; (defalias 'previous-multiscreen-window 'previous-multiframe-window) -;; (defalias 'redirect-screen-focus 'redirect-frame-focus) -(defalias 'redraw-screen 'redraw-frame) -;; (defalias 'screen-char-height 'frame-char-height) -;; (defalias 'screen-char-width 'frame-char-width) -;; (defalias 'screen-configuration-to-register 'frame-configuration-to-register) -;; (defalias 'screen-focus 'frame-focus) -(defalias 'screen-list 'frame-list) -;; (defalias 'screen-live-p 'frame-live-p) -(defalias 'screen-parameters 'frame-parameters) -(defalias 'screen-pixel-height 'frame-pixel-height) -(defalias 'screen-pixel-width 'frame-pixel-width) -(defalias 'screen-root-window 'frame-root-window) -(defalias 'screen-selected-window 'frame-selected-window) -(defalias 'lower-screen 'lower-frame) -(defalias 'raise-screen 'raise-frame) -(defalias 'screen-visible-p 'frame-visible-p) -(defalias 'screenp 'framep) -(defalias 'select-screen 'select-frame) -(defalias 'selected-screen 'selected-frame) -;; (defalias 'set-screen-configuration 'set-frame-configuration) -;; (defalias 'set-screen-height 'set-frame-height) -(defalias 'set-screen-position 'set-frame-position) -(defalias 'set-screen-size 'set-frame-size) -;; (defalias 'set-screen-width 'set-frame-width) -(defalias 'switch-to-buffer-new-screen 'switch-to-buffer-other-frame) -;; (defalias 'unfocus-screen 'unfocus-frame) -(defalias 'visible-screen-list 'visible-frame-list) -(defalias 'window-screen 'window-frame) -(defalias 'x-create-screen 'x-create-frame) -(defalias 'x-new-screen 'make-frame) - -(provide 'lucid) - -;;; end of lucid.el diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el deleted file mode 100644 index 013ce8402d3..00000000000 --- a/lisp/emacs-lisp/pp.el +++ /dev/null @@ -1,181 +0,0 @@ -;;; pp.el --- pretty printer for Emacs Lisp - -;; Copyright (C) 1989, 1993 Free Software Foundation, Inc. - -;; Author: Randal Schwartz <merlyn@stonehenge.com> - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defvar pp-escape-newlines t - "*Value of print-escape-newlines used by pp-* functions.") - -(defun pp-to-string (object) - "Return a string containing the pretty-printed representation of OBJECT, -any Lisp object. Quoting characters are used when needed to make output -that `read' can handle, whenever this is possible." - (save-excursion - (set-buffer (generate-new-buffer " pp-to-string")) - (unwind-protect - (progn - (lisp-mode-variables t) - (let ((print-escape-newlines pp-escape-newlines)) - (prin1 object (current-buffer))) - (goto-char (point-min)) - (while (not (eobp)) - ;; (message "%06d" (- (point-max) (point))) - (cond - ((looking-at "\\s(\\|#\\s(") - (while (looking-at "\\s(\\|#\\s(") - (forward-char 1))) - ((and (looking-at "\\(quote[ \t]+\\)\\([^.)]\\)") - (> (match-beginning 1) 1) - (= ?\( (char-after (1- (match-beginning 1)))) - ;; Make sure this is a two-element list. - (save-excursion - (goto-char (match-beginning 2)) - (forward-sexp) - ;; (looking-at "[ \t]*\)") - ;; Avoid mucking with match-data; does this test work? - (char-equal ?\) (char-after (point))))) - ;; -1 gets the paren preceding the quote as well. - (delete-region (1- (match-beginning 1)) (match-end 1)) - (insert "'") - (forward-sexp 1) - (if (looking-at "[ \t]*\)") - (delete-region (match-beginning 0) (match-end 0)) - (error "Malformed quote")) - (backward-sexp 1)) - ((condition-case err-var - (prog1 t (down-list 1)) - (error nil)) - (backward-char 1) - (skip-chars-backward " \t") - (delete-region - (point) - (progn (skip-chars-forward " \t") (point))) - (if (not (char-equal ?' (char-after (1- (point))))) - (insert ?\n))) - ((condition-case err-var - (prog1 t (up-list 1)) - (error nil)) - (while (looking-at "\\s)") - (forward-char 1)) - (skip-chars-backward " \t") - (delete-region - (point) - (progn (skip-chars-forward " \t") (point))) - (if (not (char-equal ?' (char-after (1- (point))))) - (insert ?\n))) - (t (goto-char (point-max))))) - (goto-char (point-min)) - (indent-sexp) - (buffer-string)) - (kill-buffer (current-buffer))))) - -;;;###autoload -(defun pp (object &optional stream) - "Output the pretty-printed representation of OBJECT, any Lisp object. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see)." - (princ (pp-to-string object) (or stream standard-output))) - -;;;###autoload -(defun pp-eval-expression (expression) - "Evaluate EXPRESSION and pretty-print value into a new display buffer. -If the pretty-printed value fits on one line, the message line is used -instead. Value is also consed on to front of variable values 's -value." - (interactive "xPp-eval: ") - (setq values (cons (eval expression) values)) - (let* ((old-show-function temp-buffer-show-function) - ;; Use this function to display the buffer. - ;; This function either decides not to display it at all - ;; or displays it in the usual way. - (temp-buffer-show-function - (function - (lambda (buf) - (save-excursion - (set-buffer buf) - (goto-char (point-min)) - (end-of-line 1) - (if (or (< (1+ (point)) (point-max)) - (>= (- (point) (point-min)) (frame-width))) - (let ((temp-buffer-show-function old-show-function) - (old-selected (selected-window)) - (window (display-buffer buf))) - (goto-char (point-min)) ; expected by some hooks ... - (make-frame-visible (window-frame window)) - (unwind-protect - (progn - (select-window window) - (run-hooks 'temp-buffer-show-hook)) - (select-window old-selected))) - (message "%s" (buffer-substring (point-min) (point))) - )))))) - (with-output-to-temp-buffer "*Pp Eval Output*" - (pp (car values))) - (save-excursion - (set-buffer "*Pp Eval Output*") - (emacs-lisp-mode) - (make-local-variable 'font-lock-verbose) - (setq font-lock-verbose nil)))) - -;;;###autoload -(defun pp-eval-last-sexp (arg) - "Run `pp-eval-expression' on sexp before point (which see). -With argument, pretty-print output into current buffer. -Ignores leading comment characters." - (interactive "P") - (let ((stab (syntax-table)) (pt (point)) start exp) - (set-syntax-table emacs-lisp-mode-syntax-table) - (save-excursion - (forward-sexp -1) - ;; If first line is commented, ignore all leading comments: - (if (save-excursion (beginning-of-line) (looking-at "[ \t]*;")) - (progn - (setq exp (buffer-substring (point) pt)) - (while (string-match "\n[ \t]*;+" exp start) - (setq start (1+ (match-beginning 0)) - exp (concat (substring exp 0 start) - (substring exp (match-end 0))))) - (setq exp (read exp))) - (setq exp (read (current-buffer))))) - (set-syntax-table stab) - (if arg - (insert (pp-to-string (eval exp))) - (pp-eval-expression exp)))) - -;;; Test cases for quote -;; (pp-eval-expression ''(quote quote)) -;; (pp-eval-expression ''((quote a) (quote b))) -;; (pp-eval-expression ''('a 'b)) ; same as above -;; (pp-eval-expression ''((quote (quote quote)) (quote quote))) -;; These do not satisfy the quote test. -;; (pp-eval-expression ''quote) -;; (pp-eval-expression ''(quote)) -;; (pp-eval-expression ''(quote . quote)) -;; (pp-eval-expression ''(quote a b)) -;; (pp-eval-expression ''(quotefoo)) -;; (pp-eval-expression ''(a b)) - -(provide 'pp) ; so (require 'pp) works - -;;; pp.el ends here. diff --git a/lisp/emacs-lisp/profile.el b/lisp/emacs-lisp/profile.el deleted file mode 100644 index d8f8b5f86fa..00000000000 --- a/lisp/emacs-lisp/profile.el +++ /dev/null @@ -1,325 +0,0 @@ -;;; profile.el --- generate run time measurements of Emacs Lisp functions - -;; Copyright (C) 1992, 1994 Free Software Foundation, Inc. - -;; Author: Boaz Ben-Zvi <boaz@lcs.mit.edu> -;; Created: 07 Feb 1992 -;; Version: 1.0 -;; Adapted-By: ESR -;; Keywords: lisp, tools - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; DESCRIPTION: -;; ------------ -;; This program can be used to monitor running time performance of Emacs Lisp -;; functions. It takes a list of functions and report the real time spent -;; inside these functions. It runs a process with a separate timer program. -;; Caveat: the C code in ../lib-src/profile.c requires BSD-compatible -;; time-of-day functions. If you're running an AT&T version prior to SVr4, -;; you may have difficulty getting it to work. Your X library may supply -;; the required routines if the standard C library does not. - -;; HOW TO USE: -;; ----------- -;; Set the variable profile-functions-list to the list of functions -;; (as symbols) You want to profile. Call M-x profile-functions to set -;; this list on and start using your program. Note that profile-functions -;; MUST be called AFTER all the functions in profile-functions-list have -;; been loaded !! (This call modifies the code of the profiled functions. -;; Hence if you reload these functions, you need to call profile-functions -;; again! ). -;; To display the results do M-x profile-results . For example: -;;------------------------------------------------------------------- -;; (setq profile-functions-list '(sokoban-set-mode-line sokoban-load-game -;; sokoban-move-vertical sokoban-move)) -;; (load "sokoban") -;; M-x profile-functions -;; ... I play the sokoban game .......... -;; M-x profile-results -;; -;; Function Time (Seconds.Useconds) -;; ======== ======================= -;; sokoban-move 0.539088 -;; sokoban-move-vertical 0.410130 -;; sokoban-load-game 0.453235 -;; sokoban-set-mode-line 1.949203 -;;----------------------------------------------------- -;; To clear all the settings to profile use profile-finish. -;; To set one function at a time (instead of or in addition to setting the -;; above list and M-x profile-functions) use M-x profile-a-function. - -;;; Code: - -;;; -;;; User modifiable VARIABLES -;;; - -(defvar profile-functions-list nil "*List of functions to profile.") -(defvar profile-timer-program - (concat exec-directory "profile") - "*Name of the profile timer program.") - -;;; -;;; V A R I A B L E S -;;; - -(defvar profile-timer-process nil "Process running the timer.") -(defvar profile-time-list nil - "List of cumulative calls and time for each profiled function.") -(defvar profile-init-list nil - "List of entry time for each function. -Both how many times invoked and real time of start.") -(defvar profile-max-fun-name 0 "Max length of name of any function profiled.") -(defvar profile-temp-result- nil "Should NOT be used anywhere else.") -(defvar profile-time (cons 0 0) "Used to return result from a filter.") -(defvar profile-buffer "*profile*" "Name of profile buffer.") - -;;; -;;; F U N C T I O N S -;;; - -(defun profile-functions (&optional flist) - "Profile all the functions listed in `profile-functions-list'. -With argument FLIST, use the list FLIST instead." - (interactive "P") - (if (null flist) (setq flist profile-functions-list)) - (mapcar 'profile-a-function flist)) - -(defun profile-filter (process input) - "Filter for the timer process. Sets `profile-time' to the returned time." - (if (zerop (string-match "\\." input)) - (error "Bad output from %s" profile-timer-program) - (setcar profile-time - (string-to-int (substring input 0 (match-beginning 0)))) - (setcdr profile-time - (string-to-int (substring input (match-end 0)))))) - - -(defun profile-print (entry) - "Print one ENTRY (from `profile-time-list')." - (let* ((calls (car (cdr entry))) - (timec (cdr (cdr entry))) - (time (+ (car timec) (/ (cdr timec) (float profile-million)))) - (avgtime 0.0)) - (insert (format (concat "%-" - (int-to-string profile-max-fun-name) - "s%8d%11d.%06d") - (car entry) calls (car timec) (cdr timec)) - (if (zerop calls) - "\n" - (format "%12d.%06d\n" - (truncate (setq avgtime (/ time calls))) - (truncate (* (- avgtime (ftruncate avgtime)) - profile-million)))) - ))) - -(defun profile-results () - "Display profiling results in the buffer `*profile*'. -\(The buffer name comes from `profile-buffer'.)" - (interactive) - (switch-to-buffer profile-buffer) - (erase-buffer) - (insert "Function" (make-string (- profile-max-fun-name 6) ? )) - (insert " Calls Total time (sec) Avg time per call\n") - (insert (make-string profile-max-fun-name ?=) " ") - (insert "====== ================ =================\n") - (mapcar 'profile-print profile-time-list)) - -(defun profile-reset-timer () - (process-send-string profile-timer-process "z\n")) - -(defun profile-check-zero-init-times (entry) - "If ENTRY has non zero time, give an error." - (let ((time (cdr (cdr entry)))) - (if (and (zerop (car time)) (zerop (cdr time))) nil ; OK - (error "Process timer died while making performance profile.")))) - -(defun profile-get-time () - "Get time from timer process into `profile-time'." - ;; first time or if process dies - (if (and (processp profile-timer-process) - (eq 'run (process-status profile-timer-process))) nil - (setq profile-timer-process;; [re]start the timer process - (start-process "timer" - (get-buffer-create profile-buffer) - profile-timer-program)) - (set-process-filter profile-timer-process 'profile-filter) - (process-kill-without-query profile-timer-process) - (profile-reset-timer) - ;; check if timer died during time measurement - (mapcar 'profile-check-zero-init-times profile-init-list)) - ;; make timer process return current time - (process-send-string profile-timer-process "p\n") - (accept-process-output)) - -(defun profile-find-function (fun flist) - "Linear search for FUN in FLIST." - (if (null flist) nil - (if (eq fun (car (car flist))) (cdr (car flist)) - (profile-find-function fun (cdr flist))))) - -(defun profile-start-function (fun) - "On entry, keep current time for function FUN." - ;; assumes that profile-time contains the current time - (let ((init-time (profile-find-function fun profile-init-list))) - (if (null init-time) (error "Function %s missing from list" fun)) - (if (not (zerop (car init-time)));; is it a recursive call ? - (setcar init-time (1+ (car init-time))) - (setcar init-time 1) ; mark first entry - (setq init-time (cdr init-time)) - (setcar init-time (car profile-time)) - (setcdr init-time (cdr profile-time))) - )) - -(defconst profile-million 1000000) - -(defun profile-update-function (fun) - "When the call to the function FUN is finished, add its run time." - ;; assumes that profile-time contains the current time - (let ((init-time (profile-find-function fun profile-init-list)) - (accum (profile-find-function fun profile-time-list)) - calls time sec usec) - (if (or (null init-time) - (null accum)) (error "Function %s missing from list" fun)) - (setq calls (car accum)) - (setq time (cdr accum)) - (setcar init-time (1- (car init-time))) ; pop one level in recursion - (if (not (zerop (car init-time))) - nil ; in some recursion level, - ; do not update cumulated time - (setcar accum (1+ calls)) - (setq init-time (cdr init-time)) - (setq sec (- (car profile-time) (car init-time)) - usec (- (cdr profile-time) (cdr init-time))) - (setcar init-time 0) ; reset time to check for error - (setcdr init-time 0) ; in case timer process dies - (if (>= usec 0) nil - (setq usec (+ usec profile-million)) - (setq sec (1- sec))) - (setcar time (+ sec (car time))) - (setcdr time (+ usec (cdr time))) - (if (< (cdr time) profile-million) nil - (setcar time (1+ (car time))) - (setcdr time (- (cdr time) profile-million))) - ))) - -(defun profile-convert-byte-code (function) - (let ((defn (symbol-function function))) - (if (byte-code-function-p defn) - ;; It is a compiled code object. - (let* ((contents (append defn nil)) - (body - (list (list 'byte-code (nth 1 contents) - (nth 2 contents) (nth 3 contents))))) - (if (nthcdr 5 contents) - (setq body (cons (list 'interactive (nth 5 contents)) body))) - (if (nth 4 contents) - ;; 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))) - (fset function (cons 'lambda (cons (car contents) body))))))) - -(defun profile-a-function (fun) - "Profile the function FUN." - (interactive "aFunction to profile: ") - (profile-convert-byte-code fun) - (let ((def (symbol-function fun)) (funlen (length (symbol-name fun)))) - (if (eq (car def) 'lambda) nil - (error "To profile: %s must be a user-defined function" fun)) - (setq profile-time-list ; add a new entry - (cons (cons fun (cons 0 (cons 0 0))) profile-time-list)) - (setq profile-init-list ; add a new entry - (cons (cons fun (cons 0 (cons 0 0))) profile-init-list)) - (if (< profile-max-fun-name funlen) (setq profile-max-fun-name funlen)) - (fset fun (profile-fix-fun fun def)))) - -(defun profile-fix-fun (fun def) - "Take function FUN and return it fixed for profiling. -DEF is (symbol-function FUN)." - (let (prefix first second third (count 2) inter suffix) - (if (< (length def) 3) - nil ; nothing to see - (setq first (car def) second (car (cdr def)) - third (car (nthcdr 2 def))) - (setq prefix (list first second)) - ;; Skip the doc string, if there is a string - ;; which serves only as a doc string, - ;; and put it in PREFIX. - (if (or (not (stringp third)) (not (nthcdr 3 def))) - ;; Either no doc string, or it is also the function value. - (setq inter third) - ;; Skip the doc string, - (setq count 3 - prefix (nconc prefix (list third)) - inter (car (nthcdr 3 def)))) - ;; Check for an interactive spec. - ;; If found, put it inu PREFIX and skip it. - (if (not (and (listp inter) - (eq (car inter) 'interactive))) - nil - (setq prefix (nconc prefix (list inter))) - (setq count (1+ count))) ; skip this sexp for suffix - ;; Set SUFFIX to the function body forms. - (setq suffix (nthcdr count def)) - (if (equal (car suffix) '(profile-get-time)) - nil - ;; Prepare new function definition. - (nconc prefix - (list '(profile-get-time)) ; read time - (list (list 'profile-start-function - (list 'quote fun))) - (list (list 'setq 'profile-temp-result- - (nconc (list 'progn) suffix))) - (list '(profile-get-time)) ; read time - (list (list 'profile-update-function - (list 'quote fun))) - (list 'profile-temp-result-) - ))))) - -(defun profile-restore-fun (fun) - "Restore profiled function FUN to its original state." - (let ((def (symbol-function (car fun))) body index) - ;; move index beyond header - (setq index (cdr def)) - (if (stringp (car (cdr index))) (setq index (cdr index))) - (if (and (listp (car (cdr index))) - (eq (car (car (cdr index))) 'interactive)) - (setq index (cdr index))) - (setq body (car (nthcdr 3 index))) - (if (and (listp body) ; the right element ? - (eq (car (cdr body)) 'profile-temp-result-)) - (setcdr index (cdr (car (cdr (cdr body)))))))) - -(defun profile-finish () - "Stop profiling functions. Clear all the settings." - (interactive) - (mapcar 'profile-restore-fun profile-time-list) - (setq profile-max-fun-name 0) - (setq profile-time-list nil) - (setq profile-init-list nil)) - -(defun profile-quit () - "Kill the timer process." - (interactive) - (process-send-string profile-timer-process "q\n")) - -;;; profile.el ends here diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el deleted file mode 100644 index ac5a72a8e67..00000000000 --- a/lisp/emacs-lisp/ring.el +++ /dev/null @@ -1,135 +0,0 @@ -;;; ring.el --- handle rings of items - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: extensions - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This code defines a ring data structure. A ring is a -;; (hd-index length . vector) -;; list. You can insert to, remove from, and rotate a ring. When the ring -;; fills up, insertions cause the oldest elts to be quietly dropped. -;; -;; In ring-ref, 0 is the index of the newest element. Higher indexes -;; correspond to older elements until they wrap. -;; -;; hd-index = index of the newest item on the ring. -;; length = number of ring items. -;; -;; These functions are used by the input history mechanism, but they can -;; be used for other purposes as well. - -;;; Code: - -;;;###autoload -(defun ring-p (x) - "Returns t if X is a ring; nil otherwise." - (and (consp x) (integerp (car x)) - (consp (cdr x)) (integerp (car (cdr x))) - (vectorp (cdr (cdr x))))) - -;;;###autoload -(defun make-ring (size) - "Make a ring that can contain SIZE elements." - (cons 0 (cons 0 (make-vector size nil)))) - -(defun ring-insert-at-beginning (ring item) - "Add to RING the item ITEM. Add it at the front (the early end)." - (let* ((vec (cdr (cdr ring))) - (veclen (length vec)) - (hd (car ring)) - (ln (car (cdr ring)))) - (setq ln (min veclen (1+ ln)) - hd (ring-minus1 hd veclen)) - (aset vec hd item) - (setcar ring hd) - (setcar (cdr ring) ln))) - -(defun ring-plus1 (index veclen) - "INDEX+1, with wraparound" - (let ((new-index (+ index 1))) - (if (= new-index veclen) 0 new-index))) - -(defun ring-minus1 (index veclen) - "INDEX-1, with wraparound" - (- (if (= 0 index) veclen index) 1)) - -(defun ring-length (ring) - "Number of elements in the ring." - (car (cdr ring))) - -(defun ring-empty-p (ring) - (= 0 (car (cdr ring)))) - -(defun ring-index (index head ringlen veclen) - (setq index (mod index ringlen)) - (mod (1- (+ head (- ringlen index))) veclen)) - -(defun ring-insert (ring item) - "Insert onto ring RING the item ITEM, as the newest (last) item. -If the ring is full, dump the oldest item to make room." - (let* ((vec (cdr (cdr ring))) - (veclen (length vec)) - (hd (car ring)) - (ln (car (cdr ring)))) - (prog1 - (aset vec (mod (+ hd ln) veclen) item) - (if (= ln veclen) - (setcar ring (ring-plus1 hd veclen)) - (setcar (cdr ring) (1+ ln)))))) - -(defun ring-remove (ring &optional index) - "Remove an item from the RING. Return the removed item. -If optional INDEX is nil, remove the oldest item. If it's -numeric, remove the element indexed." - (if (ring-empty-p ring) - (error "Ring empty") - (let* ((hd (car ring)) - (ln (car (cdr ring))) - (vec (cdr (cdr ring))) - (veclen (length vec)) - (tl (mod (1- (+ hd ln)) veclen)) - oldelt) - (if (null index) - (setq index (1- ln))) - (setq index (ring-index index hd ln veclen)) - (setq oldelt (aref vec index)) - (while (/= index tl) - (aset vec index (aref vec (ring-plus1 index veclen))) - (setq index (ring-plus1 index veclen))) - (aset vec tl nil) - (setcar (cdr ring) (1- ln)) - oldelt))) - -(defun ring-ref (ring index) - "Returns RING's INDEX element. -INDEX need not be <= the ring length, the appropriate modulo operation -will be performed. Element 0 is the most recently inserted; higher indices -correspond to older elements until they wrap." - (if (ring-empty-p ring) - (error "indexed empty ring") - (let* ((hd (car ring)) (ln (car (cdr ring))) (vec (cdr (cdr ring)))) - (aref vec (ring-index index hd ln (length vec)))))) - -(provide 'ring) - -;;; ring.el ends here diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el deleted file mode 100644 index 73650de88c8..00000000000 --- a/lisp/emacs-lisp/shadow.el +++ /dev/null @@ -1,203 +0,0 @@ -;;; shadow.el --- Locate Emacs Lisp file shadowings. - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Terry Jones <terry@santafe.edu> -;; Keywords: lisp -;; Created: 15 December 1995 - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The functions in this file detect (`find-emacs-lisp-shadows') -;; and display (`list-load-path-shadows') potential load-path -;; problems that arise when Emacs Lisp files "shadow" each other. -;; -;; For example, a file XXX.el early in one's load-path will shadow -;; a file with the same name in a later load-path directory. When -;; this is unintentional, it may result in problems that could have -;; been easily avoided. This occurs often (to me) when installing a -;; new version of emacs and something in the site-lisp directory -;; has been updated and added to the emacs distribution. The old -;; version, now outdated, shadows the new one. This is obviously -;; undesirable. -;; -;; The `list-load-path-shadows' function was run when you installed -;; this version of emacs. To run it by hand in emacs: -;; -;; M-x load-library RET shadow RET -;; M-x list-load-path-shadows -;; -;; or run it non-interactively via: -;; -;; emacs -batch -l shadow.el -f list-load-path-shadows -;; -;; Thanks to Francesco Potorti` <pot@cnuce.cnr.it> for suggestions, -;; rewritings & speedups. - -;;; Code: - -(defun find-emacs-lisp-shadows (&optional path) - "Return a list of Emacs Lisp files that create shadows. -This function does the work for `list-load-path-shadows'. - -We traverse PATH looking for shadows, and return a \(possibly empty\) -even-length list of files. A file in this list at position 2i shadows -the file in position 2i+1. Emacs Lisp file suffixes \(.el and .elc\) -are stripped from the file names in the list. - -See the documentation for `list-load-path-shadows' for further information." - - (or path (setq path load-path)) - - (let (true-names ; List of dirs considered. - shadows ; List of shadowings, to be returned. - files ; File names ever seen, with dirs. - dir ; The dir being currently scanned. - curr-files ; This dir's Emacs Lisp files. - orig-dir ; Where the file was first seen. - files-seen-this-dir ; Files seen so far in this dir. - file) ; The current file. - - - (while path - - (setq dir (file-truename (or (car path) "."))) - (if (member dir true-names) - ;; We have already considered this PATH redundant directory. - ;; Show the redundancy if we are interactiver, unless the PATH - ;; dir is nil or "." (these redundant directories are just a - ;; result of the current working directory, and are therefore - ;; not always redundant). - (or noninteractive - (and (car path) - (not (string= (car path) ".")) - (message "Ignoring redundant directory %s" (car path)))) - - (setq true-names (append true-names (list dir))) - (setq dir (or (car path) ".")) - (setq curr-files (if (file-accessible-directory-p dir) - (directory-files dir nil ".\\.elc?$" t))) - (and curr-files - (not noninteractive) - (message "Checking %d files in %s..." (length curr-files) dir)) - - (setq files-seen-this-dir nil) - - (while curr-files - - (setq file (car curr-files)) - (setq file (substring - file 0 (if (string= (substring file -1) "c") -4 -3))) - - ;; 'file' now contains the current file name, with no suffix. - (if (member file files-seen-this-dir) - nil - - ;; File has not been seen yet in this directory. - ;; This test prevents us declaring that XXX.el shadows - ;; XXX.elc (or vice-versa) when they are in the same directory. - (setq files-seen-this-dir (cons file files-seen-this-dir)) - - (if (setq orig-dir (assoc file files)) - ;; This file was seen before, we have a shadowing. - (setq shadows - (append shadows - (list (concat (cdr orig-dir) "/" file) - (concat dir "/" file)))) - - ;; Not seen before, add it to the list of seen files. - (setq files (cons (cons file dir) files)))) - - (setq curr-files (cdr curr-files)))) - (setq path (cdr path))) - - ;; Return the list of shadowings. - shadows)) - - -;;;###autoload -(defun list-load-path-shadows () - - "Display a list of Emacs Lisp files that shadow other files. - -This function lists potential load-path problems. Directories in the -`load-path' variable are searched, in order, for Emacs Lisp -files. When a previously encountered file name is found again, a -message is displayed indicating that the later file is \"hidden\" by -the earlier. - -For example, suppose `load-path' is set to - -\(\"/usr/gnu/emacs/site-lisp\" \"/usr/gnu/emacs/share/emacs/19.30/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. - -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 -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\). - -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 -considered to shadow a later file XXX.el, and vice-versa. - -When run interactively, the shadowings \(if any\) are displayed in a -buffer called `*Shadows*'. Shadowings are located by calling the -\(non-interactive\) companion function, `find-emacs-lisp-shadows'." - - (interactive) - (let* ((shadows (find-emacs-lisp-shadows)) - (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")))) - (if (interactive-p) - (save-excursion - ;; We are interactive. - ;; Create the *Shadows* buffer and display shadowings there. - (let ((output-buffer (get-buffer-create "*Shadows*"))) - (display-buffer output-buffer) - (set-buffer output-buffer) - (erase-buffer) - (while shadows - (insert (format "%s hides %s\n" (car shadows) - (car (cdr shadows)))) - (setq shadows (cdr (cdr shadows)))) - (insert msg "\n"))) - ;; We are non-interactive, print shadows via message. - (while shadows - (message "%s hides %s" (car shadows) (car (cdr shadows))) - (setq shadows (cdr (cdr shadows)))) - (message "%s" msg)))) - -(provide 'shadow) - -;;; shadow.el ends here diff --git a/lisp/emacs-lisp/tq.el b/lisp/emacs-lisp/tq.el deleted file mode 100644 index 0de2c48e638..00000000000 --- a/lisp/emacs-lisp/tq.el +++ /dev/null @@ -1,123 +0,0 @@ -;;; tq.el --- utility to maintain a transaction queue - -;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc. - -;; Author: Scott Draves <spot@cs.cmu.edu> -;; Adapted-By: ESR -;; Keywords: extensions - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; manages receiving a stream asynchronously, -;;; parsing it into transactions, and then calling -;;; handler functions - -;;; Our basic structure is the queue/process/buffer triple. Each entry -;;; of the queue is a regexp/closure/function triple. We buffer -;;; bytes from the process until we see the regexp at the head of the -;;; queue. Then we call the function with the closure and the -;;; collected bytes. - -;;; Code: - -;;;###autoload -(defun tq-create (process) - "Create and return a transaction queue communicating with PROCESS. -PROCESS should be a subprocess capable of sending and receiving -streams of bytes. It may be a local process, or it may be connected -to a tcp server on another machine." - (let ((tq (cons nil (cons process - (generate-new-buffer - (concat " tq-temp-" - (process-name process))))))) - (set-process-filter process - (`(lambda (proc string) - (tq-filter '(, tq) string)))) - tq)) - -;;; accessors -(defun tq-queue (tq) (car tq)) -(defun tq-process (tq) (car (cdr tq))) -(defun tq-buffer (tq) (cdr (cdr tq))) - -(defun tq-queue-add (tq re closure fn) - (setcar tq (nconc (tq-queue tq) - (cons (cons re (cons closure fn)) nil))) - 'ok) - -(defun tq-queue-head-regexp (tq) (car (car (tq-queue tq)))) -(defun tq-queue-head-fn (tq) (cdr (cdr (car (tq-queue tq))))) -(defun tq-queue-head-closure (tq) (car (cdr (car (tq-queue tq))))) -(defun tq-queue-empty (tq) (not (tq-queue tq))) -(defun tq-queue-pop (tq) (setcar tq (cdr (car tq))) (null (car tq))) - - -;;; must add to queue before sending! -(defun tq-enqueue (tq question regexp closure fn) - "Add a transaction to transaction queue TQ. -This sends the string QUESTION to the process that TQ communicates with. -When the corresponding answer comes back, we call FN -with two arguments: CLOSURE, and the answer to the question. -REGEXP is a regular expression to match the entire answer; -that's how we tell where the answer ends." - (tq-queue-add tq regexp closure fn) - (process-send-string (tq-process tq) question)) - -(defun tq-close (tq) - "Shut down transaction queue TQ, terminating the process." - (delete-process (tq-process tq)) - (kill-buffer (tq-buffer tq))) - -(defun tq-filter (tq string) - "Append STRING to the TQ's buffer; then process the new data." - (let ((old-buffer (current-buffer))) - (unwind-protect - (progn - (set-buffer (tq-buffer tq)) - (goto-char (point-max)) - (insert string) - (tq-process-buffer tq)) - (set-buffer old-buffer)))) - -(defun tq-process-buffer (tq) - "Check TQ's buffer for the regexp at the head of the queue." - (set-buffer (tq-buffer tq)) - (if (= 0 (buffer-size)) () - (if (tq-queue-empty tq) - (let ((buf (generate-new-buffer "*spurious*"))) - (copy-to-buffer buf (point-min) (point-max)) - (delete-region (point-min) (point)) - (pop-to-buffer buf nil) - (error "Spurious communication from process %s, see buffer %s" - (process-name (tq-process tq)) - (buffer-name buf))) - (goto-char (point-min)) - (if (re-search-forward (tq-queue-head-regexp tq) nil t) - (let ((answer (buffer-substring (point-min) (point)))) - (delete-region (point-min) (point)) - (funcall (tq-queue-head-fn tq) - (tq-queue-head-closure tq) - answer) - (tq-queue-pop tq) - (tq-process-buffer tq)))))) - -(provide 'tq) - -;;; tq.el ends here diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el deleted file mode 100644 index 40008e29a19..00000000000 --- a/lisp/emacs-lisp/trace.el +++ /dev/null @@ -1,314 +0,0 @@ -;;; trace.el --- tracing facility for Emacs Lisp functions - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Hans Chalupsky <hans@cs.buffalo.edu> -;; Created: 15 Dec 1992 -;; Keywords: tools, 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; LCD Archive Entry: -;; trace|Hans Chalupsky|hans@cs.buffalo.edu| -;; Tracing facility for Emacs Lisp functions| -;; 1993/05/18 00:41:16|2.0|~/packages/trace.el.Z| - - -;;; Commentary: - -;; Introduction: -;; ============= -;; A simple trace package that utilizes advice.el. It generates trace -;; information in a Lisp-style fashion and inserts it into a trace output -;; buffer. Tracing can be done in the background (or silently) so that -;; generation of trace output won't interfere with what you are currently -;; doing. - -;; How to get the latest trace.el: -;; =============================== -;; You can get the latest version of this file either via anonymous ftp from -;; ftp.cs.buffalo.edu (128.205.32.9) with pathname /pub/Emacs/trace.el, -;; or send email to hans@cs.buffalo.edu and I'll mail it to you. - -;; 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 -;; value of their arguments. -;; - Only functions/macros/subrs that are called via their function cell will -;; generate trace output, hence, you won't get trace output for: -;; + Subrs called directly from other subrs/C-code -;; + Compiled calls to subrs that have special byte-codes associated -;; with them (e.g., car, cdr, ...) -;; + 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"). - -;; Comments, suggestions, bug reports -;; ================================== -;; are strongly appreciated, please email them to hans@cs.buffalo.edu. - -;; Usage: -;; ====== -;; - To trace a function say `M-x trace-function' which will ask you for the -;; name of the function/subr/macro to trace, as well as for the buffer -;; into which trace output should go. -;; - If you want to trace a function that switches buffers or does other -;; display oriented stuff use `M-x trace-function-background' which will -;; generate the trace output silently in the background without popping -;; up windows and doing other irritating stuff. -;; - To untrace a function say `M-x untrace-function'. -;; - To untrace all currently traced functions say `M-x untrace-all'. - -;; Examples: -;; ========= -;; -;; (defun fact (n) -;; (if (= n 0) 1 -;; (* n (fact (1- n))))) -;; fact -;; -;; (trace-function 'fact) -;; fact -;; -;; Now, evaluating this... -;; -;; (fact 4) -;; 24 -;; -;; ...will generate the following in *trace-buffer*: -;; -;; 1 -> fact: n=4 -;; | 2 -> fact: n=3 -;; | | 3 -> fact: n=2 -;; | | | 4 -> fact: n=1 -;; | | | | 5 -> fact: n=0 -;; | | | | 5 <- fact: 1 -;; | | | 4 <- fact: 1 -;; | | 3 <- fact: 2 -;; | 2 <- fact: 6 -;; 1 <- fact: 24 -;; -;; -;; (defun ack (x y z) -;; (if (= x 0) -;; (+ y z) -;; (if (and (<= x 2) (= z 0)) -;; (1- x) -;; (if (and (> x 2) (= z 0)) -;; y -;; (ack (1- x) y (ack x y (1- z))))))) -;; ack -;; -;; (trace-function 'ack) -;; ack -;; -;; Try this for some interesting trace output: -;; -;; (ack 3 3 1) -;; 27 -;; -;; -;; The following does something similar to the functionality of the package -;; log-message.el by Robert Potter, which is giving you a chance to look at -;; messages that might have whizzed by too quickly (you won't see subr -;; generated messages though): -;; -;; (trace-function-background 'message "*Message Log*") - - -;;; Change Log: - -;; Revision 2.0 1993/05/18 00:41:16 hans -;; * Adapted for advice.el 2.0; it now also works -;; for GNU Emacs-19 and Lemacs -;; * Separate function `trace-function-background' -;; * Separate pieces of advice for foreground and background tracing -;; * Less insane handling of interactive trace buffer specification -;; * String arguments and values are now printed properly -;; -;; Revision 1.1 1992/12/15 22:45:15 hans -;; * Created, first public release - - -;;; Code: - -(require 'advice) - -;;;###autoload -(defvar trace-buffer "*trace-output*" - "*Trace output will by default go to that buffer.") - -;; Current level of traced function invocation: -(defvar trace-level 0) - -;; Semi-cryptic name used for a piece of trace advice: -(defvar trace-advice-name 'trace-function\ ) - -;; Used to separate new trace output from previous traced runs: -(defvar trace-separator (format "%s\n" (make-string 70 ?=))) - -(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 - (mapconcat (function - (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: - (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 - (cond (background - (` (advice - lambda () - (let ((trace-level (1+ trace-level)) - (trace-buffer (get-buffer-create (, buffer)))) - (save-excursion - (set-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 - (save-excursion - (set-buffer trace-buffer) - (goto-char (point-max)) - (insert - (trace-exit-message - '(, function) trace-level ad-return-value))))))) - (t (` (advice - lambda () - (let ((trace-level (1+ trace-level)) - (trace-buffer (get-buffer-create (, buffer)))) - (pop-to-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 - (pop-to-buffer trace-buffer) - (goto-char (point-max)) - (insert - (trace-exit-message - '(, function) trace-level ad-return-value))))))))) - -(defun trace-function-internal (function buffer background) - ;; Adds trace advice for FUNCTION and activates it. - (ad-add-advice - function - (trace-make-advice function (or buffer trace-buffer) background) - 'around 'last) - (ad-activate function nil)) - -(defun trace-is-traced (function) - (ad-find-advice function 'around trace-advice-name)) - -;;;###autoload -(defun trace-function (function &optional buffer) - "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)) - -;;;###autoload -(defun trace-function-background (function &optional buffer) - "Traces FUNCTION with trace output going quietly 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!! Trace output will quietly go to BUFFER without changing -the window or buffer configuration at all." - (interactive - (list - (intern - (completing-read "Trace function in background: " obarray 'fboundp t)) - (read-buffer "Output to buffer: " trace-buffer))) - (trace-function-internal function buffer t)) - -(defun untrace-function (function) - "Untraces FUNCTION and possibly activates all remaining advice. -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))) - (cond ((trace-is-traced function) - (ad-remove-advice function 'around trace-advice-name) - (ad-update function)))) - -(defun untrace-all () - "Untraces all currently traced functions." - (interactive) - (ad-do-advised-functions (function) - (untrace-function function))) - -(provide 'trace) - -;;; trace.el ends here |